summaryrefslogtreecommitdiff
path: root/Build/source/texk
diff options
context:
space:
mode:
authorMartin Schröder <martin@oneiros.de>2008-03-24 15:47:15 +0000
committerMartin Schröder <martin@oneiros.de>2008-03-24 15:47:15 +0000
commit0b5550c241229764120d133af80a0cbab5937ddd (patch)
tree81309c18d6f0deba7407813cf15b9add2db375d1 /Build/source/texk
parent51f55df6a36ce376952a1f2b30bdb4dd0e06548d (diff)
First step of importing luatex (up to r1121)
git-svn-id: svn://tug.org/texlive/trunk@7124 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/texk')
-rw-r--r--Build/source/texk/web2c/Makefile.in9
-rw-r--r--Build/source/texk/web2c/luatexdir/.indent.pro12
-rw-r--r--Build/source/texk/web2c/luatexdir/ChangeLog69
-rw-r--r--Build/source/texk/web2c/luatexdir/Makefile.in141
-rw-r--r--Build/source/texk/web2c/luatexdir/NEWS537
-rw-r--r--Build/source/texk/web2c/luatexdir/README87
-rw-r--r--Build/source/texk/web2c/luatexdir/avl.c893
-rw-r--r--Build/source/texk/web2c/luatexdir/avl.h115
-rw-r--r--Build/source/texk/web2c/luatexdir/avlstuff.c180
-rw-r--r--Build/source/texk/web2c/luatexdir/avlstuff.h29
-rw-r--r--Build/source/texk/web2c/luatexdir/change-files.txt35
-rw-r--r--Build/source/texk/web2c/luatexdir/depend.mk2874
-rw-r--r--Build/source/texk/web2c/luatexdir/font/.indent.pro12
-rw-r--r--Build/source/texk/web2c/luatexdir/font/dofont.c183
-rw-r--r--Build/source/texk/web2c/luatexdir/font/luafont.c1733
-rw-r--r--Build/source/texk/web2c/luatexdir/font/macnames.c312
-rw-r--r--Build/source/texk/web2c/luatexdir/font/mapfile.c967
-rw-r--r--Build/source/texk/web2c/luatexdir/font/pkin.c439
-rw-r--r--Build/source/texk/web2c/luatexdir/font/sfnt.c647
-rw-r--r--Build/source/texk/web2c/luatexdir/font/sfnt.h197
-rw-r--r--Build/source/texk/web2c/luatexdir/font/subfont.c264
-rw-r--r--Build/source/texk/web2c/luatexdir/font/subfont.txt74
-rw-r--r--Build/source/texk/web2c/luatexdir/font/texfont.c1094
-rw-r--r--Build/source/texk/web2c/luatexdir/font/texfont.h524
-rw-r--r--Build/source/texk/web2c/luatexdir/font/tfmofm.c1005
-rw-r--r--Build/source/texk/web2c/luatexdir/font/tounicode.c604
-rw-r--r--Build/source/texk/web2c/luatexdir/font/tt_glyf.c658
-rw-r--r--Build/source/texk/web2c/luatexdir/font/tt_glyf.h60
-rw-r--r--Build/source/texk/web2c/luatexdir/font/tt_table.c483
-rw-r--r--Build/source/texk/web2c/luatexdir/font/tt_table.h193
-rw-r--r--Build/source/texk/web2c/luatexdir/font/vfovf.c1349
-rw-r--r--Build/source/texk/web2c/luatexdir/font/vfpacket.c377
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writecff.c3381
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writecff.h349
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writeenc.c183
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writefont.c885
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writet1.c1768
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writet3.c348
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writettf.c1509
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writettf.h172
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writetype0.c124
-rw-r--r--Build/source/texk/web2c/luatexdir/font/writetype2.c422
-rw-r--r--Build/source/texk/web2c/luatexdir/hyphen.h60
-rw-r--r--Build/source/texk/web2c/luatexdir/image/.indent.pro12
-rw-r--r--Build/source/texk/web2c/luatexdir/image/epdf.c107
-rw-r--r--Build/source/texk/web2c/luatexdir/image/epdf.h125
-rw-r--r--Build/source/texk/web2c/luatexdir/image/image.h223
-rw-r--r--Build/source/texk/web2c/luatexdir/image/pdftoepdf.cc1008
-rw-r--r--Build/source/texk/web2c/luatexdir/image/writeimg.c677
-rw-r--r--Build/source/texk/web2c/luatexdir/image/writejbig2.c749
-rw-r--r--Build/source/texk/web2c/luatexdir/image/writejbig2.h151
-rw-r--r--Build/source/texk/web2c/luatexdir/image/writejpg.c277
-rw-r--r--Build/source/texk/web2c/luatexdir/image/writepng.c635
-rw-r--r--Build/source/texk/web2c/luatexdir/lang/hnjalloc.c72
-rw-r--r--Build/source/texk/web2c/luatexdir/lang/hnjalloc.h46
-rw-r--r--Build/source/texk/web2c/luatexdir/lang/hyphen.c830
-rw-r--r--Build/source/texk/web2c/luatexdir/lang/texlang.c825
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/.indent.pro12
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c463
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lfontlib.c213
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/limglib.c714
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lkpselib.c272
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/llanglib.c219
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/llualib.c229
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lmplib.c1251
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lnodelib.c1967
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/loslibext.c627
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lpdflib.c127
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lstatslib.c211
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/ltexiolib.c117
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/ltexlib.c820
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/ltokenlib.c263
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luainit.c520
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luanode.c200
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luastuff.c310
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luatex.c343
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luatoken.c548
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/mp.w26173
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/psout.w5697
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/texluac.c199
-rw-r--r--Build/source/texk/web2c/luatexdir/luatangle.ch492
-rw-r--r--Build/source/texk/web2c/luatexdir/luatangle.web3328
-rw-r--r--Build/source/texk/web2c/luatexdir/luatex-api.h104
-rw-r--r--Build/source/texk/web2c/luatexdir/luatex.ch2623
-rw-r--r--Build/source/texk/web2c/luatexdir/luatex.defines560
-rw-r--r--Build/source/texk/web2c/luatexdir/luatex.h173
-rw-r--r--Build/source/texk/web2c/luatexdir/luatex.mk170
-rw-r--r--Build/source/texk/web2c/luatexdir/luatex.web35760
-rw-r--r--Build/source/texk/web2c/luatexdir/luatexextra.in42
-rw-r--r--Build/source/texk/web2c/luatexdir/luatexlib.mk214
-rw-r--r--Build/source/texk/web2c/luatexdir/macnames.c312
-rw-r--r--Build/source/texk/web2c/luatexdir/makecpool.c60
-rw-r--r--Build/source/texk/web2c/luatexdir/managed-sa.c245
-rw-r--r--Build/source/texk/web2c/luatexdir/managed-sa.h74
-rw-r--r--Build/source/texk/web2c/luatexdir/mathcodes.c191
-rw-r--r--Build/source/texk/web2c/luatexdir/nodes.h648
-rw-r--r--Build/source/texk/web2c/luatexdir/pdftosrc.1219
-rw-r--r--Build/source/texk/web2c/luatexdir/pdftosrc.cc178
-rw-r--r--Build/source/texk/web2c/luatexdir/pdftosrc.rc35
-rw-r--r--Build/source/texk/web2c/luatexdir/ptexlib.h615
-rw-r--r--Build/source/texk/web2c/luatexdir/ptexmac.h236
-rw-r--r--Build/source/texk/web2c/luatexdir/svnversion.h3
-rw-r--r--Build/source/texk/web2c/luatexdir/tex/linebreak.c2095
-rw-r--r--Build/source/texk/web2c/luatexdir/tex/postlinebreak.c512
-rw-r--r--Build/source/texk/web2c/luatexdir/tex/texnodes.c1694
-rw-r--r--Build/source/texk/web2c/luatexdir/tex/texpdf.c169
-rw-r--r--Build/source/texk/web2c/luatexdir/tex/textoken.c753
-rw-r--r--Build/source/texk/web2c/luatexdir/textcodes.c278
-rw-r--r--Build/source/texk/web2c/luatexdir/tokens.h68
-rw-r--r--Build/source/texk/web2c/luatexdir/ttf2afm.c1053
-rw-r--r--Build/source/texk/web2c/luatexdir/ttf2afm.rc35
-rw-r--r--Build/source/texk/web2c/luatexdir/utils.c1798
-rw-r--r--Build/source/texk/web2c/luatexdir/writezip.c98
-rw-r--r--Build/source/texk/web2c/web2c/coerce.h5
-rw-r--r--Build/source/texk/web2c/web2c/splitup.c7
115 files changed, 127432 insertions, 4 deletions
diff --git a/Build/source/texk/web2c/Makefile.in b/Build/source/texk/web2c/Makefile.in
index 0ec24cdef95..bd687a9ac8f 100644
--- a/Build/source/texk/web2c/Makefile.in
+++ b/Build/source/texk/web2c/Makefile.in
@@ -1,4 +1,4 @@
-# $Id: //depot/Build/source.development/TeX/texk/web2c/Makefile.in#66 $
+# $Id$
# @configure_input@
# Makefile for web2c --kb@mail.tug.org. Public domain.
version = @WEB2CVERSION@
@@ -555,6 +555,7 @@ trip-clean:
#
# Helper makefile fragment for pdf*tex.
kpse_include pdftexdir/pdftexlib.mk
+#LUATEXkpse_include pdftexdir/luatexlib.mk
#
# Makefile fragments:
kpse_include etexdir/etex.mk
@@ -562,6 +563,7 @@ kpse_include omegadir/omega.mk
kpse_include alephdir/aleph.mk
kpse_include pdftexdir/pdftex.mk
kpse_include xetexdir/xetex.mk
+#LUATEXkpse_include luatexdir/luatex.mk
#
# non-engine programs.
@@ -575,7 +577,8 @@ programs = bibtex ctangle ctie cweave dvicopy dvitomp dvitype gftodvi gftopk \
engines = $(tex) $(etex) $(mf) $(mfn) $(metapost) \
$(omega) $(aleph) \
$(pdftex) $(pdfetex) \
- $(xetex)
+ $(xetex) #LUATEX\
+#LUATEX $(luatex)
programs: $(programs) $(engines) $(mpware_programs) \
$(omegafonts_programs) $(otps_programs) $(pdftosrc)
@@ -1125,7 +1128,7 @@ installcheck:
#
# Cleaning.
-all_subdirs = doc lib man $(mpware) web2c window $(omegafonts) $(otps) $(pdftexdir) $(mpostdir)
+all_subdirs = doc lib man $(mpware) web2c window $(omegafonts) $(otps) $(pdftexdir) $(mpostdir) #LUATEX $(luatexdir)
# Having a multiple-target rule with the subdir loop fails because of
# the dependencies introduced by clean.mk. Yet, we want the
diff --git a/Build/source/texk/web2c/luatexdir/.indent.pro b/Build/source/texk/web2c/luatexdir/.indent.pro
new file mode 100644
index 00000000000..e9e690f1ba8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/.indent.pro
@@ -0,0 +1,12 @@
+/* $Id$ */
+--k-and-r-style
+--blank-lines-after-procedures
+--line-length 80
+--procnames-start-lines
+--no-space-after-function-call-names
+--dont-break-procedure-type
+--space-after-cast
+/* this does not work in indent 2.2.6 :-( */
+--no-tabs
+/* this is new in indent 2.2.9 */
+--preprocessor-indentation 2
diff --git a/Build/source/texk/web2c/luatexdir/ChangeLog b/Build/source/texk/web2c/luatexdir/ChangeLog
new file mode 100644
index 00000000000..d6004e43700
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/ChangeLog
@@ -0,0 +1,69 @@
+2004-08-21 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.ch2: Adapted to e-TeX version 2.2.
+
+2004-08-26 Olaf Weber <olaf@infovore.xs4all.nl>
+
+ * pdfetexextra.in: File was renamed from pdftexextra.h; the
+ current pdfTeX and e-TeX versions are substituted from
+ ../pdftexdir/pdftex.version and ../etexdir/etex.version. Variant
+ of code supplied by Peter Breitenlohner <peb@mppmu.mpg.de>.
+
+ * pdfetex.mk: Added rule to insert pdfTeX and e-TeX versions into
+ pdfetexextra.h. Variant of code supplied by Peter Breitenlohner
+ <peb@mppmu.mpg.de>.
+
+2004-08-25 Olaf Weber <olaf@infovore.xs4all.nl>
+
+ * pdfetex.mk: vadjust.ch moved from pdfxtexdir to pdftexdir.
+
+2004-08-17 Olaf Weber <olaf@infovore.xs4all.nl>
+
+ * pdfetex.mk: Resurrected etex.fix, there is again a need to
+ include late-breaking changes.
+
+2004-07-29 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.ch[12]: Somewhat rearrange handling of kern and math
+ nodes in order to reduce interference between eTeX and pdfTeX
+ change files.
+
+ * pdfetex.ch1 (hlist_out): Keep full mixed direction typesetting
+ code.
+
+2004-07-25 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.ch[12]: Reorganize additional command codes for convert
+ and last_item in order to reduce interference between eTeX and
+ pdfTeX change files.
+
+2004-07-23 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.ch[12], tex.ch[01]: Reorganize handling of banner
+ string in order to reduce interference between eTeX, pdfTeX,
+ and web2c change files.
+
+2004-07-22 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.ch[12]: Removed unused token types for pdfTeX's
+ additional token list parameters.
+
+2004-07-19 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.ch[12], tex.ch0: Reorganize handling of additional
+ token list and integer parameters and e-TeX's additional
+ penalties in order to reduce interference between eTeX, pdfTeX,
+ and web2c change files.
+
+ * pdfetex.mk (pdfetex.ch): Remove tex.ch2 from build rules.
+
+ * tex.ch2: Removed.
+
+2004-07-17 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pdfetex.mk: Rewrite build rules for pdfetex.{web,ch},
+ remove etex.{ch0,ch1,fix}, tex.ch2, and several non-dependencies.
+
+ * pdfetex.ch2: Adapt to eTeX changes.
+
+ * ChangeLog: New file.
diff --git a/Build/source/texk/web2c/luatexdir/Makefile.in b/Build/source/texk/web2c/luatexdir/Makefile.in
new file mode 100644
index 00000000000..a959a42d56b
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/Makefile.in
@@ -0,0 +1,141 @@
+# Makefile for libpdf - te@dbs.uni-hannover.de
+# $Id$
+
+kpse_include ../make/common.mk
+kpse_include ../make/programs.mk
+kpse_include ../make/library.mk
+
+kpathsea_srcdir_parent = $(srcdir)/../..
+kpathsea_dir_parent = ../..
+
+ALL_CXXFLAGS = @CXXFLAGS@ @DEFS@ $(XXCFLAGS) -I. -I$(srcdir) -I$(kpathsea_dir_parent) -I$(kpathsea_srcdir_parent) @LIBXPDFCPPFLAGS@ -I$(LIBOBSDCOMPATDIR) -I$(LIBOBSDCOMPATDIR)/.. -I$(LIBOBSDCOMPATFSRCDIR) -I$(LIBOBSDCOMPATFSRCDIR)/.. -I$(LIBPNGSRCDIR) -I$(ZLIBSRCDIR)
+CXX = @CXX@
+
+CTANGLE = ../ctangle
+
+.SUFFIXES: .cc .o
+.cc.o:
+ $(CXX) $(ALL_CXXFLAGS) -c $< -o $@
+
+# XCFLAGS=-Wstrict-prototypes -Wmissing-prototypes
+
+LIBPNGDIR=../../../libs/libpng
+LIBPNGSRCDIR=$(srcdir)/$(LIBPNGDIR)
+
+ZLIBDIR=../../../libs/zlib
+ZLIBSRCDIR=$(srcdir)/$(ZLIBDIR)
+
+LIBXPDFDIR=../../../libs/xpdf
+LIBXPDFSRCDIR=$(srcdir)/$(LIBXPDFDIR)
+
+LIBMD5DIR=../../../libs/md5
+LIBMD5SRCDIR=$(srcdir)/$(LIBMD5DIR)
+
+LIBOBSDCOMPATDIR=../../../libs/obsdcompat
+LIBOBSDCOMPATFSRCDIR=$(srcdir)/$(LIBOBSDCOMPATDIR)
+
+XCPPFLAGS=-I.. -I$(srcdir)/.. -I../.. -I$(srcdir)/../.. -I$(LIBMD5DIR) \
+ -I$(LIBMD5SRCDIR) @LIBPNGCPPFLAGS@ @ZLIBCPPFLAGS@ \
+ -I$(LIBXPDFDIR) -I$(LIBXPDFDIR)/.. -I$(LIBXPDFSRCDIR) -I$(LIBXPDFSRCDIR)/.. \
+ -I$(LIBOBSDCOMPATDIR) -I$(LIBOBSDCOMPATDIR)/.. -I$(LIBOBSDCOMPATFSRCDIR) \
+ -I$(LIBOBSDCOMPATFSRCDIR)/.. -DpdfTeX
+
+
+OBJS = \
+avl.o \
+avlstuff.o \
+font/mapfile.o \
+font/pkin.o \
+font/subfont.o \
+font/tounicode.o \
+font/vfpacket.o \
+font/writeenc.o \
+font/writefont.o \
+font/writet1.o \
+font/writet3.o \
+font/writettf.o \
+font/writetype0.o \
+font/writetype2.o \
+font/writecff.o \
+font/tt_glyf.o \
+font/tt_table.o \
+font/sfnt.o \
+font/texfont.o \
+font/tfmofm.o \
+font/vfovf.o \
+font/luafont.o \
+font/dofont.o \
+image/epdf.o \
+image/pdftoepdf.o \
+image/writeimg.o \
+image/writejbig2.o \
+image/writejpg.o \
+image/writepng.o \
+lua/loslibext.o \
+lua/lcallbacklib.o \
+lua/lkpselib.o \
+lua/llualib.o \
+lua/lnodelib.o \
+lua/lpdflib.o \
+lua/lstatslib.o \
+lua/ltexiolib.o \
+lua/ltexlib.o \
+lua/ltokenlib.o \
+lua/lfontlib.o \
+lua/texluac.o \
+lua/luainit.o \
+lua/luastuff.o \
+lua/luatex.o \
+lua/luatoken.o \
+lua/luanode.o \
+lua/llanglib.o \
+lua/limglib.o \
+lua/mp.o \
+lua/psout.o \
+lua/lmplib.o \
+lang/hnjalloc.o \
+lang/hyphen.o \
+lang/texlang.o \
+tex/linebreak.o \
+tex/postlinebreak.o \
+tex/texnodes.o \
+tex/textoken.o \
+tex/texpdf.o \
+managed-sa.o \
+mathcodes.o \
+textcodes.o \
+utils.o \
+writezip.o
+
+all: libpdf.a makecpool
+
+libpdf.a: lua/mp.c lua/psout.c $(OBJS)
+ rm -f $@
+ $(AR) $(ARFLAGS) $@ $(OBJS)
+ $(RANLIB) $@
+
+lua/mp.c: lua/mp.w
+ $(CTANGLE) $(srcdir)/lua/mp.w - lua/mp.c
+
+lua/psout.c: lua/psout.w
+ $(CTANGLE) $(srcdir)/lua/psout.w - lua/psout.c
+
+makecpool: makecpool.o
+ $(link_command) makecpool.o
+
+kpse_include ../make/clean.mk
+
+clean::
+ rm -f libpdf.a ttf2afm pdftosrc
+
+depend:
+ rm -f $(OBJS) $(srcdir)/depend.mk
+ for a in $(OBJS); do \
+ env XXCFLAGS="-MM -MT \$$@" XCFLAGS="-MM -MT \$$@" $(MAKE) -k $$a; \
+ touch $$a; \
+ grep -a -v "^$(CC)\|$(CXX)\|$(AR)\|make\|klibtool" $$a | \
+ sed 's: [^ ]*/\.\./libs/[^ ]*::g' >> $(srcdir)/depend.mk; \
+ done; \
+ rm -f $(OBJS)
+
+kpse_include luatexdir/depend.mk
diff --git a/Build/source/texk/web2c/luatexdir/NEWS b/Build/source/texk/web2c/luatexdir/NEWS
new file mode 100644
index 00000000000..626b5c95a0b
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/NEWS
@@ -0,0 +1,537 @@
+---------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-beta-20060811 was released on 2006-08-11
+---------------------------------------------------------------
+- renamed primitives:
+ \primitive -> \pdfprimitive
+ \ifprimitive -> \ifpdfprimitive
+ \ifabsdim -> \ifpdfabsdim
+ \ifabsnum -> \ifpdfabsnum
+- new version of \primitive/\ifprimitive (but see above)
+- new dimen: \pdfpxdimen
+- support for jbig2 files
+- new library: obsdcompat, which has improved string functions and allows the
+ use of __attribute__
+- update libpng to 1.2.12
+- added JFIF detection patch to writejpg.c (was bug 548)
+- bugfix: truetype OS/2 v3 fonts (594)
+- bugfix: file with only \immediate\pdfobj stream results in garbage (505)
+- bugfix: invalid pdf created if font name contains space (509)
+
+---------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-beta-20060725 was released on 2006-07-25
+---------------------------------------------------------------
+- added patches by Christian Schenk forwarded by Hartmut
+- added patch 421 (popen) from Taco
+- added lots of (void) to writettf* and ttf2afm to silence the compiler
+- removed some unused variables from tounicode.c
+- add new code by Thanh (patch 580)
+- added security patch for xpdf :-(
+- added JFIF detection patch to writejpg.c (bug 548)
+
+---------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-beta-20060213 was released on 2006-02-13
+---------------------------------------------------------------
+- pdftex.web has been improved a bit
+- new patch:
+ - 473 \ifabsnum and \ifabsdim
+- the manual has been updated a bit and is again included
+
+---------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-beta-20060125 was released on 2006-01-25
+---------------------------------------------------------------
+- pdfTeX now includes pdfeTeX, i.e. there is no way to make a binary without
+ eTeX support. Also the sources of TeX, eTeX and pdfTeX have been merged into
+ one file pdftex.web
+- most pdfTeX change files are gone; only one file (pdftex.ch) remains.
+- improved patches:
+ - 393 Ensure newline before endstream
+
+---------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-beta-20060117 was released on 2006-01-17
+---------------------------------------------------------------
+- pdfTeX is now pdfeTeX, i.e. there is no way to make a binary without eTeX
+ support. Also the sources of TeX, eTeX and pdfTeX have been merged into one
+ file pdfetex.web
+- strip trailing zeros in fractions of reals written
+- removed patch 467 \ifindef
+- improved logging of objstreams
+
+----------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-alpha-20060111 was released on 2006-01-11
+----------------------------------------------------------------
+- new patches:
+ - 466 \primitive and \ifprimitive
+ - 467 \ifinedef
+- improved patches:
+ - 393 Ensure newline before endstream
+- pdfTeX now sets /ModDate and /Trapped by default (the values can be
+ overridden with /pdfinfo)
+- more fixes to remove warnings from -Wall
+
+----------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-alpha-20060106 was released on 2006-01-06
+----------------------------------------------------------------
+- many small fixes to remove warnings from -Wall
+- removed some unused variables
+- really fix bug 444
+- add some GCC extensions and use *nprintf instead of *printf where possible
+- fixed a unicode bug in ttf2afm
+
+----------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-alpha-20051226 was released on 2005-12-26
+----------------------------------------------------------------
+- improved patches:
+ - 453 Object Streams for PDF-1.5
+ - take PK resolution from "pk_dpi" parameter in texmf.cnf, if it has not
+ been set by the format file or by the user
+ - 432 Rules in a PDF qQ group
+- some fixes for Thanhs patch
+- some improvements from -Wall
+- .indent.pro for indent
+
+----------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-alpha-20051221 was released on 2005-12-21
+----------------------------------------------------------------
+- has a large patch from Thanh
+- pdflastlink has been fixed
+- remove generated pdf in case of fatal error
+
+----------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-alpha-20051208 was released on 2005-12-08
+----------------------------------------------------------------
+- improved patches:
+ - 386 grow obj_tab and dest_names arrays dynamically
+ - 453 Object Streams for PDF-1.5
+ - take PK resolution from "pk_dpi" parameter in texmf.cnf, if it has not
+ been set by the format file or by the user
+- write out PDF statistics later to make them correct
+- makefile target pdfetex-all.pdf for a huge file
+
+----------------------------------------------------------------
+pdfTeX 3.141592-1.40.0-alpha-20051205 was released on 2005-12-05
+----------------------------------------------------------------
+- has these patches:
+ - 386 grow obj_tab and dest_names arrays dynamically
+ - 416 new primitive pdflastlink
+ - 427 Character positioning patch
+ - 432 Rules in a PDF qQ group
+ - 434 Remove queued map item handling
+ - 438 \pdfsavepos in DVI mode
+ - 443 512 zeros in Type1 fonts not copied anymore
+ - 447 Don't write /Encoding for non-reencoded fonts
+ - 453 Object Streams for PDF-1.5
+ - take PK resolution from "pk_dpi" parameter in texmf.cnf, if it has not
+ been set by the format file or by the user
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.6 was released on 2006-02-16
+-------------------------------------------------
+- bugfix: updated xpdf to 3.01pl2
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.5 was released on 2005-12-04
+-------------------------------------------------
+- bugfix: \pdfximage prints the file name twice (bug 441)
+- bugfix: buffer overflow with \pdfmatch (bug 444)
+- bugfix: updated xpdf to 3.01pl1
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.4 was released on 2005-10-17
+-------------------------------------------------
+- bugfix: whitespaces in filenames didn't work on Unix anymore (bug 377)
+- bugfix: two \immediates cancel themselves (bug 437)
+- bugfix: wrong file name in error messages of image inclusion (bug 435)
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.3 was released on 2005-09-04
+-------------------------------------------------
+- bugfix: \write18
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.2 was released on 2005-08-25
+-------------------------------------------------
+- fixed some build problems and minor bugs introduced in 1.30.1
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.1 was released on 2005-08-21
+-------------------------------------------------
+- the eTeX extensions can now be enabled with the cmdline switch -etex
+- pdfTeX uses xpdf 3.01
+
+-------------------------------------------------
+pdfTeX 3.141592-1.30.0 was released on 2005-08-01
+-------------------------------------------------
+- pdfxtex (introduced with 1.20a) is gone; all extensions are now in pdf(e)tex.
+- Some primitives have been renamed; the old names will still work, but are
+ deprecated and some give a warning that they are obsolete:
+ \pdfoptionpdfminorversion -> \pdfminorversion
+ \pdfoptionalwaysusepdfpagebox -> \pdfforcepagebox
+ \pdfoptionpdfinclusionerrorlevel -> \pdfinclusionerrorlevel
+- pdftex knows two new units:
+ - new Didot (1nd=0.375mm)
+ - new Cicero (1nc=12nd)
+- New primitives:
+ - Inclusion of pngs has been greatly improved: It now does
+ - alpha channel and transparency (only if %!PDF >=1.4)
+ - 16-bit colour (only if %!PDF >=1.5); this must be enabled by setting
+ \pdfimagehicolor to 1.
+ - gamma correction; this must be enabled by setting \pdfimageapplygamma to
+ 1. The device gamma is taken from \pdfgamma. If no embedded value can be
+ found in the png image, then the value of \pdfimagegamma is used instead.
+ - fast direct embedding of png streams, if their structure allows this; the
+ automatic fall-back is to decompress and re-compress as before.
+ - pdfTeX now has an interface to the precise system time (if available) as an
+ aid in benchmarking TeX macro code.
+ - \pdfelapsedtime is a read-only integer that (initially) returns the
+ amount of time passed since the start of this run. This amount is given
+ in `scaled seconds': the value 65536 counts as one second. If more time
+ has passed than 32767 seconds, (2^31)-1 will be returned.
+ - \pdfresettimer updates the internal timer, such that subsequent calls to
+ \pdfelapsedtime will restart from 0.
+ - pdfTeX can now generate random numbers:
+ - \pdfuniformdeviate <count> generates a uniformly distributed random
+ integer value between 0 (inclusive) and <count> (exclusive).
+ - \pdfnormaldeviate expands to a random integer value with a mean of 0 and
+ a unit of 65536.
+ - \pdfrandomseed allows access to the current seed value.
+ - \pdfsetrandomseed <count> sets the random seed to a specific value.
+ - \pdfnoligatures\f disables ligatures for the loaded font \f.
+ - Escaping strings:
+ - \pdfescapestring{<a>} escapes the string <a> so that it can be used as
+ PDF string.
+ - \pdfescapename{<a>} escapes the string <a> so that it can be used as PDF
+ name.
+ - \pdfescapehex{<a>} converts the string <a> to uppercase hexadecimal
+ representation.
+ - \pdfunescapehex{<b>} reverses the effect of \pdfescapehex
+ - \pdfcreationdate expands to the date string that pdfTeX uses in the info
+ dict as default.
+ - \pdffilemoddate{<file>} expands to the modification date of <file> in the
+ same format as \pdfcreationdate (PDF date format).
+ - \pdffilesize{<file>} expands to the size of <file> as string.
+ - \pdfmdfivesum{<abc>} or \pdfmdfivesum file {<file>} calculates the md5
+ sum (of a string or a file) and converts it to uppercase hexadecimal format
+ (same as \pdfescapehex).
+ - \pdffiledump [offset <int>] [length <int>] <general text>
+ Expands to a hex dump of the file given in <general text>, starting at
+ given offset or 0 with given length.
+ - \pdfshellescape is a read-only integer that is 1 if \write18 is enabled, 0
+ otherwise.
+ - \pdfxformname <object number>, which expands to the number in the
+ corresponding form XObject name.
+ - \leftmarginkern <box number> and \rightmarginkern <box number> tell the
+ margin kern at the left and right side of the horizontal list stored in box
+ <box number>.
+ - \pdfpkmode is a token register that sets the MF mode for pixel font
+ generation. The contents of this register is dumped into the format, so one
+ can (optionally) preset it e.g. in part of pdftexconfig.tex.
+ - \pdftracingfonts: An integer variable controlling the tracing of font
+ expansion. It is zero by default; then we get a log (with fontexpansion)
+ like this
+ ...\tenrm t
+ ...\tenrm (+20) e
+ Without font expansion, this default should be compatible with TeX's
+ original log output.
+ If \pdftracingfonts is set to 1 (or greater), we get a more verbose log:
+ ...\xivtt (cmtt10@14.0pt) t
+ ...\xivtt (cmtt10+20@14.0pt) e
+ See also bug 304.
+- New experimental primitives:
+ - \pdfmatch [icase] [subcount <number>}] {<pattern>}{<string>}
+ Implements pattern matching using the POSIX regex.
+ It returns the same values as \pdfstrcmp, but with the following semantics:
+ -1: error case (invalid pattern, ...)
+ 0: no match
+ 1: match found
+ Options:
+ * icase: case insensitive matching
+ * subcount: it sets the table size for found subpatterns.
+ A number "-1" resets the table size to the start default.
+ - \pdflastmatch <number>
+ The result of \pdfmatch is stored in an array. The entry "0" contains the
+ match, the following entries submatches. The positions of the matches are
+ also available. They are encoded:
+ <position> "->" <match string>
+ The position "-1" with an empty string indicates that this entry is not
+ set.
+ - \pdfstrcmp{<a>}{<b>} compares two strings and returns the strings "0" if
+ <a> equals <b>, "-1" if <a> is less than <b>, "1" if <a> is greater than
+ <b>
+- The primitive \pdfmovechars has been removed (bug 294)
+- Bugfixes:
+ - empty strings are not supressed anymore (bug 335)
+ - \unhboxing and character protusion didn't work well together (bug 292)
+ - --jobname didn't work if there was no filename at all (bug 302)
+ - Some problem with fonts on solaris (bug 315)
+ - Dangling font objects with non-replacable fonts (bug 311).
+ - \pdfxform didn't work with box>255 (bug 310)
+ - cmap: unicode ???? is mapped to multiple glyphs (bug 306).
+- pdfTeX uses zlib 1.2.3
+
+------------------------------------------------
+pdfTeX 3.141592-1.21a was released on 2005-02-04
+------------------------------------------------
+- ttf2afm 1.0:
+ - added support for refering to glyphs via unicode in encoding files (ie 'uniXXX')
+ - added some more info to the AFM output
+ - some minor bug fixes
+ - a short documentation available
+- pdftex now understand forms 'uniXXXX' in encoding files (only makes sense
+ with TrueType fonts)
+- added subset tag for TrueType fonts
+- PDF strings are now printed as following:
+ (This is a string) -> (This is a string)
+ This is a string -> (This is a string)
+ <a1b245c1a2...> -> <a1b245c1a2...>
+- check for double newline char to get rid of empty lines in PDF output
+- Fixed a bug in the scanning of map lines introduced in the fix of bug #242 in
+ 1.20b.
+- Fixed three problems in xpdf; xpdf is now 3.00pl3
+- \ifeof18 is a simple method to test if \write18 is enabled.
+- a few extensions in pdfxtex:
+ - \pdflastximagecolordepth returns the last color depth
+ - \pdfximage supports a keyword "colorspace" following an object number
+ representing a ColorSpace object
+ - \pdfstrcmp compares two strings
+ - \pdfescapestring/\pdflastescapedstring provide a way to escape string
+ - \pdffirstlineheight/\pdflastlinedepth/\pdfeachlineheight/\pdfeachlinedepth
+ allow fixing line dimen
+ - patches from Taco
+ - px dimen unit
+ - tagcode patch
+ - quitvmode patch
+
+------------------------------------------------
+pdfTeX 3.141592-1.20b was released on 2004-12-22
+------------------------------------------------
+- Fixed some minor bugs, mostly with hz
+- The info line "output format initialized to PDF/DVI" isn't shown anymore, as
+ this info wasn't reliable (bug 112).
+- Now the PDF-related statistics (PDF objects...) in the .log file is only
+ shown in PDF output mode. It start with a line "PDF statistics:".
+- \pdfimageresolution is not limited to 2400 [dpi] anymore, can now be between
+ 0 and 65535 [dpi].
+- pdfTeX uses xpdf 3.00pl2
+- pdfTeX uses libpng 1.2.8, which fixes some png-related bugs.
+
+------------------------------------------------
+pdfTeX 3.141592-1.20a was released on 2004-09-06
+------------------------------------------------
+- There is a new program pdfxtex, which contains experimental features which
+ might end up in pdftex in the future.
+- Most distributions now use eTeX as the default engine, so when you call
+ pdftex you will get pdfeTeX. Most distributions now also use pdfTeX as the
+ default engine, so when you call latex you will get pdfeTeX running LaTeX.:-)
+- We are setting up pdfTeX as a project at sarovar
+ (http://sarovar.org/projects/pdftex/). Please report bugs etc. through the
+ site.
+- Support for the file pdftex.cfg is gone completely. All parameters that had
+ previously been set by it can be set through primitives; their values are
+ dumped to the format file.
+- The searchpath for encoding and mapfiles has been changed.
+ See http://tug.org/pipermail/tex-live/2004-January/004734.html and
+ http://tug.org/pipermail/tex-live/2004-January/004791.html
+- eTeX is now version 2.2, incorporating the last changes to TeX (3.141592).
+- New options for \pdfmapfile:
+ General functionality: Map items (map files, new: also single map lines; see
+ \pdfmapline) are put in list of pending map items. During the next shipout,
+ pending map items are sequentially scanned for their map entries, and an
+ internal map entry database is updated, using the modes below. Then the list
+ of pending map items is cleared. Map entries of fonts already in use are left
+ untouched. New: All \pdfmapfile and \pdfmapline commands can also be given
+ after shipout of the first page.
+ - \pdfmapfile {foo.map} clears the list of pending map items and starts a new
+ list with the only pending file foo.map. When the map entry lines of
+ foo.map are scanned, duplicate map entries are ignored and a warning is
+ issued. This is the old behaviour.
+ - \pdfmapfile {+foo.map} puts foo.map in the list of pending map items. When
+ the map entry lines of foo.map are scanned, duplicate map entries are
+ ignored and a warning is issued.
+ - \pdfmapfile {=foo.map} puts foo.map in the list of pending map items. When
+ foo.map is scanned, matching map entries in database are replaced by new
+ entries from foo.map.
+ - \pdfmapfile {-foo.map} puts foo.map in the list of pending map items. When
+ foo.map is scanned, matching map entries are deleted from database.
+ - \pdfmapfile {} clears the list of pending map items. It does not affect map
+ entries already registered into the database. This is the old behaviour.
+- New command \pdfmapline {line}. It's like \pdfmapfile but here you can set
+ single map lines like in the map files directly. The modifiers (+-=) have the
+ same effect as with \pdfmapfile.
+- Simplified the handling of the 14 Type 1 "standard fonts" (Times,
+ Helvetica...): They are now more or less handled like any other Type 1 font.
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2004-July/000648.html
+- hz: So far the font expansion feature required that the user must be able to
+ create expanded tfms (eg cmr10+10.tfm). Now font expansion can be used
+ without creating these tfms.
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2004-May/000504.html
+- hz: Changed \pdffontexpand primitive --> the expand factor is now fixed to
+ 1000 and the argument is ignored. This will lead to spurious texts of "1000"
+ in your output if you compile old documents.
+- New command \pdftexbanner which returns a string with the full banner of the
+ current binary (e.g. "This is pdfTeX, Version 3.141592-1.20a (Web2C 7.5.3)
+ kpathsea version 3.5.3")
+- The PTEX.FullBanner key is now inserted in the document info dict instead of
+ the catalog. Newer versions of Acrobat display it.
+- Now includes support for encTeX.
+- Extended \pdfannot to use reserveobjnum/useobjnum
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2004-March/000424.html
+- Bugfix: pdfTeX would read an .xpdfrc when including pdfs.
+ See http://tug.org/pipermail/pdftex/2004-March/004835.html
+- Bugfix: The strings in /ID would sometimes be empty.
+- Bugfix: Even when mapfiles or encodings or PostScript font files were
+ missing, pdfTeX still produced a (most often corrupt) pdf. Now it aborts with
+ an error in these cases.
+- numerous small bugfixes.
+- pdfTeX now uses the GNU libavl from Ben Pfaff for managing of fontmap
+ entries.
+- pdfTeX uses zlib 1.2.1
+- pdfTeX uses xpdf 3.00
+- pdfTeX uses libpng 1.2.7
+
+------------------------------------------------
+pdfTeX 3.141592-1.11b was released on 2003-10-06
+------------------------------------------------
+- Bugfix: The handling of /Rotate produced displaced images when /Rotate was 90
+ or 270.
+
+------------------------------------------------
+pdfTeX 3.141592-1.11a was released on 2003-08-02
+------------------------------------------------
+- New command \pdftrailer analogue to \pdfcatalog whose argument ends up in the
+ trailer dictionary.
+- The behaviour when an included pdf has a newer version than the one specified
+ with \pdfoptionpdfminorversion can be controlled by the new internal integer
+ \pdfoptionpdfinclusionerrorlevel: If it's 0, pdfTeX gives only a warning; if
+ it's 1, it raises an error.
+ This can also be set in pdftex.cfg with pdf_inclusion_errorlevel
+- The syntax for outlines has been extended to allow attributes:
+ <outline spec> --> <attr spec> <action spec> [count <number>] <general text>
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2003-June/000165.html
+- The syntax of \pdfobj has been extended:
+ \pdfobj <object type spec> (h, v, m)
+ <object type spec> --> reserveobjnum
+ | [useobjnum <number>] [<attr spec>] [stream [<attr spec>]] <object contents>
+ <object contents> --> <file spec>
+ | <general text>
+ When the optional keyword `reserveobjnum' and `useobjnum' is not given, the
+ behaviour is unchanged.
+ See also http://tug.org/mailman/htdig/pdftex/2003-March/003814.html
+- Bugfix: /CreationDate didn't care for the timezone and could be fooled.
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2003-July/000223.html
+- Bugfix: The translation of 8-bit characters in included pdfs that had their
+ eighth bit set sometimes got wrong because of a missing typecast.
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2003-July/000216.html
+- Bugfix: pdfTeX -ini would crash with a minimal file because it didn't read
+ it's config and so didn't know anything about fonts.
+ See http://tug.org/pipermail/pdftex/2003-July/004262.html
+- Bugfix: \pdfstartlink would produce spurious /NewWindow entries. Also the
+ syntax of <action spec> and <goto-action spec> has been cleaned up.
+ See http://www.ntg.nl/pipermail/ntg-pdftex/2003-June/000167.html
+- Bugfix: \pdffontattr was not used for T3 fonts.
+ See http://tug.org/pipermail/pdftex/2003-June/004127.html
+- Bugfix: The cropbox of an included pdf would sometimes not be used.
+ See http://tug.org/pipermail/pdftex/2003-May/004037.html
+- pdfTeX uses xpdf 2.02
+
+------------------------------------------------
+pdfTeX 3.141592-1.10b was released on 2003-02-26
+------------------------------------------------
+- The numbers in transformation matrices are allways written with maximum
+ precision (see http://tug.org/pipermail/pdftex/2003-February/003596.html).
+- Incorporated the new version of TeX: 3.141592
+- Bugfix: Numbers in pdfs would sometimes be just a wee bit of (changed
+ implementation of pdftoepdf.convertNumToPDF).
+- Bugfix: When setting the /Producer, /Creator or /CreationDate keys with
+ /pdfinfo pdfTeX would also insert default values which caused duplicate keys
+ in the info dict (see
+ http://tug.org/pipermail/pdftex/2003-February/003524.html).
+- The reading of mapfiles is much faster (see
+ http://tug.org/pipermail/pdftex/2002-July/002843.html).
+- Bugfix: AR5 had problems with the CTM when displaying in "fit visible" mode
+ (see http://tug.org/pipermail/pdftex/2002-May/002688.html).
+- Bugfix: str_in_str had wrong indices (see
+ http://tug.org/pipermail/pdftex/2002-March/002367.html).
+- Bugfix: decimal_digits defaulted to 0, which caused problems with included
+ images when including pdfs (see
+ http://tug.org/pipermail/pdftex/2003-February/003518.html).
+ It now defaults to 4.
+- Bugfix: the type of included images was decided based only on the extensions;
+ now pdfTeX looks for magic bytes at the start of files (see
+ http://tug.org/pipermail/pdftex/2003-February/003519.html)
+
+-----------------------------------------------
+pdfTeX 3.14159-1.10a was released on 2003-01-16
+-----------------------------------------------
+- pdfTeX is now able to produce pdf1.4 (which is also the default) and has
+ almost complete support for including pdf1.4 files:
+ - Additional attributes like MetaData are copied from included pdfs.
+ - Currently the Page Group attribute (see sections 7.3.6 and 7.5.5 of the pdf
+ 1.4 reference) of included pdfs is NOT copied (as we don't know how to
+ handle this when imposing pdfs).
+ This means including pdfs with transparency features will work as long as
+ the included pdf doesn't use Page Groups; if it does, the result might not
+ be what is expected (One application known to use Page Groups is Adobe
+ Illustrator v9++). The distributed pdfTeX binaries will give a warning
+ about any occurance of a Page Group in an included pdf and ignore the Page
+ Group (thus producing syntactically correct pdfs but probably not the
+ intended output).
+ Acrobat 5++ and newer versions of Jaws display files without Page Groups
+ correctly, so this might not really be a problem.
+ See pdftoepdf.cc for preprocessor flags which allow this behaviour to be
+ changed (copying the Page Group (most likely producing incorrect pdf) or
+ treating Page Groups as errors).
+- The new primitive \pdfoptionpdfminorversion sets the pdf version of the
+ generated file and the latest allowed pdf version of included pdfs:
+ \pdfoptionpdfminorversion=3
+ tells pdfTeX to set the pdf version to 1.3 and allows only included pdfs with
+ versions <= 1.3 .
+ The default for \pdfoptionpdfminorversion is 4 for pdf 1.4
+ This must appear before any data is written to the generated pdf file, so
+ you should put it at the very start of your files.
+ This can also be set in pdftex.cfg with pdf_minorversion
+- It is now possible to specify the pdf page box to use when including pdfs.
+ The syntax has been extended:
+ \pdfximage [<image attr spec>] <general text> (h, v, m)
+ <image attr spec> --> [<rule spec>] [<attr spec>] [<page spec>] [<pdf box spec>]
+ <pdf box spec> --> mediabox|cropbox|bleedbox|trimbox|artbox
+ The default is cropbox (which defaults to mediabox), to be compatible with
+ previous versions of pdfTeX.
+ The page box specified at \pdfximage can be globally overridden with the
+ config parameter always_use_pdfpagebox and the command
+ \pdfoptionalwaysusepdfpagebox <integer>, where 0 is the default (use whatever
+ is specified with \pdfximage), 1 is media, 2 is crop, 3 is bleed, 4 is trim
+ and 5 is artbox. This can only be set once per object, i.e. the value used at
+ \pdfximage is remembered.
+ See the pdf reference for an explanation of the boxes.
+- The support for the inclusion of jpeg images has been extended to allow the
+ inclusion of JPEG/Exif files which are produced by digital photo cameras
+ (thanks to Hartmut Henkel).
+- The support for the inclusion of tif images has been removed as it was of
+ limited use (it worked only for gray-scale and rgb images) and produced wrong
+ results (all other images types where treated as rgb images).
+ Tif images can be converted on *nix on-the-fly to pngs with the help of
+ ImageMagick, epstopdf.sty or pdftex.def v0.4 or newer, and this rule:
+ \DeclareGraphicsRule{.tif}{png}{.png}{`convert #1 `basename #1 .tif`.png}
+- The extensions for pdf encryption have been removed, since they make the
+ pdfTeX code overly complex. Those needing pdf encryption are encouraged to
+ produce a standalone program for encrypting pdfs.
+- pdfTeX now writes a usage statistic about the pdfTeX specific memory to the
+ log.
+- numerous bugfixes, most of them in the inclusion of pdfs.
+- pdfTeX uses xpdf 2.01
+- pdfTeX uses libpng 1.2.5
+
+---------------------------------------------------------------------
+pdfTeX 3.14159-1.00a-pretest-20011127-ojmw was released on 2002-01-29
+---------------------------------------------------------------------
+
+----------------------------------------------------------------
+pdfTeX 3.14159-1.00a-pretest-20010806 was released on 2001-08-06
+----------------------------------------------------------------
+
+----------------------------------------------------------------
+pdfTeX 3.14159-1.00a-pretest-20010804 was released on 2001-08-04
+----------------------------------------------------------------
+
+$Id$
+// vim: tw=79:ts=2:expandtab:autoindent
diff --git a/Build/source/texk/web2c/luatexdir/README b/Build/source/texk/web2c/luatexdir/README
new file mode 100644
index 00000000000..f1e142f1b25
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/README
@@ -0,0 +1,87 @@
+pdfTeX
+======
+
+README for version 3.14159-1.40.0-beta-20060811
+===============================================
+
+This directory contains the version 1.40.0-alpha-20060811 of pdfTeX, an
+extended version of eTeX that can create PDF directly from TeX source files
+and enhance the result of TeX typesetting with the help of PDF. When PDF
+output is not selected, pdfTeX produces normal DVI output, otherwise it
+produces PDF output that looks identical to the DVI output. An important
+aspect of this project is to investigate alternative justification
+algorithms, optionally making use of multiple master fonts.
+
+pdfTeX is based on the original eTeX sources and Web2c, and has been
+successfully compiled on Unix, Win32 and DOS systems. It is still under
+development and features may change; it produces reasonable PDF code.
+
+See the file NEWS for changes to the program.
+
+Documentation about pdfTeX can be found at http://www.pdftex.org
+
+There is also a mailing list on pdfTeX; go to
+http://tug.org/mailman/listinfo/pdftex for more information about it. Its
+searchable archive can be found at http://tug.org/pipermail/pdftex/
+Please read http://www.catb.org/~esr/faqs/smart-questions.html before
+asking any questions on the pdfTeX mailing list.
+
+A mailing list for the developement of pdfTeX can be found at
+http://www.ntg.nl/mailman/listinfo/ntg-pdftex
+
+
+LEGAL ISSUES
+============
+
+pdfTeX is copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+pdfTeX is free software; you can redistribute it and/or modify it under the
+terms of the GNU General Public License as published by the Free Software
+Foundation; either version 2 of the License, or (at your option) any later
+version.
+
+pdfTeX is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+details.
+
+You should have received a copy of the GNU General Public License along
+with pdfTeX; if not, write to the Free Software Foundation, Inc., 59 Temple
+Place, Suite 330, Boston, MA 02111-1307 USA
+
+pdfTeX uses code from TeX; for these parts the original copyright by Don
+Knuth applies. See the source files for details.
+
+pdfeTeX uses code from eTeX; for these parts the original copyright by
+Peter Breitenlohner applies. See the source files for details.
+
+
+WHAT TO DO IF YOU BELIEVE YOU HAVE FOUND A BUG IN pdfTeX
+========================================================
+
+Please read http://www.chiark.greenend.org.uk/~sgtatham/bugs.html and
+follow the guidelines there. Then go to the sarovar site of pdfTeX
+(http://sarovar.org/projects/pdftex/) and submit your bug report there.
+Here you can also report feature requests or patches.
+
+
+CONTRIBUTORS
+============
+
+Peter Breitenlohner, Ricardo Sanchez Carmenes, Otfried Cheong, Thomas
+Esser, Hans Hagen, Hartmut Henkel, Taco Hoekwater, Pawel Jackowski, Tom
+Kacvinsky, Akira Kakuto, Reinhard Kotucha, Derek B. Noonburg, Heiko
+Oberdiek, Jiri Osoba, Fabrice Popineau, Sebastian Rahtz, Tomas Rokicki,
+Martin Schröder, Petr Sojka, Ralf Utermann, Olaf Weber, Jiri Zlatuska.
+
+pdfTeX is built on top of TeX, written by Donald Knuth cum suis (Liang and
+so), and eTeX, written by Peter Breitenlohner cum suis; part of the
+paragraph optimization is inspired by the work of Hermann Zapf.
+
+
+------------------------------------------------------------------------------
+
+Please send bug reports, offers of help, etc. to martin@pdftex.org
+
+$Id$
+// vim: tw=75
diff --git a/Build/source/texk/web2c/luatexdir/avl.c b/Build/source/texk/web2c/luatexdir/avl.c
new file mode 100644
index 00000000000..a25239e8d93
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/avl.c
@@ -0,0 +1,893 @@
+/* Produced by texiweb from libavl.w. */
+
+/* libavl - library for manipulation of binary trees.
+ Copyright (C) 1998-2002, 2004 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or
+ modify it under the terms of the GNU General Public License as
+ published by the Free Software Foundation; either version 2 of the
+ License, or (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ The author may be contacted at <blp@gnu.org> on the Internet, or
+ write to Ben Pfaff, Stanford University, Computer Science Dept., 353
+ Serra Mall, Stanford CA 94305, USA.
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "avl.h"
+
+/* Creates and returns a new table
+ with comparison function |compare| using parameter |param|
+ and memory allocator |allocator|.
+ Returns |NULL| if memory allocation failed. */
+struct avl_table *
+avl_create (avl_comparison_func *compare, void *param,
+ struct libavl_allocator *allocator)
+{
+ struct avl_table *tree;
+
+ assert (compare != NULL);
+
+ if (allocator == NULL)
+ allocator = &avl_allocator_default;
+
+ tree = allocator->libavl_malloc (allocator, sizeof *tree);
+ if (tree == NULL)
+ return NULL;
+
+ tree->avl_root = NULL;
+ tree->avl_compare = compare;
+ tree->avl_param = param;
+ tree->avl_alloc = allocator;
+ tree->avl_count = 0;
+ tree->avl_generation = 0;
+
+ return tree;
+}
+
+/* Search |tree| for an item matching |item|, and return it if found.
+ Otherwise return |NULL|. */
+void *
+avl_find (const struct avl_table *tree, const void *item)
+{
+ const struct avl_node *p;
+
+ assert (tree != NULL && item != NULL);
+ for (p = tree->avl_root; p != NULL; )
+ {
+ int cmp = tree->avl_compare (item, p->avl_data, tree->avl_param);
+
+ if (cmp < 0)
+ p = p->avl_link[0];
+ else if (cmp > 0)
+ p = p->avl_link[1];
+ else /* |cmp == 0| */
+ return p->avl_data;
+ }
+
+ return NULL;
+}
+
+/* Inserts |item| into |tree| and returns a pointer to |item|'s address.
+ If a duplicate item is found in the tree,
+ returns a pointer to the duplicate without inserting |item|.
+ Returns |NULL| in case of memory allocation failure. */
+void **
+avl_probe (struct avl_table *tree, void *item)
+{
+ struct avl_node *y, *z; /* Top node to update balance factor, and parent. */
+ struct avl_node *p, *q; /* Iterator, and parent. */
+ struct avl_node *n; /* Newly inserted node. */
+ struct avl_node *w; /* New root of rebalanced subtree. */
+ int dir; /* Direction to descend. */
+
+ unsigned char da[AVL_MAX_HEIGHT]; /* Cached comparison results. */
+ int k = 0; /* Number of cached results. */
+
+ assert (tree != NULL && item != NULL);
+
+ z = (struct avl_node *) &tree->avl_root;
+ y = tree->avl_root;
+ dir = 0;
+ for (q = z, p = y; p != NULL; q = p, p = p->avl_link[dir])
+ {
+ int cmp = tree->avl_compare (item, p->avl_data, tree->avl_param);
+ if (cmp == 0)
+ return &p->avl_data;
+
+ if (p->avl_balance != 0)
+ z = q, y = p, k = 0;
+ da[k++] = dir = cmp > 0;
+ }
+
+ n = q->avl_link[dir] =
+ tree->avl_alloc->libavl_malloc (tree->avl_alloc, sizeof *n);
+ if (n == NULL)
+ return NULL;
+
+ tree->avl_count++;
+ n->avl_data = item;
+ n->avl_link[0] = n->avl_link[1] = NULL;
+ n->avl_balance = 0;
+ if (y == NULL)
+ return &n->avl_data;
+
+ for (p = y, k = 0; p != n; p = p->avl_link[da[k]], k++)
+ if (da[k] == 0)
+ p->avl_balance--;
+ else
+ p->avl_balance++;
+
+ if (y->avl_balance == -2)
+ {
+ struct avl_node *x = y->avl_link[0];
+ if (x->avl_balance == -1)
+ {
+ w = x;
+ y->avl_link[0] = x->avl_link[1];
+ x->avl_link[1] = y;
+ x->avl_balance = y->avl_balance = 0;
+ }
+ else
+ {
+ assert (x->avl_balance == +1);
+ w = x->avl_link[1];
+ x->avl_link[1] = w->avl_link[0];
+ w->avl_link[0] = x;
+ y->avl_link[0] = w->avl_link[1];
+ w->avl_link[1] = y;
+ if (w->avl_balance == -1)
+ x->avl_balance = 0, y->avl_balance = +1;
+ else if (w->avl_balance == 0)
+ x->avl_balance = y->avl_balance = 0;
+ else /* |w->avl_balance == +1| */
+ x->avl_balance = -1, y->avl_balance = 0;
+ w->avl_balance = 0;
+ }
+ }
+ else if (y->avl_balance == +2)
+ {
+ struct avl_node *x = y->avl_link[1];
+ if (x->avl_balance == +1)
+ {
+ w = x;
+ y->avl_link[1] = x->avl_link[0];
+ x->avl_link[0] = y;
+ x->avl_balance = y->avl_balance = 0;
+ }
+ else
+ {
+ assert (x->avl_balance == -1);
+ w = x->avl_link[0];
+ x->avl_link[0] = w->avl_link[1];
+ w->avl_link[1] = x;
+ y->avl_link[1] = w->avl_link[0];
+ w->avl_link[0] = y;
+ if (w->avl_balance == +1)
+ x->avl_balance = 0, y->avl_balance = -1;
+ else if (w->avl_balance == 0)
+ x->avl_balance = y->avl_balance = 0;
+ else /* |w->avl_balance == -1| */
+ x->avl_balance = +1, y->avl_balance = 0;
+ w->avl_balance = 0;
+ }
+ }
+ else
+ return &n->avl_data;
+ z->avl_link[y != z->avl_link[0]] = w;
+
+ tree->avl_generation++;
+ return &n->avl_data;
+}
+
+/* Inserts |item| into |table|.
+ Returns |NULL| if |item| was successfully inserted
+ or if a memory allocation error occurred.
+ Otherwise, returns the duplicate item. */
+void *
+avl_insert (struct avl_table *table, void *item)
+{
+ void **p = avl_probe (table, item);
+ return p == NULL || *p == item ? NULL : *p;
+}
+
+/* Inserts |item| into |table|, replacing any duplicate item.
+ Returns |NULL| if |item| was inserted without replacing a duplicate,
+ or if a memory allocation error occurred.
+ Otherwise, returns the item that was replaced. */
+void *
+avl_replace (struct avl_table *table, void *item)
+{
+ void **p = avl_probe (table, item);
+ if (p == NULL || *p == item)
+ return NULL;
+ else
+ {
+ void *r = *p;
+ *p = item;
+ return r;
+ }
+}
+
+/* Deletes from |tree| and returns an item matching |item|.
+ Returns a null pointer if no matching item found. */
+void *
+avl_delete (struct avl_table *tree, const void *item)
+{
+ /* Stack of nodes. */
+ struct avl_node *pa[AVL_MAX_HEIGHT]; /* Nodes. */
+ unsigned char da[AVL_MAX_HEIGHT]; /* |avl_link[]| indexes. */
+ int k; /* Stack pointer. */
+
+ struct avl_node *p; /* Traverses tree to find node to delete. */
+ int cmp; /* Result of comparison between |item| and |p|. */
+
+ assert (tree != NULL && item != NULL);
+
+ k = 0;
+ p = (struct avl_node *) &tree->avl_root;
+ for (cmp = -1; cmp != 0;
+ cmp = tree->avl_compare (item, p->avl_data, tree->avl_param))
+ {
+ int dir = cmp > 0;
+
+ pa[k] = p;
+ da[k++] = dir;
+
+ p = p->avl_link[dir];
+ if (p == NULL)
+ return NULL;
+ }
+ item = p->avl_data;
+
+ if (p->avl_link[1] == NULL)
+ pa[k - 1]->avl_link[da[k - 1]] = p->avl_link[0];
+ else
+ {
+ struct avl_node *r = p->avl_link[1];
+ if (r->avl_link[0] == NULL)
+ {
+ r->avl_link[0] = p->avl_link[0];
+ r->avl_balance = p->avl_balance;
+ pa[k - 1]->avl_link[da[k - 1]] = r;
+ da[k] = 1;
+ pa[k++] = r;
+ }
+ else
+ {
+ struct avl_node *s;
+ int j = k++;
+
+ for (;;)
+ {
+ da[k] = 0;
+ pa[k++] = r;
+ s = r->avl_link[0];
+ if (s->avl_link[0] == NULL)
+ break;
+
+ r = s;
+ }
+
+ s->avl_link[0] = p->avl_link[0];
+ r->avl_link[0] = s->avl_link[1];
+ s->avl_link[1] = p->avl_link[1];
+ s->avl_balance = p->avl_balance;
+
+ pa[j - 1]->avl_link[da[j - 1]] = s;
+ da[j] = 1;
+ pa[j] = s;
+ }
+ }
+
+ tree->avl_alloc->libavl_free (tree->avl_alloc, p);
+
+ assert (k > 0);
+ while (--k > 0)
+ {
+ struct avl_node *y = pa[k];
+
+ if (da[k] == 0)
+ {
+ y->avl_balance++;
+ if (y->avl_balance == +1)
+ break;
+ else if (y->avl_balance == +2)
+ {
+ struct avl_node *x = y->avl_link[1];
+ if (x->avl_balance == -1)
+ {
+ struct avl_node *w;
+ assert (x->avl_balance == -1);
+ w = x->avl_link[0];
+ x->avl_link[0] = w->avl_link[1];
+ w->avl_link[1] = x;
+ y->avl_link[1] = w->avl_link[0];
+ w->avl_link[0] = y;
+ if (w->avl_balance == +1)
+ x->avl_balance = 0, y->avl_balance = -1;
+ else if (w->avl_balance == 0)
+ x->avl_balance = y->avl_balance = 0;
+ else /* |w->avl_balance == -1| */
+ x->avl_balance = +1, y->avl_balance = 0;
+ w->avl_balance = 0;
+ pa[k - 1]->avl_link[da[k - 1]] = w;
+ }
+ else
+ {
+ y->avl_link[1] = x->avl_link[0];
+ x->avl_link[0] = y;
+ pa[k - 1]->avl_link[da[k - 1]] = x;
+ if (x->avl_balance == 0)
+ {
+ x->avl_balance = -1;
+ y->avl_balance = +1;
+ break;
+ }
+ else
+ x->avl_balance = y->avl_balance = 0;
+ }
+ }
+ }
+ else
+ {
+ y->avl_balance--;
+ if (y->avl_balance == -1)
+ break;
+ else if (y->avl_balance == -2)
+ {
+ struct avl_node *x = y->avl_link[0];
+ if (x->avl_balance == +1)
+ {
+ struct avl_node *w;
+ assert (x->avl_balance == +1);
+ w = x->avl_link[1];
+ x->avl_link[1] = w->avl_link[0];
+ w->avl_link[0] = x;
+ y->avl_link[0] = w->avl_link[1];
+ w->avl_link[1] = y;
+ if (w->avl_balance == -1)
+ x->avl_balance = 0, y->avl_balance = +1;
+ else if (w->avl_balance == 0)
+ x->avl_balance = y->avl_balance = 0;
+ else /* |w->avl_balance == +1| */
+ x->avl_balance = -1, y->avl_balance = 0;
+ w->avl_balance = 0;
+ pa[k - 1]->avl_link[da[k - 1]] = w;
+ }
+ else
+ {
+ y->avl_link[0] = x->avl_link[1];
+ x->avl_link[1] = y;
+ pa[k - 1]->avl_link[da[k - 1]] = x;
+ if (x->avl_balance == 0)
+ {
+ x->avl_balance = +1;
+ y->avl_balance = -1;
+ break;
+ }
+ else
+ x->avl_balance = y->avl_balance = 0;
+ }
+ }
+ }
+ }
+
+ tree->avl_count--;
+ tree->avl_generation++;
+ return (void *) item;
+}
+
+/* Refreshes the stack of parent pointers in |trav|
+ and updates its generation number. */
+static void
+trav_refresh (struct avl_traverser *trav)
+{
+ assert (trav != NULL);
+
+ trav->avl_generation = trav->avl_table->avl_generation;
+
+ if (trav->avl_node != NULL)
+ {
+ avl_comparison_func *cmp = trav->avl_table->avl_compare;
+ void *param = trav->avl_table->avl_param;
+ struct avl_node *node = trav->avl_node;
+ struct avl_node *i;
+
+ trav->avl_height = 0;
+ for (i = trav->avl_table->avl_root; i != node; )
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ assert (i != NULL);
+
+ trav->avl_stack[trav->avl_height++] = i;
+ i = i->avl_link[cmp (node->avl_data, i->avl_data, param) > 0];
+ }
+ }
+}
+
+/* Initializes |trav| for use with |tree|
+ and selects the null node. */
+void
+avl_t_init (struct avl_traverser *trav, struct avl_table *tree)
+{
+ trav->avl_table = tree;
+ trav->avl_node = NULL;
+ trav->avl_height = 0;
+ trav->avl_generation = tree->avl_generation;
+}
+
+/* Initializes |trav| for |tree|
+ and selects and returns a pointer to its least-valued item.
+ Returns |NULL| if |tree| contains no nodes. */
+void *
+avl_t_first (struct avl_traverser *trav, struct avl_table *tree)
+{
+ struct avl_node *x;
+
+ assert (tree != NULL && trav != NULL);
+
+ trav->avl_table = tree;
+ trav->avl_height = 0;
+ trav->avl_generation = tree->avl_generation;
+
+ x = tree->avl_root;
+ if (x != NULL)
+ while (x->avl_link[0] != NULL)
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = x;
+ x = x->avl_link[0];
+ }
+ trav->avl_node = x;
+
+ return x != NULL ? x->avl_data : NULL;
+}
+
+/* Initializes |trav| for |tree|
+ and selects and returns a pointer to its greatest-valued item.
+ Returns |NULL| if |tree| contains no nodes. */
+void *
+avl_t_last (struct avl_traverser *trav, struct avl_table *tree)
+{
+ struct avl_node *x;
+
+ assert (tree != NULL && trav != NULL);
+
+ trav->avl_table = tree;
+ trav->avl_height = 0;
+ trav->avl_generation = tree->avl_generation;
+
+ x = tree->avl_root;
+ if (x != NULL)
+ while (x->avl_link[1] != NULL)
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = x;
+ x = x->avl_link[1];
+ }
+ trav->avl_node = x;
+
+ return x != NULL ? x->avl_data : NULL;
+}
+
+/* Searches for |item| in |tree|.
+ If found, initializes |trav| to the item found and returns the item
+ as well.
+ If there is no matching item, initializes |trav| to the null item
+ and returns |NULL|. */
+void *
+avl_t_find (struct avl_traverser *trav, struct avl_table *tree, void *item)
+{
+ struct avl_node *p, *q;
+
+ assert (trav != NULL && tree != NULL && item != NULL);
+ trav->avl_table = tree;
+ trav->avl_height = 0;
+ trav->avl_generation = tree->avl_generation;
+ for (p = tree->avl_root; p != NULL; p = q)
+ {
+ int cmp = tree->avl_compare (item, p->avl_data, tree->avl_param);
+
+ if (cmp < 0)
+ q = p->avl_link[0];
+ else if (cmp > 0)
+ q = p->avl_link[1];
+ else /* |cmp == 0| */
+ {
+ trav->avl_node = p;
+ return p->avl_data;
+ }
+
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = p;
+ }
+
+ trav->avl_height = 0;
+ trav->avl_node = NULL;
+ return NULL;
+}
+
+/* Attempts to insert |item| into |tree|.
+ If |item| is inserted successfully, it is returned and |trav| is
+ initialized to its location.
+ If a duplicate is found, it is returned and |trav| is initialized to
+ its location. No replacement of the item occurs.
+ If a memory allocation failure occurs, |NULL| is returned and |trav|
+ is initialized to the null item. */
+void *
+avl_t_insert (struct avl_traverser *trav, struct avl_table *tree, void *item)
+{
+ void **p;
+
+ assert (trav != NULL && tree != NULL && item != NULL);
+
+ p = avl_probe (tree, item);
+ if (p != NULL)
+ {
+ trav->avl_table = tree;
+ trav->avl_node =
+ ((struct avl_node *)
+ ((char *) p - offsetof (struct avl_node, avl_data)));
+ trav->avl_generation = tree->avl_generation - 1;
+ return *p;
+ }
+ else
+ {
+ avl_t_init (trav, tree);
+ return NULL;
+ }
+}
+
+/* Initializes |trav| to have the same current node as |src|. */
+void *
+avl_t_copy (struct avl_traverser *trav, const struct avl_traverser *src)
+{
+ assert (trav != NULL && src != NULL);
+
+ if (trav != src)
+ {
+ trav->avl_table = src->avl_table;
+ trav->avl_node = src->avl_node;
+ trav->avl_generation = src->avl_generation;
+ if (trav->avl_generation == trav->avl_table->avl_generation)
+ {
+ trav->avl_height = src->avl_height;
+ memcpy (trav->avl_stack, (const void *) src->avl_stack,
+ sizeof *trav->avl_stack * trav->avl_height);
+ }
+ }
+
+ return trav->avl_node != NULL ? trav->avl_node->avl_data : NULL;
+}
+
+/* Returns the next data item in inorder
+ within the tree being traversed with |trav|,
+ or if there are no more data items returns |NULL|. */
+void *
+avl_t_next (struct avl_traverser *trav)
+{
+ struct avl_node *x;
+
+ assert (trav != NULL);
+
+ if (trav->avl_generation != trav->avl_table->avl_generation)
+ trav_refresh (trav);
+
+ x = trav->avl_node;
+ if (x == NULL)
+ {
+ return avl_t_first (trav, trav->avl_table);
+ }
+ else if (x->avl_link[1] != NULL)
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = x;
+ x = x->avl_link[1];
+
+ while (x->avl_link[0] != NULL)
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = x;
+ x = x->avl_link[0];
+ }
+ }
+ else
+ {
+ struct avl_node *y;
+
+ do
+ {
+ if (trav->avl_height == 0)
+ {
+ trav->avl_node = NULL;
+ return NULL;
+ }
+
+ y = x;
+ x = trav->avl_stack[--trav->avl_height];
+ }
+ while (y == x->avl_link[1]);
+ }
+ trav->avl_node = x;
+
+ return x->avl_data;
+}
+
+/* Returns the previous data item in inorder
+ within the tree being traversed with |trav|,
+ or if there are no more data items returns |NULL|. */
+void *
+avl_t_prev (struct avl_traverser *trav)
+{
+ struct avl_node *x;
+
+ assert (trav != NULL);
+
+ if (trav->avl_generation != trav->avl_table->avl_generation)
+ trav_refresh (trav);
+
+ x = trav->avl_node;
+ if (x == NULL)
+ {
+ return avl_t_last (trav, trav->avl_table);
+ }
+ else if (x->avl_link[0] != NULL)
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = x;
+ x = x->avl_link[0];
+
+ while (x->avl_link[1] != NULL)
+ {
+ assert (trav->avl_height < AVL_MAX_HEIGHT);
+ trav->avl_stack[trav->avl_height++] = x;
+ x = x->avl_link[1];
+ }
+ }
+ else
+ {
+ struct avl_node *y;
+
+ do
+ {
+ if (trav->avl_height == 0)
+ {
+ trav->avl_node = NULL;
+ return NULL;
+ }
+
+ y = x;
+ x = trav->avl_stack[--trav->avl_height];
+ }
+ while (y == x->avl_link[0]);
+ }
+ trav->avl_node = x;
+
+ return x->avl_data;
+}
+
+/* Returns |trav|'s current item. */
+void *
+avl_t_cur (struct avl_traverser *trav)
+{
+ assert (trav != NULL);
+
+ return trav->avl_node != NULL ? trav->avl_node->avl_data : NULL;
+}
+
+/* Replaces the current item in |trav| by |new| and returns the item replaced.
+ |trav| must not have the null item selected.
+ The new item must not upset the ordering of the tree. */
+void *
+avl_t_replace (struct avl_traverser *trav, void *new)
+{
+ void *old;
+
+ assert (trav != NULL && trav->avl_node != NULL && new != NULL);
+ old = trav->avl_node->avl_data;
+ trav->avl_node->avl_data = new;
+ return old;
+}
+
+/* Destroys |new| with |avl_destroy (new, destroy)|,
+ first setting right links of nodes in |stack| within |new|
+ to null pointers to avoid touching uninitialized data. */
+static void
+copy_error_recovery (struct avl_node **stack, int height,
+ struct avl_table *new, avl_item_func *destroy)
+{
+ assert (stack != NULL && height >= 0 && new != NULL);
+
+ for (; height > 2; height -= 2)
+ stack[height - 1]->avl_link[1] = NULL;
+ avl_destroy (new, destroy);
+}
+
+/* Copies |org| to a newly created tree, which is returned.
+ If |copy != NULL|, each data item in |org| is first passed to |copy|,
+ and the return values are inserted into the tree,
+ with |NULL| return values taken as indications of failure.
+ On failure, destroys the partially created new tree,
+ applying |destroy|, if non-null, to each item in the new tree so far,
+ and returns |NULL|.
+ If |allocator != NULL|, it is used for allocation in the new tree.
+ Otherwise, the same allocator used for |org| is used. */
+struct avl_table *
+avl_copy (const struct avl_table *org, avl_copy_func *copy,
+ avl_item_func *destroy, struct libavl_allocator *allocator)
+{
+ struct avl_node *stack[2 * (AVL_MAX_HEIGHT + 1)];
+ int height = 0;
+
+ struct avl_table *new;
+ const struct avl_node *x;
+ struct avl_node *y;
+
+ assert (org != NULL);
+ new = avl_create (org->avl_compare, org->avl_param,
+ allocator != NULL ? allocator : org->avl_alloc);
+ if (new == NULL)
+ return NULL;
+ new->avl_count = org->avl_count;
+ if (new->avl_count == 0)
+ return new;
+
+ x = (const struct avl_node *) &org->avl_root;
+ y = (struct avl_node *) &new->avl_root;
+ for (;;)
+ {
+ while (x->avl_link[0] != NULL)
+ {
+ assert (height < 2 * (AVL_MAX_HEIGHT + 1));
+
+ y->avl_link[0] =
+ new->avl_alloc->libavl_malloc (new->avl_alloc,
+ sizeof *y->avl_link[0]);
+ if (y->avl_link[0] == NULL)
+ {
+ if (y != (struct avl_node *) &new->avl_root)
+ {
+ y->avl_data = NULL;
+ y->avl_link[1] = NULL;
+ }
+
+ copy_error_recovery (stack, height, new, destroy);
+ return NULL;
+ }
+
+ stack[height++] = (struct avl_node *) x;
+ stack[height++] = y;
+ x = x->avl_link[0];
+ y = y->avl_link[0];
+ }
+ y->avl_link[0] = NULL;
+
+ for (;;)
+ {
+ y->avl_balance = x->avl_balance;
+ if (copy == NULL)
+ y->avl_data = x->avl_data;
+ else
+ {
+ y->avl_data = copy (x->avl_data, org->avl_param);
+ if (y->avl_data == NULL)
+ {
+ y->avl_link[1] = NULL;
+ copy_error_recovery (stack, height, new, destroy);
+ return NULL;
+ }
+ }
+
+ if (x->avl_link[1] != NULL)
+ {
+ y->avl_link[1] =
+ new->avl_alloc->libavl_malloc (new->avl_alloc,
+ sizeof *y->avl_link[1]);
+ if (y->avl_link[1] == NULL)
+ {
+ copy_error_recovery (stack, height, new, destroy);
+ return NULL;
+ }
+
+ x = x->avl_link[1];
+ y = y->avl_link[1];
+ break;
+ }
+ else
+ y->avl_link[1] = NULL;
+
+ if (height <= 2)
+ return new;
+
+ y = stack[--height];
+ x = stack[--height];
+ }
+ }
+}
+
+/* Frees storage allocated for |tree|.
+ If |destroy != NULL|, applies it to each data item in inorder. */
+void
+avl_destroy (struct avl_table *tree, avl_item_func *destroy)
+{
+ struct avl_node *p, *q;
+
+ assert (tree != NULL);
+
+ for (p = tree->avl_root; p != NULL; p = q)
+ if (p->avl_link[0] == NULL)
+ {
+ q = p->avl_link[1];
+ if (destroy != NULL && p->avl_data != NULL)
+ destroy (p->avl_data, tree->avl_param);
+ tree->avl_alloc->libavl_free (tree->avl_alloc, p);
+ }
+ else
+ {
+ q = p->avl_link[0];
+ p->avl_link[0] = q->avl_link[1];
+ q->avl_link[1] = p;
+ }
+
+ tree->avl_alloc->libavl_free (tree->avl_alloc, tree);
+}
+
+/* Allocates |size| bytes of space using |malloc()|.
+ Returns a null pointer if allocation fails. */
+void *
+avl_malloc (struct libavl_allocator *allocator, size_t size)
+{
+ assert (allocator != NULL && size > 0);
+ return malloc (size);
+}
+
+/* Frees |block|. */
+void
+avl_free (struct libavl_allocator *allocator, void *block)
+{
+ assert (allocator != NULL && block != NULL);
+ free (block);
+}
+
+/* Default memory allocator that uses |malloc()| and |free()|. */
+struct libavl_allocator avl_allocator_default =
+ {
+ avl_malloc,
+ avl_free
+ };
+
+#undef NDEBUG
+#include <assert.h>
+
+/* Asserts that |avl_insert()| succeeds at inserting |item| into |table|. */
+void
+(avl_assert_insert) (struct avl_table *table, void *item)
+{
+ void **p = avl_probe (table, item);
+ assert (p != NULL && *p == item);
+}
+
+/* Asserts that |avl_delete()| really removes |item| from |table|,
+ and returns the removed item. */
+void *
+(avl_assert_delete) (struct avl_table *table, void *item)
+{
+ void *p = avl_delete (table, item);
+ assert (p != NULL);
+ return p;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/avl.h b/Build/source/texk/web2c/luatexdir/avl.h
new file mode 100644
index 00000000000..b9f9e3c01a9
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/avl.h
@@ -0,0 +1,115 @@
+/* Produced by texiweb from libavl.w. */
+
+/* libavl - library for manipulation of binary trees.
+ Copyright (C) 1998-2002, 2004 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or
+ modify it under the terms of the GNU General Public License as
+ published by the Free Software Foundation; either version 2 of the
+ License, or (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ The author may be contacted at <blp@gnu.org> on the Internet, or
+ write to Ben Pfaff, Stanford University, Computer Science Dept., 353
+ Serra Mall, Stanford CA 94305, USA.
+*/
+
+#ifndef AVL_H
+#define AVL_H 1
+
+#include <stddef.h>
+
+/* Function types. */
+typedef int avl_comparison_func (const void *avl_a, const void *avl_b,
+ void *avl_param);
+typedef void avl_item_func (void *avl_item, void *avl_param);
+typedef void *avl_copy_func (void *avl_item, void *avl_param);
+
+#ifndef LIBAVL_ALLOCATOR
+#define LIBAVL_ALLOCATOR
+/* Memory allocator. */
+struct libavl_allocator
+ {
+ void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
+ void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
+ };
+#endif
+
+/* Default memory allocator. */
+extern struct libavl_allocator avl_allocator_default;
+void *avl_malloc (struct libavl_allocator *, size_t);
+void avl_free (struct libavl_allocator *, void *);
+
+/* Maximum AVL height. */
+#ifndef AVL_MAX_HEIGHT
+#define AVL_MAX_HEIGHT 32
+#endif
+
+/* Tree data structure. */
+struct avl_table
+ {
+ struct avl_node *avl_root; /* Tree's root. */
+ avl_comparison_func *avl_compare; /* Comparison function. */
+ void *avl_param; /* Extra argument to |avl_compare|. */
+ struct libavl_allocator *avl_alloc; /* Memory allocator. */
+ size_t avl_count; /* Number of items in tree. */
+ unsigned long avl_generation; /* Generation number. */
+ };
+
+/* An AVL tree node. */
+struct avl_node
+ {
+ struct avl_node *avl_link[2]; /* Subtrees. */
+ void *avl_data; /* Pointer to data. */
+ signed char avl_balance; /* Balance factor. */
+ };
+
+/* AVL traverser structure. */
+struct avl_traverser
+ {
+ struct avl_table *avl_table; /* Tree being traversed. */
+ struct avl_node *avl_node; /* Current node in tree. */
+ struct avl_node *avl_stack[AVL_MAX_HEIGHT];
+ /* All the nodes above |avl_node|. */
+ size_t avl_height; /* Number of nodes in |avl_parent|. */
+ unsigned long avl_generation; /* Generation number. */
+ };
+
+/* Table functions. */
+struct avl_table *avl_create (avl_comparison_func *, void *,
+ struct libavl_allocator *);
+struct avl_table *avl_copy (const struct avl_table *, avl_copy_func *,
+ avl_item_func *, struct libavl_allocator *);
+void avl_destroy (struct avl_table *, avl_item_func *);
+void **avl_probe (struct avl_table *, void *);
+void *avl_insert (struct avl_table *, void *);
+void *avl_replace (struct avl_table *, void *);
+void *avl_delete (struct avl_table *, const void *);
+void *avl_find (const struct avl_table *, const void *);
+void avl_assert_insert (struct avl_table *, void *);
+void *avl_assert_delete (struct avl_table *, void *);
+
+#define avl_count(table) ((size_t) (table)->avl_count)
+
+/* Table traverser functions. */
+void avl_t_init (struct avl_traverser *, struct avl_table *);
+void *avl_t_first (struct avl_traverser *, struct avl_table *);
+void *avl_t_last (struct avl_traverser *, struct avl_table *);
+void *avl_t_find (struct avl_traverser *, struct avl_table *, void *);
+void *avl_t_insert (struct avl_traverser *, struct avl_table *, void *);
+void *avl_t_copy (struct avl_traverser *, const struct avl_traverser *);
+void *avl_t_next (struct avl_traverser *);
+void *avl_t_prev (struct avl_traverser *);
+void *avl_t_cur (struct avl_traverser *);
+void *avl_t_replace (struct avl_traverser *, void *);
+
+#endif /* avl.h */
diff --git a/Build/source/texk/web2c/luatexdir/avlstuff.c b/Build/source/texk/web2c/luatexdir/avlstuff.c
new file mode 100644
index 00000000000..74fcf6b8eda
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/avlstuff.c
@@ -0,0 +1,180 @@
+/*
+Copyright (c) 2004-2005 Han The Thanh, <thanh@pdftex.org>
+
+This file is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by Free
+Software Foundation; either version 2 of the License, or (at your option)
+any later version.
+
+This file is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License along
+with this file; if not, write to the Free Software Foundation, Inc.,
+59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+
+*/
+
+#include "ptexlib.h"
+#include <kpathsea/c-vararg.h>
+#include <kpathsea/c-proto.h>
+#include "avl.h"
+
+static struct avl_table *PdfObjTree[pdf_objtype_max + 1] =
+ { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL };
+
+/**********************************************************************/
+/* memory management functions for AVL */
+
+void *avl_xmalloc(struct libavl_allocator *allocator, size_t size)
+{
+ assert(allocator != NULL && size > 0);
+ return xmalloc(size);
+}
+
+void avl_xfree(struct libavl_allocator *allocator, void *block)
+{
+ assert(allocator != NULL && block != NULL);
+ xfree(block);
+}
+
+struct libavl_allocator avl_xallocator = {
+ avl_xmalloc,
+ avl_xfree
+};
+
+/**********************************************************************/
+/* general AVL comparison functions */
+
+int comp_int_entry(const void *pa, const void *pb, void *p)
+{
+ cmp_return(*(const int *) pa, *(const int *) pb);
+ return 0;
+}
+
+int comp_string_entry(const void *pa, const void *pb, void *p)
+{
+ return strcmp((const char *) pa, (const char *) pb);
+}
+
+/**********************************************************************/
+/* One AVL tree for each obj_type 0...pdfobjtypemax */
+
+
+typedef struct oentry_ {
+ integer int0;
+ integer objptr;
+} oentry;
+
+/* AVL sort oentry into avl_table[] */
+
+int compare_info(const void *pa, const void *pb, void *param)
+{
+ integer a, b;
+ int as, ae, bs, be, al, bl;
+
+ a = ((const oentry *) pa)->int0;
+ b = ((const oentry *) pb)->int0;
+ if (a < 0 && b < 0) { /* string comparison */
+ if (a <= 2097152 && b <= 2097152) {
+ a+=2097152;
+ b+=2097152;
+ as = str_start[-a];
+ ae = str_start[-a + 1]; /* start of next string in pool */
+ bs = str_start[-b];
+ be = str_start[-b + 1];
+ al = ae - as;
+ bl = be - bs;
+ if (al < bl) /* compare first by string length */
+ return -1;
+ if (al > bl)
+ return 1;
+ for (; as < ae; as++, bs++) {
+ if (str_pool[as] < str_pool[bs])
+ return -1;
+ if (str_pool[as] > str_pool[bs])
+ return 1;
+ }
+ } else {
+ pdftex_fail("avlstuff.c: compare_items() for single characters: NI");
+ }
+ } else { /* integer comparison */
+ if (a < b)
+ return -1;
+ if (a > b)
+ return 1;
+ }
+ return 0;
+}
+
+void avl_put_obj(integer objptr, integer t)
+{
+ static void **pp;
+ static oentry *oe;
+
+ if (PdfObjTree[t] == NULL) {
+ PdfObjTree[t] = avl_create(compare_info, NULL, &avl_xallocator);
+ if (PdfObjTree[t] == NULL)
+ pdftex_fail("avlstuff.c: avl_create() PdfObjTree failed");
+ }
+ oe = xtalloc(1, oentry);
+ oe->int0 = obj_tab[objptr].int0;
+ oe->objptr = objptr; /* allows to relocate objtab */
+ pp = avl_probe(PdfObjTree[t], oe);
+ if (pp == NULL)
+ pdftex_fail("avlstuff.c: avl_probe() out of memory in insertion");
+}
+
+
+/* replacement for linear search pascal function "find_obj()" */
+
+integer avl_find_obj(integer t, integer i, integer byname)
+{
+ static oentry *p;
+ static oentry tmp;
+
+ if (byname > 0)
+ tmp.int0 = -i;
+ else
+ tmp.int0 = i;
+ if (PdfObjTree[t] == NULL)
+ return 0;
+ p = (oentry *) avl_find(PdfObjTree[t], &tmp);
+ if (p == NULL)
+ return 0;
+ return p->objptr;
+}
+
+/**********************************************************************/
+
+struct avl_table *mf_tree = NULL;
+
+typedef struct {
+ char *tfm_name;
+ internalfontnumber fontnum;
+} mf_entry;
+
+/**********************************************************************/
+/* cleaning up... */
+
+static void destroy_oentry(void *pa, void *pb)
+{
+ oentry *p = (oentry *) pa;
+ xfree(p);
+}
+
+void PdfObjTree_free()
+{
+ int i;
+
+ for (i = 0; i <= pdf_objtype_max; i++) {
+ if (PdfObjTree[i] != NULL)
+ avl_destroy(PdfObjTree[i], destroy_oentry);
+ }
+}
+
+/**********************************************************************/
diff --git a/Build/source/texk/web2c/luatexdir/avlstuff.h b/Build/source/texk/web2c/luatexdir/avlstuff.h
new file mode 100644
index 00000000000..e5a4de894d2
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/avlstuff.h
@@ -0,0 +1,29 @@
+/*
+Copyright (c) 2004 Han The Thanh, <thanh@pdftex.org>
+
+This file is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by Free
+Software Foundation; either version 2 of the License, or (at your option)
+any later version.
+
+This file is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License along
+with this file; if not, write to the Free Software Foundation, Inc.,
+59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+
+formatted by indent -kr
+*/
+
+#include "avl.h"
+
+/* memory management functions for avl */
+
+extern struct libavl_allocator avl_xallocator;
+
+/* end of file avlstuff.h */
diff --git a/Build/source/texk/web2c/luatexdir/change-files.txt b/Build/source/texk/web2c/luatexdir/change-files.txt
new file mode 100644
index 00000000000..c6a3387f41d
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/change-files.txt
@@ -0,0 +1,35 @@
+How change files are applied for pdftex/pdfetex?
+
+============================= pdftex =============================
+
+2) pdftex.ch is generated from
+ ./tie -c pdftex.ch pdftex.web \
+ $(srcdir)/pdftexdir/tex.ch0 \
+ $(srcdir)/tex.ch \
+ $(srcdir)/pdftexdir/tex.ch1 \
+ $(srcdir)/pdftexdir/tex.pch
+
+Input:
+ pdftex.web:
+ pdftex without system-dependent changes
+
+ pdftexdir/tex.ch0:
+ % Change file to assist in creating the web2c-specific change file.
+ % This one comes first, resolves inconsistencies between the
+ % generated pdftex.web and tex.ch
+
+ change the pdftex banner to tex banner, so tex.ch can be applied
+
+ tex.ch:
+ the main web2c-specific (or other system-dependent) change file
+
+ pdftexdir/pdftex.ch:
+
+ % Change file to assist in creating the web2c-specific change file.
+ % This one resolves inconsistencies between tex.ch and tex.pch.
+
+ change the tex banner to pdftex banner (reverse tex.ch0)
+
+Output:
+ pdftex.ch (not pdftexdir/pdftex.ch):
+ additional & system-dependent changes
diff --git a/Build/source/texk/web2c/luatexdir/depend.mk b/Build/source/texk/web2c/luatexdir/depend.mk
new file mode 100644
index 00000000000..8d1bf394648
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/depend.mk
@@ -0,0 +1,2874 @@
+avl.o: ../../../../src/texk/web2c/luatexdir/avl.c \
+ ../../../../src/texk/web2c/luatexdir/avl.h
+avlstuff.o: ../../../../src/texk/web2c/luatexdir/avlstuff.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/mapfile.o: ../../../../src/texk/web2c/luatexdir/font/mapfile.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+
+font/pkin.o: ../../../../src/texk/web2c/luatexdir/font/pkin.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/subfont.o: ../../../../src/texk/web2c/luatexdir/font/subfont.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/tounicode.o: ../../../../src/texk/web2c/luatexdir/font/tounicode.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/vfpacket.o: ../../../../src/texk/web2c/luatexdir/font/vfpacket.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/writeenc.o: ../../../../src/texk/web2c/luatexdir/font/writeenc.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/writefont.o: ../../../../src/texk/web2c/luatexdir/font/writefont.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/writet1.o: ../../../../src/texk/web2c/luatexdir/font/writet1.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+
+font/writet3.o: ../../../../src/texk/web2c/luatexdir/font/writet3.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-glyph.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/magstep.h
+font/writettf.o: ../../../../src/texk/web2c/luatexdir/font/writettf.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/font/writettf.h \
+ ../../../../src/texk/web2c/luatexdir/font/macnames.c
+font/writetype0.o: \
+ ../../../../src/texk/web2c/luatexdir/font/writetype0.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/font/writettf.h \
+ ../../../../src/texk/web2c/luatexdir/font/writecff.h
+font/writetype2.o: \
+ ../../../../src/texk/web2c/luatexdir/font/writetype2.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/font/writettf.h \
+ ../../../../src/texk/web2c/luatexdir/font/writecff.h \
+ ../../../../src/texk/web2c/luatexdir/font/sfnt.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/font/tt_glyf.h
+font/writecff.o: ../../../../src/texk/web2c/luatexdir/font/writecff.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/font/writecff.h
+font/tt_glyf.o: ../../../../src/texk/web2c/luatexdir/font/tt_glyf.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/font/sfnt.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/font/tt_table.h \
+ ../../../../src/texk/web2c/luatexdir/font/tt_glyf.h
+font/tt_table.o: ../../../../src/texk/web2c/luatexdir/font/tt_table.c \
+ ../../../../src/texk/web2c/luatexdir/font/sfnt.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/font/tt_table.h
+font/sfnt.o: ../../../../src/texk/web2c/luatexdir/font/sfnt.c \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/font/sfnt.h
+font/texfont.o: ../../../../src/texk/web2c/luatexdir/font/texfont.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+
+font/tfmofm.o: ../../../../src/texk/web2c/luatexdir/font/tfmofm.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+
+font/vfovf.o: ../../../../src/texk/web2c/luatexdir/font/vfovf.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+
+font/luafont.o: ../../../../src/texk/web2c/luatexdir/font/luafont.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+font/dofont.o: ../../../../src/texk/web2c/luatexdir/font/dofont.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+
+image/epdf.o: ../../../../src/texk/web2c/luatexdir/image/epdf.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+image/pdftoepdf.o: \
+ ../../../../src/texk/web2c/luatexdir/image/pdftoepdf.cc \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/image/epdf.h \
+ ../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../web2c/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../web2c/luatexdir/ptexmac.h \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+
+image/writeimg.o: ../../../../src/texk/web2c/luatexdir/image/writeimg.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+
+image/writejbig2.o: \
+ ../../../../src/texk/web2c/luatexdir/image/writejbig2.c \
+ ../../../../src/texk/web2c/luatexdir/image/writejbig2.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h
+image/writejpg.o: ../../../../src/texk/web2c/luatexdir/image/writejpg.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h
+image/writepng.o: ../../../../src/texk/web2c/luatexdir/image/writepng.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h
+lua/loslibext.o: ../../../../src/texk/web2c/luatexdir/lua/loslibext.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/lcallbacklib.o: \
+ ../../../../src/texk/web2c/luatexdir/lua/lcallbacklib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/lkpselib.o: ../../../../src/texk/web2c/luatexdir/lua/lkpselib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/expand.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-glyph.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/readable.h
+lua/llualib.o: ../../../../src/texk/web2c/luatexdir/lua/llualib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/lnodelib.o: ../../../../src/texk/web2c/luatexdir/lua/lnodelib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/lpdflib.o: ../../../../src/texk/web2c/luatexdir/lua/lpdflib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/lstatslib.o: ../../../../src/texk/web2c/luatexdir/lua/lstatslib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/ltexiolib.o: ../../../../src/texk/web2c/luatexdir/lua/ltexiolib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/ltexlib.o: ../../../../src/texk/web2c/luatexdir/lua/ltexlib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/ltokenlib.o: ../../../../src/texk/web2c/luatexdir/lua/ltokenlib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/lfontlib.o: ../../../../src/texk/web2c/luatexdir/lua/lfontlib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/texluac.o: ../../../../src/texk/web2c/luatexdir/lua/texluac.c \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+
+lua/luainit.o: ../../../../src/texk/web2c/luatexdir/lua/luainit.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h ../luatexdir/luatexextra.h
+lua/luastuff.o: ../../../../src/texk/web2c/luatexdir/lua/luastuff.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/luatex.o: ../../../../src/texk/web2c/luatexdir/lua/luatex.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+
+lua/luatoken.o: ../../../../src/texk/web2c/luatexdir/lua/luatoken.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/tokens.h
+lua/luanode.o: ../../../../src/texk/web2c/luatexdir/lua/luanode.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/llanglib.o: ../../../../src/texk/web2c/luatexdir/lua/llanglib.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lua/limglib.o: ../../../../src/texk/web2c/luatexdir/lua/limglib.c \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/lua/../image/image.h
+lang/hnjalloc.o: ../../../../src/texk/web2c/luatexdir/lang/hnjalloc.c
+lang/hyphen.o: ../../../../src/texk/web2c/luatexdir/lang/hyphen.c \
+ ../../../../src/texk/web2c/luatexdir/lang/hnjalloc.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+lang/texlang.o: ../../../../src/texk/web2c/luatexdir/lang/texlang.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h
+tex/linebreak.o: ../../../../src/texk/web2c/luatexdir/tex/linebreak.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+tex/postlinebreak.o: \
+ ../../../../src/texk/web2c/luatexdir/tex/postlinebreak.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+tex/texnodes.o: ../../../../src/texk/web2c/luatexdir/tex/texnodes.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+tex/textoken.o: ../../../../src/texk/web2c/luatexdir/tex/textoken.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/tokens.h
+tex/texpdf.o: ../../../../src/texk/web2c/luatexdir/tex/texpdf.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h
+managed-sa.o: ../../../../src/texk/web2c/luatexdir/managed-sa.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/managed-sa.h
+mathcodes.o: ../../../../src/texk/web2c/luatexdir/mathcodes.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/managed-sa.h
+textcodes.o: ../../../../src/texk/web2c/luatexdir/textcodes.c \
+ ../../../../src/texk/web2c/luatexdir/luatex-api.h \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/managed-sa.h
+utils.o: ../../../../src/texk/web2c/luatexdir/utils.c \
+ \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-stat.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+ ../../../../src/texk/web2c/luatexdir/svnversion.h \
+ \
+
+writezip.o: ../../../../src/texk/web2c/luatexdir/writezip.c \
+ ../../../../src/texk/web2c/luatexdir/ptexlib.h ../luatexd.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmp.h \
+ ../../../../src/texk/web2c/luatexdir/../cpascal.h \
+ ../../../../src/texk/web2c/luatexdir/../config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/config.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-std.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-unistd.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/systypes.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-memstr.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-errno.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-minmax.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-limits.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-proto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/debug.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/types.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/lib.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/progname.h \
+ ../../web2c/c-auto.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-fopen.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/getopt.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/proginit.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/tex-file.h \
+ ../../../../src/texk/web2c/luatexdir/../help.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-pathch.h \
+ ../../../../src/texk/web2c/luatexdir/../../kpathsea/c-ctype.h \
+ ../../../../src/texk/web2c/luatexdir/../texmfmem.h ../luatexcoerce.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/luatex.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/ptexlib.h \
+ ../../../../src/texk/web2c/luatexdir/ptexmac.h \
+ ../../../../src/texk/web2c/luatexdir/avlstuff.h \
+ ../../../../src/texk/web2c/luatexdir/avl.h \
+ ../../../../src/texk/web2c/luatexdir/image/image.h \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ \
+ ../../../../src/texk/web2c/luatexdir/font/texfont.h \
+ ../../../../src/texk/web2c/luatexdir/../luatexdir/managed-sa.h \
+ ../../../../src/texk/web2c/luatexdir/hyphen.h \
+ ../../../../src/texk/web2c/luatexdir/nodes.h \
+
diff --git a/Build/source/texk/web2c/luatexdir/font/.indent.pro b/Build/source/texk/web2c/luatexdir/font/.indent.pro
new file mode 100644
index 00000000000..e9e690f1ba8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/.indent.pro
@@ -0,0 +1,12 @@
+/* $Id$ */
+--k-and-r-style
+--blank-lines-after-procedures
+--line-length 80
+--procnames-start-lines
+--no-space-after-function-call-names
+--dont-break-procedure-type
+--space-after-cast
+/* this does not work in indent 2.2.6 :-( */
+--no-tabs
+/* this is new in indent 2.2.9 */
+--preprocessor-indentation 2
diff --git a/Build/source/texk/web2c/luatexdir/font/dofont.c b/Build/source/texk/web2c/luatexdir/font/dofont.c
new file mode 100644
index 00000000000..fbe44c29ba9
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/dofont.c
@@ -0,0 +1,183 @@
+/*
+Copyright (c) 1996-2006 Taco Hoekwater <taco@luatex.org>
+
+This file is part of LuaTeX.
+
+LuaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+LuaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with LuaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: dofont.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+
+#include "luatex-api.h"
+
+#define TIMERS 0
+
+#if TIMERS
+#include <sys/time.h>
+#endif
+
+
+/* a bit more interfacing is needed for proper error reporting */
+
+static char *
+font_error_message (pointer u, char *nom, scaled s) {
+ char *str = xmalloc(256);
+ char *c = makecstring(zget_cs_text(u));
+ char *extra = "metric data not found or bad";
+ if (s>=0 ) {
+ snprintf(str,255,"Font \\%s=%s at %gpt not loadable: %s", c, nom, (double)s/65536, extra);
+ } else if (s!=-1000) {
+ snprintf(str,255,"Font \\%s=%s scaled %d not loadable: %s", c, nom, (int)(-s), extra);
+ } else {
+ snprintf(str,255,"Font \\%s=%s not loadable: %s", c, nom, extra);
+ }
+ return str;
+}
+
+static int
+do_define_font (integer f, char *cnom, char *caire, scaled s, integer natural_dir) {
+
+ boolean res; /* was the callback successful? */
+ integer callback_id;
+ char *cnam;
+#if TIMERS
+ struct timeval tva;
+ struct timeval tvb;
+ double tvdiff;
+#endif
+ int r;
+ res = 0;
+
+ callback_id=callback_defined(define_font_callback);
+ if (callback_id>0) {
+ if (caire == NULL || strlen(caire)==0) {
+ cnam = xstrdup(cnom);
+ } else {
+ cnam = xmalloc(strlen(cnom)+strlen(caire)+2);
+ sprintf(cnam,"%s/%s",caire,cnom);
+ }
+#if TIMERS
+ gettimeofday(&tva,NULL);
+#endif
+ callback_id = run_and_save_callback(callback_id,"Sdd->",cnam,s,f);
+#if TIMERS
+ gettimeofday(&tvb,NULL);
+ tvdiff = tvb.tv_sec*1000000.0;
+ tvdiff += (double)tvb.tv_usec;
+ tvdiff -= (tva.tv_sec*1000000.0);
+ tvdiff -= (double)tva.tv_usec;
+ tvdiff /= 1000000;
+ fprintf(stdout,"\ncallback('define_font',%s,%i): %f seconds\n", cnam,f,tvdiff);
+#endif
+ free(cnam);
+ if (callback_id>0) { /* success */
+ luaL_checkstack(Luas[0],1,"out of stack space");
+ lua_rawgeti(Luas[0],LUA_REGISTRYINDEX, callback_id);
+ if (lua_istable(Luas[0],-1)) {
+#if TIMERS
+ gettimeofday(&tva,NULL);
+#endif
+ res = font_from_lua(Luas[0],f);
+ destroy_saved_callback (callback_id);
+#if TIMERS
+ gettimeofday(&tvb,NULL);
+ tvdiff = tvb.tv_sec*1000000.0;
+ tvdiff += (double)tvb.tv_usec;
+ tvdiff -= (tva.tv_sec*1000000.0);
+ tvdiff -= (double)tva.tv_usec;
+ tvdiff /= 1000000;
+ fprintf(stdout,"font_from_lua(%s,%i): %f seconds\n", font_name(f),f,tvdiff);
+#endif
+ lua_pop(Luas[0],1);
+ } else if (lua_isnumber(Luas[0],-1)) {
+ r = lua_tonumber(Luas[0],-1);
+ destroy_saved_callback (callback_id);
+ delete_font(f);
+ lua_pop(Luas[0],1);
+ return r;
+ } else {
+ lua_pop(Luas[0],1);
+ delete_font(f);
+ return 0;
+ }
+ }
+ } else {
+ res = read_tfm_info(f,cnom,caire,s);
+ if (res) {
+ set_hyphen_char(f,get_default_hyphen_char());
+ set_skew_char(f,get_default_skew_char());
+ }
+ }
+ if (res) {
+ do_vf(f);
+ set_font_natural_dir(f,natural_dir);
+ return f;
+ } else {
+ delete_font(f);
+ return 0;
+ }
+
+}
+
+int
+read_font_info(pointer u, strnumber nom, strnumber aire, scaled s,
+ integer natural_dir) {
+ integer f;
+ char *cnom, *caire = NULL;
+ char *msg;
+ cnom = xstrdup(makecstring(nom));
+ if (aire != 0)
+ caire = xstrdup(makecstring(aire));
+
+ f = new_font();
+ if ((f = do_define_font(f, cnom,caire,s,natural_dir))) {
+ if (caire != NULL) free(caire);
+ free(cnom);
+ return f;
+ } else {
+ char *help[] = {"I wasn't able to read the size data for this font,",
+ "so I will ignore the font specification.",
+ "[Wizards can fix TFM files using TFtoPL/PLtoTF.]",
+ "You might try inserting a different font spec;",
+ "e.g., type `I\font<same font id>=<substitute font name>'.",
+ NULL } ;
+ if(!get_suppress_fontnotfound_error()) {
+ msg = font_error_message(u, cnom, s);
+ tex_error(msg,help);
+ free(msg);
+ }
+ if (caire != NULL) free(caire);
+ free(cnom);
+ return 0;
+ }
+}
+
+/* TODO This function is a placeholder. There can easily appears holes in
+ the |font_tables| array, and we could attempt to reuse those
+*/
+
+int
+find_font_id (char *nom, char *aire, scaled s) {
+ integer f;
+ f = new_font();
+ if ((f = do_define_font(f, nom, aire,s,-1))) {
+ return f;
+ } else {
+ return 0;
+ }
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/font/luafont.c b/Build/source/texk/web2c/luatexdir/font/luafont.c
new file mode 100644
index 00000000000..be32e39de9f
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/luafont.c
@@ -0,0 +1,1733 @@
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include "nodes.h"
+
+#define noVERBOSE
+
+#define SAVE_REF 1
+
+char *font_type_strings[] = {"unknown","virtual","real", NULL};
+char *font_format_strings[] = {"unknown","type1","type3","truetype", "opentype", NULL};
+char *font_embedding_strings[] = {"unknown","no","subset", "full", NULL};
+char *ligature_type_strings[] = {"=:", "=:|", "|=:", "|=:|", "", "=:|>", "|=:>", "|=:|>", "", "", "", "|=:|>>", NULL };
+
+void
+font_char_to_lua (lua_State *L, internalfontnumber f, charinfo *co) {
+ int i;
+ liginfo *l;
+ kerninfo *ki;
+
+ lua_createtable(L,0,10);
+
+ lua_pushstring(L,"width");
+ lua_pushnumber(L,get_charinfo_width(co));
+ lua_rawset(L,-3);
+
+ lua_pushstring(L,"height");
+ lua_pushnumber(L,get_charinfo_height(co));
+ lua_rawset(L,-3);
+
+ lua_pushstring(L,"depth");
+ lua_pushnumber(L,get_charinfo_depth(co));
+ lua_rawset(L,-3);
+
+ lua_pushstring(L,"italic");
+ lua_pushnumber(L,get_charinfo_italic(co));
+ lua_rawset(L,-3);
+
+ if (get_charinfo_ef(co)!=0) {
+ lua_pushstring(L,"expansion_factor");
+ lua_pushnumber(L,get_charinfo_ef(co));
+ lua_rawset(L,-3);
+ }
+
+ if (get_charinfo_lp(co)!=0) {
+ lua_pushstring(L,"left_protruding");
+ lua_pushnumber(L,get_charinfo_lp(co));
+ lua_rawset(L,-3);
+ }
+
+ if (get_charinfo_lp(co)!=0) {
+ lua_pushstring(L,"right_protruding");
+ lua_pushnumber(L,get_charinfo_rp(co));
+ lua_rawset(L,-3);
+ }
+
+
+ if (font_encodingbytes(f) == 2 ) {
+ lua_pushstring(L,"index");
+ lua_pushnumber(L,get_charinfo_index(co));
+ lua_rawset(L,-3);
+ }
+
+ if (get_charinfo_name(co)!=NULL) {
+ lua_pushstring(L,"name");
+ lua_pushstring(L,get_charinfo_name(co));
+ lua_rawset(L,-3);
+ }
+
+ if (get_charinfo_tounicode(co)!=NULL) {
+ lua_pushstring(L,"tounicode");
+ lua_pushstring(L,get_charinfo_tounicode(co));
+ lua_rawset(L,-3);
+ }
+
+ if (get_charinfo_tag(co) == list_tag) {
+ lua_pushstring(L,"next");
+ lua_pushnumber(L,get_charinfo_remainder(co));
+ lua_rawset(L,-3);
+ }
+
+ lua_pushstring(L,"used");
+ lua_pushboolean(L,(get_charinfo_used(co) ? true : false));
+ lua_rawset(L,-3);
+
+ if (get_charinfo_tag(co) == ext_tag) {
+ lua_pushstring(L,"extensible");
+ lua_createtable(L,0,4);
+ lua_pushnumber(L,get_charinfo_extensible(co,EXT_TOP));
+ lua_setfield(L,-2,"top");
+ lua_pushnumber(L,get_charinfo_extensible(co,EXT_BOT));
+ lua_setfield(L,-2,"bot");
+ lua_pushnumber(L,get_charinfo_extensible(co,EXT_MID));
+ lua_setfield(L,-2,"mid");
+ lua_pushnumber(L,get_charinfo_extensible(co,EXT_REP));
+ lua_setfield(L,-2,"rep");
+ lua_rawset(L,-3);
+ }
+ ki = get_charinfo_kerns(co);
+ if (ki != NULL) {
+ lua_pushstring(L,"kerns");
+ lua_createtable(L,10,1);
+ for (i=0;!kern_end(ki[i]);i++) {
+ if (kern_char(ki[i]) == right_boundarychar) {
+ lua_pushstring(L,"right_boundary");
+ } else {
+ lua_pushnumber(L,kern_char(ki[i]));
+ }
+ lua_pushnumber(L,kern_kern(ki[i]));
+ lua_rawset(L,-3);
+ }
+ lua_rawset(L,-3);
+ }
+ l = get_charinfo_ligatures(co);
+ if (l!=NULL) {
+ lua_pushstring(L,"ligatures");
+ lua_createtable(L,10,1);
+ for (i=0;!lig_end(l[i]);i++) {
+ if (lig_char(l[i]) == right_boundarychar) {
+ lua_pushstring(L,"right_boundary");
+ } else {
+ lua_pushnumber(L,lig_char(l[i]));
+ }
+ lua_createtable(L,0,2);
+ lua_pushstring(L,"type");
+ lua_pushnumber(L,lig_type(l[i]));
+ lua_rawset(L,-3);
+ lua_pushstring(L,"char");
+ lua_pushnumber(L,lig_replacement(l[i]));
+ lua_rawset(L,-3);
+ lua_rawset(L,-3);
+ }
+ lua_rawset(L,-3);
+ }
+}
+
+static void
+write_lua_parameters (lua_State *L, int f) {
+ int k;
+ lua_newtable(L);
+ for (k=1;k<=font_params(f);k++) {
+ lua_pushnumber(L,font_param(f,k));
+ switch (k) {
+ case slant_code: lua_setfield(L,-2,"slant"); break;
+ case space_code: lua_setfield(L,-2,"space"); break;
+ case space_stretch_code: lua_setfield(L,-2,"space_stretch"); break;
+ case space_shrink_code: lua_setfield(L,-2,"space_shrink"); break;
+ case x_height_code: lua_setfield(L,-2,"x_height"); break;
+ case quad_code: lua_setfield(L,-2,"quad"); break;
+ case extra_space_code: lua_setfield(L,-2,"extra_space"); break;
+ default:
+ lua_rawseti(L,-2,k);
+ }
+ }
+ lua_setfield(L,-2,"parameters");
+}
+
+
+int
+font_to_lua (lua_State *L, int f) {
+ int k;
+ charinfo *co;
+ if (font_cache_id(f)) {
+ /* fetch the table from the registry if it was
+ saved there by font_from_lua() */
+ lua_rawgeti(L,LUA_REGISTRYINDEX,font_cache_id(f));
+ /* fontdimens can be changed from tex code */
+ write_lua_parameters(L,f);
+ return 1;
+ }
+
+ lua_newtable(L);
+ lua_pushstring(L,font_name(f));
+ lua_setfield(L,-2,"name");
+ if(font_area(f)!=NULL) {
+ lua_pushstring(L,font_area(f));
+ lua_setfield(L,-2,"area");
+ }
+ if(font_filename(f)!=NULL) {
+ lua_pushstring(L,font_filename(f));
+ lua_setfield(L,-2,"filename");
+ }
+ if(font_fullname(f)!=NULL) {
+ lua_pushstring(L,font_fullname(f));
+ lua_setfield(L,-2,"fullname");
+ }
+ if(font_encodingname(f)!=NULL) {
+ lua_pushstring(L,font_encodingname(f));
+ lua_setfield(L,-2,"encodingname");
+ }
+
+ lua_pushboolean(L,(font_used(f) ? true : false));
+ lua_setfield(L,-2,"used");
+
+
+ lua_pushstring(L,font_type_strings[font_type(f)]);
+ lua_setfield(L,-2,"type");
+ lua_pushstring(L,font_format_strings[font_format(f)]);
+ lua_setfield(L,-2,"format");
+ lua_pushstring(L,font_embedding_strings[font_embedding(f)]);
+ lua_setfield(L,-2,"embedding");
+
+ lua_pushnumber(L,font_size(f));
+ lua_setfield(L,-2,"size");
+ lua_pushnumber(L,font_dsize(f));
+ lua_setfield(L,-2,"designsize");
+ lua_pushnumber(L,font_checksum(f));
+ lua_setfield(L,-2,"checksum");
+ lua_pushnumber(L,font_slant(f));
+ lua_setfield(L,-2,"slant");
+ lua_pushnumber(L,font_extend(f));
+ lua_setfield(L,-2,"extend");
+ lua_pushnumber(L,font_natural_dir(f));
+ lua_setfield(L,-2,"direction");
+ lua_pushnumber(L,font_encodingbytes(f));
+ lua_setfield(L,-2,"encodingbytes");
+ lua_pushnumber(L,font_tounicode(f));
+ lua_setfield(L,-2,"tounicode");
+
+ /* pdf parameters */
+ /* skip the first four for now, that are very much interal */
+ /*
+ if (pdf_font_size(f) != 0) {
+ lua_pushnumber(L,pdf_font_size(f));
+ lua_setfield(L,-2,"pdf_size");
+ }
+ if (pdf_font_num(f) != 0) {
+ lua_pushnumber(L,pdf_font_num(f));
+ lua_setfield(L,-2,"pdf_num");
+ }
+ if (pdf_font_blink(f) != 0) {
+ lua_pushnumber(L,pdf_font_blink(f));
+ lua_setfield(L,-2,"pdf_blink");
+ }
+ if (pdf_font_elink(f) != 0) {
+ lua_pushnumber(L,pdf_font_elink(f));
+ lua_setfield(L,-2,"pdf_elink");
+ }
+ */
+ /* the next one is read only */
+ if (pdf_font_expand_ratio(f) != 0) {
+ lua_pushnumber(L,pdf_font_expand_ratio(f));
+ lua_setfield(L,-2,"expand_ratio");
+ }
+ if (pdf_font_shrink(f) != 0) {
+ lua_pushnumber(L,pdf_font_shrink(f));
+ lua_setfield(L,-2,"shrink");
+ }
+ if (pdf_font_stretch(f) != 0) {
+ lua_pushnumber(L,pdf_font_stretch(f));
+ lua_setfield(L,-2,"stretch");
+ }
+ if (pdf_font_step(f) != 0) {
+ lua_pushnumber(L,pdf_font_step(f));
+ lua_setfield(L,-2,"step");
+ }
+ if (pdf_font_auto_expand(f) != 0) {
+ lua_pushboolean(L,pdf_font_auto_expand(f));
+ lua_setfield(L,-2,"auto_expand");
+ }
+ if (pdf_font_attr(f) != 0) {
+ lua_pushstring(L,makecstring(pdf_font_attr(f)));
+ lua_setfield(L,-2,"attributes");
+ }
+
+ /* params */
+ write_lua_parameters(L,f);
+
+ /* chars */
+ lua_createtable(L,font_tables[f]->charinfo_size,0); /* all characters */
+
+ if (has_left_boundary(f)) {
+ co = get_charinfo(f,left_boundarychar);
+ font_char_to_lua(L,f,co);
+ lua_setfield(L,-2,"left_boundary");
+ }
+ if (has_right_boundary(f)) {
+ co = get_charinfo(f,right_boundarychar);
+ font_char_to_lua(L,f,co);
+ lua_setfield(L,-2,"right_boundary");
+ }
+
+ for (k=font_bc(f);k<=font_ec(f);k++) {
+ if (char_exists(f,k)) {
+ lua_pushnumber(L,k);
+ co = get_charinfo(f,k);
+ font_char_to_lua(L,f,co);
+ lua_rawset(L,-3);
+ }
+ }
+ lua_setfield(L,-2,"characters");
+ return 1;
+}
+
+static int
+count_hash_items (lua_State *L, int name_index){
+ int n = -1;
+ lua_rawgeti(L,LUA_REGISTRYINDEX,name_index);
+ lua_rawget(L,-2);
+ if (!lua_isnil(L,-1)) {
+ if (lua_istable(L,-1)) {
+ n = 0;
+ /* now find the number */
+ lua_pushnil(L); /* first key */
+ while (lua_next(L, -2) != 0) {
+ n++;
+ lua_pop(L,1);
+ }
+ }
+ }
+ lua_pop(L,1);
+ return n;
+}
+
+#define streq(a,b) (strcmp(a,b)==0)
+
+#define append_packet(k) { cpackets[np++] = k; }
+
+#define do_store_four(l) { \
+ append_packet((l&0xFF000000)>>24); \
+ append_packet((l&0x00FF0000)>>16); \
+ append_packet((l&0x0000FF00)>>8); \
+ append_packet((l&0x000000FF)); }
+
+/*
+*/
+
+#define lua_roundnumber(a,b) (int)floor((double)lua_tonumber(L,-1)+0.5)
+
+static int
+numeric_field (lua_State *L, char *name, int dflt) {
+ int i = dflt;
+ lua_pushstring(L,name);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ i = lua_roundnumber(L,-1);
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+static int
+n_numeric_field (lua_State *L, int name_index, int dflt) {
+ register int i = dflt;
+ lua_rawgeti(L,LUA_REGISTRYINDEX, name_index); /* fetch the stringptr */
+ lua_rawget(L,-2);
+ if (lua_type(L,-1)==LUA_TNUMBER) {
+ i = lua_roundnumber(L,-1);
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+
+static int
+enum_field (lua_State *L, char *name, int dflt, char **values) {
+ int k;
+ char *s;
+ int i = dflt;
+ lua_pushstring(L,name);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ i = lua_tonumber(L,-1);
+ } else if (lua_isstring(L,-1)) {
+ s = (char *)lua_tostring(L,-1);
+ k = 0;
+ while (values[k] != NULL) {
+ if (strcmp(values[k],s) == 0) {
+ i = k;
+ break;
+ }
+ k++;
+ }
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+static int
+boolean_field (lua_State *L, char *name, int dflt) {
+ int i = dflt;
+ lua_pushstring(L,name);
+ lua_rawget(L,-2);
+ if (lua_isboolean(L,-1)) {
+ i = lua_toboolean(L,-1);
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+static int
+n_boolean_field (lua_State *L, int name_index, int dflt) {
+ int i = dflt;
+ lua_rawgeti(L,LUA_REGISTRYINDEX, name_index); /* fetch the stringptr */
+ lua_rawget(L,-2);
+ if (lua_isboolean(L,-1)) {
+ i = lua_toboolean(L,-1);
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+
+static char *
+string_field (lua_State *L, char *name, char *dflt) {
+ char *i;
+ lua_pushstring(L,name);
+ lua_rawget(L,-2);
+ if (lua_isstring(L,-1)) {
+ i = xstrdup(lua_tostring(L,-1));
+ } else if (dflt==NULL) {
+ i = NULL;
+ } else {
+ i = xstrdup(dflt);
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+static char *
+n_string_field (lua_State *L, int name_index, char *dflt) {
+ char *i;
+ lua_rawgeti(L,LUA_REGISTRYINDEX, name_index); /* fetch the stringptr */
+ lua_rawget(L,-2);
+ if (lua_isstring(L,-1)) {
+ i = xstrdup(lua_tostring(L,-1));
+ } else if (dflt==NULL) {
+ i = NULL;
+ } else {
+ i = xstrdup(dflt);
+ }
+ lua_pop(L,1);
+ return i;
+}
+
+#define init_luaS_index(a) do { \
+ lua_pushliteral(L,#a); \
+ luaS_##a##_ptr = (char *)lua_tostring(L,-1); \
+ luaS_##a##_index = luaL_ref (L,LUA_REGISTRYINDEX); \
+ } while (0)
+
+#define make_luaS_index(a) \
+ static int luaS_##a##_index = 0; \
+ static char * luaS_##a##_ptr = NULL
+
+#define luaS_index(a) luaS_##a##_index
+
+#define luaS_ptr_eq(a,b) (a==luaS_##b##_ptr)
+
+make_luaS_index(width);
+make_luaS_index(height);
+make_luaS_index(depth);
+make_luaS_index(italic);
+make_luaS_index(index);
+make_luaS_index(left_protruding);
+make_luaS_index(right_protruding);
+make_luaS_index(expansion_factor);
+make_luaS_index(top);
+make_luaS_index(bot);
+make_luaS_index(rep);
+make_luaS_index(mid);
+make_luaS_index(next);
+make_luaS_index(used);
+make_luaS_index(name);
+make_luaS_index(tounicode);
+make_luaS_index(font);
+make_luaS_index(char);
+make_luaS_index(slot);
+make_luaS_index(comment);
+make_luaS_index(push);
+make_luaS_index(pop);
+make_luaS_index(rule);
+make_luaS_index(right);
+make_luaS_index(node);
+make_luaS_index(down);
+make_luaS_index(special);
+make_luaS_index(slant);
+make_luaS_index(space);
+make_luaS_index(space_stretch);
+make_luaS_index(space_shrink);
+make_luaS_index(x_height);
+make_luaS_index(quad);
+make_luaS_index(extra_space);
+make_luaS_index(left_boundary);
+make_luaS_index(right_boundary);
+make_luaS_index(kerns);
+make_luaS_index(ligatures);
+make_luaS_index(fonts);
+
+void init_font_string_pointers (lua_State *L) {
+ init_luaS_index(width);
+ init_luaS_index(height);
+ init_luaS_index(depth);
+ init_luaS_index(italic);
+ init_luaS_index(index);
+ init_luaS_index(left_protruding);
+ init_luaS_index(right_protruding);
+ init_luaS_index(expansion_factor);
+ init_luaS_index(top);
+ init_luaS_index(bot);
+ init_luaS_index(rep);
+ init_luaS_index(mid);
+ init_luaS_index(next);
+ init_luaS_index(used);
+ init_luaS_index(name);
+ init_luaS_index(tounicode);
+ init_luaS_index(font);
+ init_luaS_index(char);
+ init_luaS_index(slot);
+ init_luaS_index(comment);
+ init_luaS_index(push);
+ init_luaS_index(pop);
+ init_luaS_index(rule);
+ init_luaS_index(right);
+ init_luaS_index(node);
+ init_luaS_index(down);
+ init_luaS_index(special);
+
+ init_luaS_index(slant);
+ init_luaS_index(space);
+ init_luaS_index(space_stretch);
+ init_luaS_index(space_shrink);
+ init_luaS_index(x_height);
+ init_luaS_index(quad);
+ init_luaS_index(extra_space);
+
+ init_luaS_index(left_boundary);
+ init_luaS_index(right_boundary);
+ init_luaS_index(kerns);
+ init_luaS_index(ligatures);
+ init_luaS_index(fonts);
+}
+
+static int
+count_char_packet_bytes (lua_State *L) {
+ register int i;
+ register int l = 0;
+ int ff = 0;
+ for (i=1;i<=lua_objlen(L,-1);i++) {
+ lua_rawgeti(L,-1,i);
+ if (lua_istable(L,-1)) {
+ lua_rawgeti(L,-1,1);
+ if (lua_isstring(L,-1)) {
+ char *s = (char *)lua_tostring(L,-1);
+ if (luaS_ptr_eq(s,font)) { l+= 5; ff =1; }
+ else if (luaS_ptr_eq(s,char)) { if (ff==0) { l+=5; } l += 5; ff = 1; }
+ else if (luaS_ptr_eq(s,slot)) { l += 10; ff = 1;}
+ else if (luaS_ptr_eq(s,comment)) { ; }
+ else if (luaS_ptr_eq(s,push) ||
+ luaS_ptr_eq(s,pop)) { l++; }
+ else if (luaS_ptr_eq(s,rule)) { l+=9; }
+ else if (luaS_ptr_eq(s,right) ||
+ luaS_ptr_eq(s,node) ||
+ luaS_ptr_eq(s,down)) { l+=5; }
+ else if (luaS_ptr_eq(s,special)) {
+ size_t len;
+ lua_rawgeti(L,-2,2);
+ (void)lua_tolstring(L,-1,&len);
+ lua_pop(L,1);
+ if (len>0) { l = l + 5 + len; }
+ }
+ else { fprintf(stdout,"unknown packet command %s!\n",s); }
+ } else {
+ fprintf(stdout,"no packet command!\n");
+ }
+ lua_pop(L,1); /* command name */
+ }
+ lua_pop(L,1); /* item */
+ }
+ return l;
+}
+
+
+
+scaled
+sp_to_dvi (halfword sp, halfword atsize) {
+ double result, mult;
+ mult = (double)(atsize>>16);
+ result = (sp << 4);
+ return floor (result/mult );
+}
+
+
+static void
+read_char_packets (lua_State *L, integer *l_fonts, charinfo *co, int atsize) {
+ int i, n, m;
+ size_t l;
+ int cmd;
+ char *s;
+ real_eight_bits *cpackets;
+ int ff = 0;
+ int np = 0;
+ int max_f = 0;
+ int pc = count_char_packet_bytes (L);
+ if (pc<=0)
+ return;
+ assert(l_fonts != NULL);
+ assert(l_fonts[1] != 0);
+ while (l_fonts[(max_f+1)]!=0)
+ max_f++;
+
+ cpackets = xmalloc(pc+1);
+ for (i=1;i<=lua_objlen(L,-1);i++) {
+ lua_rawgeti(L,-1,i);
+ if (lua_istable(L,-1)) {
+ /* fetch the command code */
+ lua_rawgeti(L,-1,1);
+ if (lua_isstring(L,-1)) {
+ s = (char *)lua_tostring(L,-1);
+ cmd = 0;
+ if (luaS_ptr_eq(s,font)) {
+ cmd = packet_font_code;
+ } else if (luaS_ptr_eq(s,char)) {
+ cmd = packet_char_code;
+ if (ff==0) {
+ append_packet(packet_font_code);
+ ff = l_fonts[1];
+ do_store_four(ff);
+ }
+ } else if (luaS_ptr_eq(s,slot)) {
+ cmd = packet_nop_code;
+ lua_rawgeti(L,-2,2); n = lua_tointeger(L,-1);
+ ff = (n>max_f ? l_fonts[1] : l_fonts[n]);
+ lua_rawgeti(L,-3,3); n = lua_tointeger(L,-1);
+ lua_pop(L,2);
+ append_packet(packet_font_code);
+ do_store_four(ff);
+ append_packet(packet_char_code);
+ do_store_four(n);
+ }
+ else if (luaS_ptr_eq(s,comment)) { cmd = packet_nop_code; }
+ else if (luaS_ptr_eq(s,node)) { cmd = packet_node_code; }
+ else if (luaS_ptr_eq(s,push)) { cmd = packet_push_code; }
+ else if (luaS_ptr_eq(s,pop)) { cmd = packet_pop_code; }
+ else if (luaS_ptr_eq(s,rule)) { cmd = packet_rule_code; }
+ else if (luaS_ptr_eq(s,right)) { cmd = packet_right_code; }
+ else if (luaS_ptr_eq(s,down)) { cmd = packet_down_code; }
+ else if (luaS_ptr_eq(s,special)) { cmd = packet_special_code; }
+
+ switch(cmd) {
+ case packet_push_code:
+ case packet_pop_code:
+ append_packet(cmd);
+ break;
+ case packet_font_code:
+ append_packet(cmd);
+ lua_rawgeti(L,-2,2);
+ n = lua_tointeger(L,-1);
+ ff = (n>max_f ? l_fonts[1] : l_fonts[n]);
+ do_store_four(ff);
+ lua_pop(L,1);
+ break;
+ case packet_node_code:
+ append_packet(cmd);
+ lua_rawgeti(L,-2,2);
+ n = copy_node_list(nodelist_from_lua(L));
+ do_store_four(n);
+ lua_pop(L,1);
+ break;
+ case packet_char_code:
+ append_packet(cmd);
+ lua_rawgeti(L,-2,2);
+ n = lua_tointeger(L,-1);
+ do_store_four(n);
+ lua_pop(L,1);
+ break;
+ case packet_right_code:
+ case packet_down_code:
+ append_packet(cmd);
+ lua_rawgeti(L,-2,2);
+ n = lua_tointeger(L,-1);
+ do_store_four(sp_to_dvi(n,atsize));
+ lua_pop(L,1);
+ break;
+ case packet_rule_code:
+ append_packet(cmd);
+ lua_rawgeti(L,-2,2);
+ n = lua_tointeger(L,-1);
+ do_store_four(sp_to_dvi(n,atsize));
+ lua_rawgeti(L,-3,3);
+ n = lua_tointeger(L,-1);
+ do_store_four(sp_to_dvi(n,atsize));
+ lua_pop(L,2);
+ break;
+ case packet_special_code:
+ append_packet(cmd);
+ lua_rawgeti(L,-2,2);
+ s = (char *)lua_tolstring(L,-1,&l);
+ if (l>0) {
+ do_store_four(l);
+ m = (int)l;
+ while(m>0) {
+ n = *s++;
+ m--;
+ append_packet(n);
+ }
+ }
+ lua_pop(L,1);
+ break;
+ case packet_nop_code:
+ break;
+ default:
+ fprintf(stdout,"Unknown char packet code %s (char %d in font %s)\n",s,(int)c,font_name(f));
+ }
+ }
+ lua_pop(L,1); /* command code */
+ } else {
+ fprintf(stdout,"Found a `commands' item that is not a table (char %d in font %s)\n",(int)c,font_name(f));
+ }
+ lua_pop(L,1); /* command table */
+ }
+ append_packet(packet_end_code);
+ set_charinfo_packets(co,cpackets);
+ return;
+}
+
+
+static void
+read_lua_cidinfo (lua_State *L, int f) {
+ int i;
+ char *s;
+ lua_getfield(L,-1,"cidinfo");
+ if (lua_istable(L,-1)) {
+ i = numeric_field(L,"version",0);
+ set_font_cidversion(f,i);
+ i = numeric_field(L,"supplement",0);
+ set_font_cidsupplement(f,i);
+ s = string_field(L,"registry","Adobe"); /* Adobe-Identity-0 */
+ set_font_cidregistry(f,s);
+ s = string_field(L,"ordering","Identity");
+ set_font_cidordering(f,s);
+ }
+ lua_pop(L,1);
+}
+
+
+static void
+read_lua_parameters (lua_State *L, int f) {
+ int i, n;
+ char *s;
+ lua_getfield(L,-1,"parameters");
+ if (lua_istable(L,-1)) {
+ /* the number of parameters is the max(IntegerKeys(L)),7) */
+ n = 7;
+ lua_pushnil(L); /* first key */
+ while (lua_next(L, -2) != 0) {
+ if (lua_isnumber(L,-2)) {
+ i = lua_tonumber(L,-2);
+ if (i > n) n = i;
+ }
+ lua_pop(L,1); /* pop value */
+ }
+ if (n>7) set_font_params(f,n);
+ /* sometimes it is handy to have all integer keys */
+ for (i=1;i<=7;i++) {
+ lua_rawgeti(L,-1,i);
+ if (lua_isnumber(L,-1)) {
+ n = lua_roundnumber(L,-1);
+ set_font_param(f,i, n);
+ }
+ lua_pop(L,1);
+ }
+ lua_pushnil(L); /* first key */
+ while (lua_next(L, -2) != 0) {
+ if (lua_isnumber(L,-2)) {
+ i = lua_tointeger(L,-2);
+ if (i>=8) {
+ n = (lua_isnumber(L,-1) ? lua_roundnumber(L,-1) : 0);
+ set_font_param(f,i, n);
+ }
+ } else if (lua_isstring(L,-2)) {
+ s = (char *)lua_tostring(L,-2);
+ n = (lua_isnumber(L,-1) ? lua_roundnumber(L,-1) : 0);
+ if (luaS_ptr_eq(s,slant)) { set_font_param(f,slant_code,n); }
+ else if (luaS_ptr_eq(s,space)) { set_font_param(f,space_code,n); }
+ else if (luaS_ptr_eq(s,space_stretch)) { set_font_param(f,space_stretch_code,n); }
+ else if (luaS_ptr_eq(s,space_shrink)) { set_font_param(f,space_shrink_code,n); }
+ else if (luaS_ptr_eq(s,x_height)) { set_font_param(f,x_height_code,n); }
+ else if (luaS_ptr_eq(s,quad)) { set_font_param(f,quad_code,n); }
+ else if (luaS_ptr_eq(s,extra_space)) { set_font_param(f,extra_space_code,n); }
+ }
+ lua_pop(L,1);
+ }
+ }
+ lua_pop(L,1);
+
+}
+
+void
+font_char_from_lua (lua_State *L, internal_font_number f, integer i, integer *l_fonts) {
+ int k,r,t;
+ charinfo *co;
+ kerninfo *ckerns;
+ liginfo *cligs;
+ scaled j;
+ char *s;
+ int nl = 0; /* number of ligature table items */
+ int nk = 0; /* number of kern table items */
+ int ctr = 0;
+ int atsize = font_size(f);
+ if (lua_istable(L,-1)) {
+ co = get_charinfo(f,i);
+ set_charinfo_tag (co,0);
+ j = n_numeric_field(L,luaS_width_index,0); set_charinfo_width (co,j);
+ j = n_numeric_field(L,luaS_height_index,0); set_charinfo_height (co,j);
+ j = n_numeric_field(L,luaS_depth_index,0); set_charinfo_depth (co,j);
+ j = n_numeric_field(L,luaS_italic_index,0); set_charinfo_italic (co,j);
+ j = n_numeric_field(L,luaS_index_index,0); set_charinfo_index(co,j);
+ j = n_numeric_field(L,luaS_expansion_factor_index,0); set_charinfo_ef(co,j);
+ j = n_numeric_field(L,luaS_left_protruding_index,0); set_charinfo_lp(co,j);
+ j = n_numeric_field(L,luaS_right_protruding_index,0); set_charinfo_rp(co,j);
+ k = n_boolean_field(L,luaS_used_index,0); set_charinfo_used(co,k);
+ s = n_string_field (L,luaS_name_index,NULL); set_charinfo_name(co,s);
+ s = n_string_field (L,luaS_tounicode_index,NULL); set_charinfo_tounicode(co,s);
+ k = n_numeric_field(L,luaS_next_index,-1);
+ if (k>=0) {
+ set_charinfo_tag (co,list_tag);
+ set_charinfo_remainder (co,k);
+ }
+ lua_getfield(L,-1,"extensible");
+ if (lua_istable(L,-1)){
+ int top, bot,mid, rep;
+ top = n_numeric_field(L,luaS_top_index,0);
+ bot = n_numeric_field(L,luaS_bot_index,0);
+ mid = n_numeric_field(L,luaS_mid_index,0);
+ rep = n_numeric_field(L,luaS_rep_index,0);
+ if (top != 0 || bot != 0 || mid != 0 || rep != 0) {
+ set_charinfo_tag (co,ext_tag);
+ set_charinfo_extensible (co,top,bot,mid,rep);
+ } else {
+ pdftex_warn("lua-loaded font %s char [%d] has an invalid extensible field!",font_name(f),(int)i);
+ }
+ }
+ lua_pop(L,1);
+
+ nk = count_hash_items(L,luaS_index(kerns));
+ if (nk>0) {
+ ckerns = xcalloc((nk+1),sizeof(kerninfo));
+ lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(kerns));
+ lua_rawget(L,-2);
+ if (lua_istable(L,-1)) { /* there are kerns */
+ ctr = 0;
+ lua_pushnil(L);
+ while (lua_next(L, -2) != 0) {
+ k = non_boundarychar;
+ if (lua_isnumber(L,-2)) {
+ k = lua_tonumber(L,-2); /* adjacent char */
+ if (k<0)
+ k = non_boundarychar;
+ } else if (lua_isstring(L,-2)) {
+ s = (char *)lua_tostring(L,-2);
+ if (luaS_ptr_eq(s,right_boundary)) {
+ k = right_boundarychar;
+ if (!has_right_boundary(f))
+ set_right_boundary(f,get_charinfo(f,right_boundarychar));
+ }
+ }
+ j = lua_roundnumber(L,-1); /* movement */
+ if (k!=non_boundarychar) {
+ set_kern_item(ckerns[ctr],k,j);
+ ctr++;
+ } else {
+ pdftex_warn("lua-loaded font %s char [%d] has an invalid kern field!",font_name(f),(int)i);
+ }
+ lua_pop(L,1);
+ }
+ /* guard against empty tables */
+ if (ctr>0) {
+ set_kern_item(ckerns[ctr],end_kern,0);
+ set_charinfo_kerns(co,ckerns);
+ } else {
+ pdftex_warn("lua-loaded font %s char [%d] has an invalid kerns field!",font_name(f),(int)i);
+ }
+ }
+ lua_pop(L,1);
+ }
+
+ /* packet commands */
+ lua_getfield(L,-1,"commands");
+ if (lua_istable(L,-1)){
+ lua_pushnil(L); /* first key */
+ if (lua_next(L, -2) != 0) {
+ lua_pop(L,2);
+ read_char_packets(L,(integer *)l_fonts,co,atsize);
+ }
+ }
+ lua_pop(L,1);
+
+ /* ligatures */
+ nl = count_hash_items(L,luaS_index(ligatures));
+
+ if (nl>0) {
+ cligs = xcalloc((nl+1),sizeof(liginfo));
+ lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(ligatures));
+ lua_rawget(L,-2);
+ if (lua_istable(L,-1)){/* do ligs */
+ ctr = 0;
+ lua_pushnil(L);
+ while (lua_next(L, -2) != 0) {
+ k = non_boundarychar;
+ if (lua_isnumber(L,-2)) {
+ k = lua_tonumber(L,-2); /* adjacent char */
+ if (k<0) {
+ k = non_boundarychar;
+ }
+ } else if (lua_isstring(L,-2)) {
+ s = (char *)lua_tostring(L,-2);
+ if (luaS_ptr_eq(s,right_boundary)) {
+ k = right_boundarychar;
+ if (!has_right_boundary(f))
+ set_right_boundary(f,get_charinfo(f,right_boundarychar));
+ }
+ }
+ r = -1;
+ if (lua_istable(L,-1)) {
+ r = n_numeric_field(L,luaS_char_index,-1); /* ligature */
+ }
+ if (r != -1 && k != non_boundarychar) {
+ t = enum_field(L,"type",0,ligature_type_strings);
+ set_ligature_item(cligs[ctr],(t*2)+1,k,r);
+ ctr++;
+ } else {
+ pdftex_warn("lua-loaded font %s char [%d] has an invalid ligature field!",font_name(f),(int)i);
+ }
+ lua_pop(L,1); /* iterator value */
+ }
+ /* guard against empty tables */
+ if (ctr>0) {
+ set_ligature_item(cligs[ctr],0,end_ligature,0);
+ set_charinfo_ligatures(co,cligs);
+ } else {
+ pdftex_warn("lua-loaded font %s char [%d] has an invalid ligatures field!",font_name(f),(int)i);
+ }
+ }
+ lua_pop(L,1); /* ligatures table */
+ }
+ }
+}
+
+
+
+/* The caller has to fix the state of the lua stack when there is an error! */
+
+
+int
+font_from_lua (lua_State *L, int f) {
+ int i,n,r,t;
+ int s_top; /* lua stack top */
+ int bc; /* first char index */
+ int ec; /* last char index */
+ char *s;
+ integer *l_fonts = NULL;
+ /* the table is at stack index -1 */
+
+ if (luaS_width_index==0)
+ init_font_string_pointers(L);
+
+ s = string_field(L,"area",""); set_font_area(f,s);
+ s = string_field(L,"filename",NULL); set_font_filename(f,s);
+ s = string_field(L,"encodingname",NULL); set_font_encodingname(f,s);
+
+ s = string_field(L,"name",NULL); set_font_name(f,s);
+ s = string_field(L,"fullname",font_name(f)); set_font_fullname(f,s);
+
+ if (s==NULL) {
+ pdftex_fail("lua-loaded font [%d] has no name!",f);
+ return false;
+ }
+
+ i = numeric_field(L,"designsize",655360); set_font_dsize(f,i);
+ i = numeric_field(L,"size",font_dsize(f)); set_font_size(f,i);
+ i = numeric_field(L,"checksum",0); set_font_checksum(f,i);
+ i = numeric_field(L,"direction",0); set_font_natural_dir(f,i);
+ i = numeric_field(L,"encodingbytes",0); set_font_encodingbytes(f,i);
+ i = numeric_field(L,"tounicode",0); set_font_tounicode(f,i);
+
+ i = numeric_field(L,"extend",0);
+ if (i<-2000) i = -2000; if (i>2000) i = 2000; if (i==1000) i = 0;
+ set_font_extend(f,i);
+ i = numeric_field(L,"slant",0);
+ if (i<-1000) i = -1000; if (i>1000) i = 1000;
+ set_font_slant(f,i);
+
+ i = numeric_field(L,"hyphenchar",get_default_hyphen_char()); set_hyphen_char(f,i);
+ i = numeric_field(L,"skewchar",get_default_skew_char()); set_skew_char(f,i);
+ i = boolean_field(L,"used",0); set_font_used(f,i);
+
+ s = string_field (L,"attributes",NULL);
+ if (s!=NULL && strlen(s)>0) {
+ i = maketexstring(s);
+ set_pdf_font_attr(f,i);
+ }
+
+ i = enum_field(L,"type", unknown_font_type,font_type_strings); set_font_type(f,i);
+ i = enum_field(L,"format", unknown_format, font_format_strings); set_font_format(f,i);
+ i = enum_field(L,"embedding",unknown_embedding,font_embedding_strings); set_font_embedding(f,i);
+ if (font_encodingbytes(f)==0 &&
+ (font_format(f)==opentype_format || font_format(f)==truetype_format)) {
+ set_font_encodingbytes(f,2);
+ }
+
+ /* now fetch the base fonts, if needed */
+ n = count_hash_items(L,luaS_index(fonts));
+ if (n>0) {
+ l_fonts = xmalloc((n+2)*sizeof(integer));
+ memset (l_fonts,0,(n+2)*sizeof(integer));
+ lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(fonts));
+ lua_rawget(L,-2);
+ for (i=1;i<=n;i++) {
+ lua_rawgeti(L,-1,i);
+ if (lua_istable(L,-1)) {
+ lua_getfield(L,-1,"id");
+ if (lua_isnumber(L,-1)) {
+ l_fonts[i] = lua_tonumber(L,-1);
+ lua_pop(L,2); /* pop id and entry */
+ continue;
+ }
+ lua_pop(L,1); /* pop id */
+ };
+ s = NULL;
+ if (lua_istable(L,-1)) {
+ lua_getfield(L,-1,"name");
+ if (lua_isstring(L,-1)) {
+ s = (char *)lua_tostring(L,-1);
+ }
+ lua_pop(L,1); /* pop name */
+ }
+ if (s!= NULL) {
+ lua_getfield(L,-1,"size");
+ t = (lua_isnumber(L,-1) ? lua_roundnumber(L,-1) : -1000);
+ lua_pop(L,1);
+
+ /* TODO: the stack is messed up, otherwise this
+ * explicit resizing would not be needed
+ */
+ s_top = lua_gettop(L);
+ l_fonts[i] = find_font_id(s,"",t);
+ lua_settop(L,s_top);
+ } else {
+ pdftex_fail("Invalid local font in font %s!\n", font_name(f));
+ }
+ lua_pop(L,1); /* pop list entry */
+ }
+ lua_pop(L,1); /* pop list entry */
+ } else {
+ if(font_type(f) == virtual_font_type) {
+ pdftex_fail("Invalid local fonts in font %s!\n", font_name(f));
+ } else {
+ l_fonts = xmalloc(3*sizeof(integer));
+ l_fonts[0] = 0;
+ l_fonts[1] = f;
+ l_fonts[2] = 0;
+ }
+ }
+
+ /* parameters */
+ read_lua_parameters(L,f);
+ read_lua_cidinfo(L,f);
+
+ /* characters */
+ lua_getfield(L,-1,"characters");
+ if (lua_istable(L,-1)) {
+ /* find the array size values */
+ ec = 0; bc = -1;
+ lua_pushnil(L); /* first key */
+ while (lua_next(L, -2) != 0) {
+ if (lua_isnumber(L,-2)) {
+ i = lua_tointeger(L,-2);
+ if (i>=0) {
+ if (lua_istable(L,-1)) {
+ if (i>ec) ec = i;
+ if (bc<0) bc = i;
+ if (bc>=0 && i<bc) bc = i;
+ }
+ }
+ }
+ lua_pop(L, 1);
+ }
+
+ if (bc != -1) {
+ /* fprintf(stdout,"defined a font at %d with %d-%d\n",f,bc,ec); */
+ set_font_bc(f,bc);
+ set_font_ec(f,ec);
+ lua_pushnil(L); /* first key */
+ while (lua_next(L, -2) != 0) {
+ if (lua_isnumber(L,-2)) {
+ i = lua_tonumber(L,-2);
+ if (i>=0) {
+ font_char_from_lua(L,f, i, l_fonts);
+ }
+ } else if (lua_isstring(L,-2)) {
+ s = (char *)lua_tostring(L,-2);
+ if (luaS_ptr_eq(s,left_boundary)) {
+ font_char_from_lua(L,f, left_boundarychar, l_fonts);
+ } else if (luaS_ptr_eq(s,right_boundary)) {
+ font_char_from_lua(L,f, right_boundarychar, l_fonts);
+ }
+ }
+ lua_pop(L, 1);
+ }
+ lua_pop(L, 1);
+
+ /* handle font expansion last: the |copy_font| routine is called eventually,
+ and that needs to know |bc| and |ec|. */
+ if (font_type(f)!=virtual_font_type) {
+ int fstep = numeric_field(L,"step",0);
+ if (fstep<0) fstep = 0;
+ if (fstep>100) fstep = 100;
+ if (fstep!=0) {
+ int fshrink = numeric_field(L,"shrink",0);
+ int fstretch = numeric_field(L,"stretch",0);
+ int fexpand = boolean_field(L,"auto_expand",0);
+ if (fshrink<0) fshrink = 0;
+ if (fshrink>500) fshrink = 500;
+ fshrink -= (fshrink % fstep);
+ if (fshrink<0) fshrink = 0;
+ if (fstretch<0) fstretch = 0;
+ if (fstretch>1000) fstretch = 1000;
+ fstretch -= (fstretch % fstep);
+ if (fstretch<0) fstretch = 0;
+ set_expand_params(f, fexpand, fstretch, fshrink, fstep, 0);
+ }
+ }
+
+ } else { /* jikes, no characters */
+ pdftex_warn("lua-loaded font [%d] (%s) has no characters!",f, font_name(f));
+ }
+
+#if SAVE_REF
+ r = luaL_ref(Luas[0],LUA_REGISTRYINDEX); /* pops the table */
+ set_font_cache_id(f,r);
+#else
+ lua_pop(Luas[0],1);
+#endif
+ } else { /* jikes, no characters */
+ pdftex_warn("lua-loaded font [%d] (%s) has no character table!",f, font_name(f));
+ }
+
+ if (l_fonts!=NULL)
+ free(l_fonts);
+ return true;
+}
+
+/* ====================================================================
+ *
+ * L I G A T U R I N G
+ *
+ * ==================================================================== */
+
+
+#define assert_disc(a) \
+ assert(pre_break(a)!=null); /* expect head_node */ \
+ assert(type(pre_break(a))==nesting_node); \
+ assert((vlink_pre_break(a)==null && tlink_pre_break(a)==null) || tail_of_list(vlink_pre_break(a))==tlink_pre_break(a)); \
+ assert(post_break(a)!=null); /* expect head_node */ \
+ assert(type(post_break(a))==nesting_node); \
+ assert((vlink_post_break(a)==null && tlink_post_break(a)==null) || tail_of_list(vlink_post_break(a))==tlink_post_break(a)); \
+ assert(no_break(a)!=null); /* expect head_node */ \
+ assert(type(no_break(a))==nesting_node); \
+ assert((vlink_no_break(a)==null && tlink_no_break(a)==null) || tail_of_list(vlink_no_break(a))==tlink_no_break(a));
+
+static void
+nesting_append (halfword nest, halfword newn) {
+ halfword tail = tlink(nest);
+ assert(alink(nest)==null);
+ assert(vlink(newn)==null);
+ assert(alink(newn)==null);
+ if (tail==null) {
+ assert(vlink(nest)==null);
+ couple_nodes(nest,newn);
+ } else {
+ assert(vlink(tail)==null);
+ assert(tail_of_list(vlink(nest))==tail);
+ couple_nodes(tail,newn);
+ }
+ tlink(nest) = newn;
+}
+
+
+static void
+nesting_prepend (halfword nest, halfword newn) {
+ halfword head = vlink(nest);
+ assert(alink(nest)==null);
+ assert(vlink(newn)==null);
+ assert(alink(newn)==null);
+ couple_nodes(nest,newn);
+ if (head==null) {
+ assert(tlink(nest)==null);
+ tlink(nest) = newn;
+ } else {
+ assert(alink(head)==nest);
+ assert(tail_of_list(head)==tlink(nest));
+ couple_nodes(newn,head);
+ }
+}
+
+
+static int
+test_ligature( liginfo *lig, halfword left, halfword right ) {
+ if (type(left)!=glyph_node)
+ return 0;
+ assert(type(right)==glyph_node);
+ if (font(left)!=font(right)) return 0;
+ if (is_ghost(left) || is_ghost(right)) return 0;
+ *lig = get_ligature(font(left),character(left),character(right));
+ if (is_valid_ligature(*lig)) {
+ return 1;
+ }
+ return 0;
+}
+
+
+static int
+try_ligature(halfword *frst, halfword fwd) {
+ halfword cur = *frst;
+ liginfo lig;
+ if (test_ligature(&lig,cur,fwd)) {
+ int move_after = (lig_type(lig) & 0x0C)>>2;
+ int keep_right = ((lig_type(lig) & 0x01) != 0);
+ int keep_left = ((lig_type(lig) & 0x02) != 0);
+ halfword newgl = raw_glyph_node();
+ font(newgl) = font(cur);
+ character(newgl) = lig_replacement(lig);
+ set_is_ligature(newgl);
+
+ /* below might not be correct in contrived border case.
+ * but we use it only for debugging, so ... */
+ if (character(cur)<0) {
+ set_is_leftboundary(newgl);
+ }
+ if (character(fwd)<0) {
+ set_is_rightboundary(newgl);
+ }
+ if (character(cur)<0) {
+ if (character(fwd)<0) {
+ build_attribute_list(newgl);
+ } else {
+ add_node_attr_ref(node_attr(fwd));
+ node_attr(newgl) = node_attr(fwd);
+ }
+ } else {
+ add_node_attr_ref(node_attr(cur));
+ node_attr(newgl) = node_attr(cur);
+ }
+
+ /* TODO/FIXME if this ligature is consists of another ligature
+ * we should add it's lig_ptr to the new glyphs lig_ptr (and
+ * cleanup the no longer needed node) LOW PRIORITY */
+ /* left side */
+ if (keep_left) {
+ halfword new_first = copy_node(cur);
+ lig_ptr(newgl) = new_first;
+ couple_nodes(cur,newgl);
+ if (move_after) {
+ move_after--;
+ cur = newgl;
+ }
+ } else {
+ halfword prev = alink(cur);
+ uncouple_node(cur);
+ lig_ptr(newgl) = cur;
+ assert(prev!=null);
+ couple_nodes(prev,newgl);
+ cur = newgl; /* as cur has disappeared */
+ }
+ /* right side */
+ if (keep_right) {
+ halfword new_second = copy_node(fwd);
+ /* correct, because we _know_ lig_ptr points to _one_ node */
+ couple_nodes(lig_ptr(newgl),new_second);
+ couple_nodes(newgl,fwd);
+ if (move_after) {
+ move_after--;
+ cur = fwd;
+ }
+ } else {
+ halfword next = vlink(fwd);
+ uncouple_node(fwd);
+ /* correct, because we _know_ lig_ptr points to _one_ node */
+ couple_nodes(lig_ptr(newgl),fwd);
+ if (next!=null) {couple_nodes(newgl,next);}
+ }
+
+ /* check and return */
+ /* assert(move_after==0);*/
+ *frst = cur;
+ return 1;
+ }
+ return 0;
+}
+
+
+/* there shouldn't be any ligatures here - we only add them at the end of
+ * xxx_break in a DISC-1 - DISC-2 situation and we stop processing DISC-1
+ * (we continue with DISC-1's post_ and no_break */
+static halfword
+handle_lig_nest(halfword root, halfword cur) {
+ if (cur==null) return root;
+ while (vlink(cur)!=null) {
+ halfword fwd = vlink(cur);
+ if (type(cur)==glyph_node && type(fwd)==glyph_node &&
+ font(cur)==font(fwd) && try_ligature(&cur,fwd)) continue;
+ cur = vlink(cur);
+ assert(vlink(alink(cur))==cur);
+ }
+ tlink(root) = cur;
+ return root;
+}
+
+
+static halfword
+handle_lig_word(halfword cur) {
+ halfword right=null;
+
+ if (type(cur)==whatsit_node && subtype(cur)==cancel_boundary_node) {
+ halfword prev= alink(cur);
+ halfword fwd = vlink(cur);
+/* uncouple_node(cur); */ /* not needed, it is freed */
+ flush_node(cur);
+ if (fwd==null) {
+ vlink(prev) = fwd;
+ return prev;
+ }
+ couple_nodes(prev,fwd);
+ if (type(fwd)!=glyph_node) return prev;
+ cur = fwd;
+ } else if (has_left_boundary(font(cur))) {
+ halfword prev= alink(cur);
+ halfword p = new_glyph(font(cur),left_boundarychar);
+ couple_nodes(prev,p);
+ couple_nodes(p,cur);
+ cur = p;
+ }
+ if (has_right_boundary(font(cur))) {
+ right = new_glyph(font(cur),right_boundarychar);
+ }
+
+ while (1) {
+ /* A glyph followed by ... */
+ if (type(cur)==glyph_node) {
+ halfword fwd = vlink(cur);
+ if (fwd==null) { /* last character of paragraph */
+ if (right==null) break;
+ couple_nodes(cur,right);
+ right = null;
+ continue;
+ }
+ assert(alink(fwd)==cur);
+ if (type(fwd)==glyph_node) { /* GLYPH - GLYPH */
+ if (font(cur)!=font(fwd)) break;
+ if (try_ligature(&cur,fwd)) continue;
+ } else if (type(fwd)==disc_node) { /* GLYPH - DISC */
+
+ /* if a{bx}{}{y} and a+b=>B convert to {Bx}{}{ay} */
+ halfword pre = vlink_pre_break(fwd);
+ halfword nob = vlink_no_break(fwd);
+ liginfo lig;
+ assert_disc(fwd);
+ /* Check on: a{b?}{?}{?} and a+b=>B : {B?}{?}{a?}*/
+ /* Check on: a{?}{?}{b?} and a+b=>B : {a?}{?}{B?} */
+ if ( (pre!=null && type(pre)==glyph_node && test_ligature(&lig,cur,pre))
+ || (nob!=null && type(nob)==glyph_node && test_ligature(&lig,cur,nob))) {
+ /* move cur from before disc, to skipped part */
+ halfword prev = alink(cur);
+ assert(vlink(prev)==cur);
+ uncouple_node(cur);
+ couple_nodes(prev,fwd);
+ nesting_prepend(no_break(fwd),cur);
+ /* now ligature the pre_break */
+ nesting_prepend(pre_break(fwd),copy_node(cur));
+ /* As we have removed cur, we need to start again ... */
+ cur = prev;
+ }
+ /* Check on: a{?}{?}{}b and a+b=>B : {a?}{?b}{B}*/
+ halfword next = vlink(fwd);
+ if (nob==null && next != null && type(next)==glyph_node
+ && test_ligature(&lig,cur,next)) {
+ /* move cur from before disc to no_break part */
+ halfword prev = alink(cur);
+ assert(alink(next)==fwd);
+ assert(vlink(prev)==cur);
+ uncouple_node(cur);
+ couple_nodes(prev,fwd);
+ couple_nodes(no_break(fwd),cur); /* we _know_ it's empty */
+ /* now copy cur the pre_break */
+ nesting_prepend(pre_break(fwd),copy_node(cur));
+ /* move next from after disc to no_break part */
+ halfword tail = vlink(next);
+ uncouple_node(next);
+ try_couple_nodes(fwd,tail);
+ couple_nodes(cur,next); /* we _know_ this works */
+ tlink(no_break(fwd)) = next; /* and make sure the list is correct */
+ /* now copy next to the post_break */
+ nesting_append(post_break(fwd),copy_node(next));
+ /* As we have removed cur, we need to start again ... */
+ cur = prev;
+ }
+ /* we are finished with the pre_break */
+ handle_lig_nest(pre_break(fwd),vlink_pre_break(fwd));
+ } else if (type(fwd)==whatsit_node && subtype(fwd)==cancel_boundary_node) {
+ halfword next = vlink(fwd);
+ try_couple_nodes(cur,next);
+ flush_node(fwd);
+ if (right!=null) {
+ flush_node(right); /* Shame, didn't need it */
+ /* right = null; */ /* no need, we're going to leave the loop anyway */
+ }
+ break;
+ } else { /* fwd is something unknown */
+ if (right==null) break;
+ couple_nodes(cur,right);
+ couple_nodes(right,fwd);
+ right = null;
+ continue;
+ }
+ /* A discretionary followed by ... */
+ } else if (type(cur)==disc_node) {
+ assert_disc(cur);
+ /* If {?}{x}{?} or {?}{?}{y} then ... */
+ if (vlink_no_break(cur)!=null || vlink_post_break(cur)!=null) {
+ halfword fwd;
+ halfword lists[511]; /* max 8 levels */
+
+ int i, max_depth=0;
+ lists[max_depth++] = handle_lig_nest(post_break(cur),vlink_post_break(cur));
+ lists[max_depth++] = handle_lig_nest(no_break(cur),vlink_no_break(cur));
+ while (1) {
+ if ((fwd = vlink(cur))==null) return cur;
+ if ( type(fwd)==glyph_node) {
+ for (i=0; i<max_depth; i++) {
+ liginfo lig;
+ halfword tail = tlink(lists[i]);
+ if ( tail!=null && test_ligature(&lig,tail,fwd))
+ goto add_glyph_to_all;
+ }
+ /* if we get here, nothing had a ligature, so we stop */
+ break;
+add_glyph_to_all:
+ for (i=0; i<max_depth; i++) {
+ halfword copy = copy_node(fwd);
+ halfword tail = tlink(lists[i]);
+ nesting_append(lists[i],copy);
+ if (tail==null) continue; /* first character - never a ligature */
+ handle_lig_nest(lists[i],tail);
+ }
+ halfword next = vlink(fwd);
+ uncouple_node(fwd);
+ try_couple_nodes(cur,next);
+ flush_node(fwd);
+ } else if ( type(fwd)==disc_node) {
+ /* MAGIC WARNING
+ * A disc followed by a disc can have different kernings
+ * depending on which path is choosen, and it is impossible to
+ * store the possible kernings: fe {}{A}{W} {V}{}{A}
+ * So we _always_ add discs so only a simple path remains. */
+ int m=max_depth; /* as max_depth changes in this loop */
+ for (i=0; i<m; i++) {
+ halfword copy = copy_node(fwd);
+ halfword tail = tlink(lists[i]);
+ if (tail!=null) {
+ halfword prev = alink(tail);
+ assert(alink(tail)!=null);
+ uncouple_node(tail);
+ vlink(prev) = null;
+ if (prev==lists[i]) {
+ tlink(prev) = null;
+ } else {
+ tlink(lists[i]) = prev;
+ }
+ nesting_prepend(pre_break(copy),tail);
+ nesting_prepend(no_break(copy),copy_node(tail));
+ }
+ nesting_append(lists[i],copy);
+ handle_lig_nest(pre_break(copy),vlink_pre_break(copy));
+ assert(max_depth<256);
+ lists[max_depth++] = handle_lig_nest(no_break(copy),vlink_no_break(copy));
+ lists[i] = handle_lig_nest(post_break(copy),vlink_post_break(copy));
+ }
+ halfword next = vlink(fwd);
+ uncouple_node(fwd);
+ try_couple_nodes(cur,next);
+ flush_node(fwd);
+ } else {
+ return cur;
+ }
+ }
+ }
+ } else { /* NO GLYPH NOR DISC */
+ /* fprintf(stdout,"This is a %d node\n",type(cur));*/
+ /* assert(0);*/ /* TODO howcome there can be a glue here? */
+ return cur;
+ }
+ /* step-to-next-node */
+ {
+ halfword prev = cur;
+ cur = vlink(cur);
+ assert(cur!=null);
+ assert(alink(cur)==prev);
+ /* alink(cur) = prev;*/
+ }
+ }
+
+ return cur;
+}
+
+/* return = new tail, head should be a dummy */
+
+halfword
+handle_ligaturing(halfword head, halfword tail) {
+ halfword save_tail ; /* trick to allow explicit node==null tests */
+ halfword cur, prev;
+
+ if (vlink(head)==null)
+ return tail;
+ save_tail = vlink(tail);
+ vlink(tail) = null;
+
+ /* if (fix_node_lists) */
+ fix_node_list(head);
+
+ prev = head;
+ cur = vlink(prev);
+
+ while (cur!=null) {
+ if ( type(cur)==glyph_node ||
+ (type(cur)==whatsit_node && subtype(cur)==cancel_boundary_node)) {
+ cur = handle_lig_word(cur);
+ }
+ prev = cur;
+ cur = vlink(cur);
+ assert(cur==null||alink(cur) == prev);
+ }
+ if (valid_node(save_tail)) {
+ try_couple_nodes(prev,save_tail);
+ }
+ return prev;
+}
+
+
+/* ====================================================================
+ *
+ * K E R N I N G
+ *
+ * ==================================================================== */
+
+static void
+add_kern_before(halfword left, halfword right) {
+ if ((!is_rightghost(right)) &&
+ font(left)==font(right) &&
+ has_kern(font(left),character(left))) {
+ int k = get_kern(font(left),character(left),character(right));
+ if (k!=0) {
+ halfword kern = new_kern(k);
+ halfword prev = alink(right);
+ assert(vlink(prev)==right);
+ couple_nodes(prev,kern);
+ couple_nodes(kern,right);
+ }
+ }
+}
+
+
+static void
+add_kern_after(halfword left, halfword right, halfword aft) {
+ if ((!is_rightghost(right)) &&
+ font(left)==font(right) &&
+ has_kern(font(left),character(left))) {
+ int k = get_kern(font(left),character(left),character(right));
+ if (k!=0) {
+ halfword kern = new_kern(k);
+ halfword next = vlink(aft);
+ assert(next==null||alink(next)==aft);
+ couple_nodes(aft,kern);
+ try_couple_nodes(kern,next);
+ }
+ }
+}
+
+
+static void
+do_handle_kerning (halfword root, halfword init_left, halfword init_right) {
+ halfword cur = vlink(root);
+ halfword left = null;
+ assert(init_left==null || type(init_left)==glyph_node);
+ assert(init_right==null || type(init_right)==glyph_node);
+ if (cur==null) {
+ if (init_left!=null && init_right!=null) {
+ add_kern_after(init_left,init_right,root);
+ tlink(root)=vlink(root);
+ }
+ return;
+ }
+ if (type(cur)==glyph_node) {
+ set_is_glyph(cur);
+ if (init_left!=null)
+ add_kern_before(init_left,cur);
+ left = cur;
+ }
+ while ((cur=vlink(cur))!=null) {
+ if (type(cur)==glyph_node) {
+ set_is_glyph(cur);
+ if (left != null) {
+ add_kern_before(left,cur);
+ if (character(left)<0 || is_ghost(left)) {
+ halfword prev = alink(left);
+ couple_nodes(prev,cur);
+ flush_node(left);
+ }
+ }
+ left = cur;
+ } else {
+ if (type(cur)==disc_node) {
+ halfword right= type(vlink(cur))==glyph_node ? vlink(cur) : null;
+ do_handle_kerning(pre_break(cur),left,null);
+ do_handle_kerning(post_break(cur),null,right);
+ do_handle_kerning(no_break(cur),left,right);
+ }
+ if (left != null) {
+ if (character(left)<0 || is_ghost(left)) {
+ halfword prev = alink(left);
+ couple_nodes(prev,cur);
+ flush_node(left);
+ }
+ left = null;
+ }
+ }
+ }
+ if (left!=null) {
+ if (init_right!=null)
+ add_kern_after(left,init_right,left);
+ if (character(left)<0 || is_ghost(left)) {
+ halfword prev = alink(left);
+ halfword next = vlink(left);
+ if (next!=null) {
+ couple_nodes(prev,next);
+ tlink(root) = next;
+ assert(vlink(next)==null);
+ assert(type(next)==kern_node);
+ } else if (prev!=root) {
+ vlink(prev) = null;
+ tlink(root) = prev;
+ } else {
+ vlink(root) = null;
+ tlink(root) = null;
+ }
+ flush_node(left);
+ }
+ }
+}
+
+
+halfword
+handle_kerning (halfword head, halfword tail) {
+ halfword save_link;
+ save_link = vlink(tail);
+ vlink(tail) = null;
+ tlink(head) = tail;
+ do_handle_kerning(head,null,null);
+ tail = tlink(head);
+ if (valid_node(save_link)) {
+ try_couple_nodes(tail,save_link);
+ }
+ return tail;
+}
+
+/* ====================================================================
+ *
+ * L I G A T U R I N G and K E R N I N G : L U A - I N T E R F A C E
+ *
+ * ==================================================================== */
+
+static halfword
+run_lua_ligkern_callback (halfword head, halfword tail, int callback_id){
+ lua_State *L = Luas[0];
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2);
+ return tail;
+ }
+ nodelist_to_lua(L,head);
+ nodelist_to_lua(L,tail);
+ if (lua_pcall(L,2,1,0) != 0) {
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ lua_error(L);
+ return tail;
+ }
+ tail = nodelist_from_lua(L);
+ if (fix_node_lists)
+ fix_node_list(head);
+ lua_pop(L,2);
+ return tail;
+}
+
+
+halfword
+new_ligkern(halfword head, halfword tail) {
+ int callback_id = 0;
+
+ assert(head!=null);
+ if (vlink(head)==null)
+ return tail;
+
+ callback_id = callback_defined(ligaturing_callback);
+ if (callback_id>0) {
+ tail = run_lua_ligkern_callback(head,tail,callback_id);
+ if (tail==null) tail = tail_of_list(head);
+ } else {
+ tail = handle_ligaturing(head,tail);
+ }
+
+ callback_id = callback_defined(kerning_callback);
+ if (callback_id>0) {
+ tail = run_lua_ligkern_callback(head,tail,callback_id);
+ if (tail==null) tail = tail_of_list(head);
+ } else {
+ halfword nest = new_node(nesting_node,1);
+ halfword cur = vlink(head);
+ halfword aft = vlink(tail);
+ couple_nodes(nest,cur);
+ tlink(nest)=tail;
+ vlink(tail)=null;
+ do_handle_kerning(nest,null,null);
+ couple_nodes(head,vlink(nest));
+ tail = tlink(nest);
+ try_couple_nodes(tail,aft);
+ flush_node(nest);
+ }
+ return tail;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/font/macnames.c b/Build/source/texk/web2c/luatexdir/font/macnames.c
new file mode 100644
index 00000000000..941f087ef56
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/macnames.c
@@ -0,0 +1,312 @@
+/*
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: macnames.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+const char notdef[] = ".notdef";
+
+const char *mac_glyph_names[] = {
+/* 0x00 */
+ notdef,
+ ".null",
+ "CR",
+ "space",
+ "exclam",
+ "quotedbl",
+ "numbersign",
+ "dollar",
+ "percent",
+ "ampersand",
+ "quotesingle",
+ "parenleft",
+ "parenright",
+ "asterisk",
+ "plus",
+ "comma",
+/* 0x10 */
+ "hyphen",
+ "period",
+ "slash",
+ "zero",
+ "one",
+ "two",
+ "three",
+ "four",
+ "five",
+ "six",
+ "seven",
+ "eight",
+ "nine",
+ "colon",
+ "semicolon",
+ "less",
+/* 0x20 */
+ "equal",
+ "greater",
+ "question",
+ "at",
+ "A",
+ "B",
+ "C",
+ "D",
+ "E",
+ "F",
+ "G",
+ "H",
+ "I",
+ "J",
+ "K",
+ "L",
+/* 0x30 */
+ "M",
+ "N",
+ "O",
+ "P",
+ "Q",
+ "R",
+ "S",
+ "T",
+ "U",
+ "V",
+ "W",
+ "X",
+ "Y",
+ "Z",
+ "bracketleft",
+ "backslash",
+/* 0x40 */
+ "bracketright",
+ "asciicircum",
+ "underscore",
+ "grave",
+ "a",
+ "b",
+ "c",
+ "d",
+ "e",
+ "f",
+ "g",
+ "h",
+ "i",
+ "j",
+ "k",
+ "l",
+/* 0x50 */
+ "m",
+ "n",
+ "o",
+ "p",
+ "q",
+ "r",
+ "s",
+ "t",
+ "u",
+ "v",
+ "w",
+ "x",
+ "y",
+ "z",
+ "braceleft",
+ "bar",
+/* 0x60 */
+ "braceright",
+ "asciitilde",
+ "Adieresis",
+ "Aring",
+ "Ccedilla",
+ "Eacute",
+ "Ntilde",
+ "Odieresis",
+ "Udieresis",
+ "aacute",
+ "agrave",
+ "acircumflex",
+ "adieresis",
+ "atilde",
+ "aring",
+ "ccedilla",
+/* 0x70 */
+ "eacute",
+ "egrave",
+ "ecircumflex",
+ "edieresis",
+ "iacute",
+ "igrave",
+ "icircumflex",
+ "idieresis",
+ "ntilde",
+ "oacute",
+ "ograve",
+ "ocircumflex",
+ "odieresis",
+ "otilde",
+ "uacute",
+ "ugrave",
+/* 0x80 */
+ "ucircumflex",
+ "udieresis",
+ "dagger",
+ "degree",
+ "cent",
+ "sterling",
+ "section",
+ "bullet",
+ "paragraph",
+ "germandbls",
+ "registered",
+ "copyright",
+ "trademark",
+ "acute",
+ "dieresis",
+ "notequal",
+/* 0x90 */
+ "AE",
+ "Oslash",
+ "infinity",
+ "plusminus",
+ "lessequal",
+ "greaterequal",
+ "yen",
+ "mu",
+ "partialdiff",
+ "Sigma",
+ "Pi",
+ "pi",
+ "integral",
+ "ordfeminine",
+ "ordmasculine",
+ "Omega",
+/* 0xa0 */
+ "ae",
+ "oslash",
+ "questiondown",
+ "exclamdown",
+ "logicalnot",
+ "radical",
+ "florin",
+ "approxequal",
+ "Delta",
+ "guillemotleft",
+ "guillemotright",
+ "ellipsis",
+ "nbspace",
+ "Agrave",
+ "Atilde",
+ "Otilde",
+/* 0xb0 */
+ "OE",
+ "oe",
+ "endash",
+ "emdash",
+ "quotedblleft",
+ "quotedblright",
+ "quoteleft",
+ "quoteright",
+ "divide",
+ "lozenge",
+ "ydieresis",
+ "Ydieresis",
+ "fraction",
+ "currency",
+ "guilsinglleft",
+ "guilsinglright",
+/* 0xc0 */
+ "fi",
+ "fl",
+ "daggerdbl",
+ "periodcentered",
+ "quotesinglbase",
+ "quotedblbase",
+ "perthousand",
+ "Acircumflex",
+ "Ecircumflex",
+ "Aacute",
+ "Edieresis",
+ "Egrave",
+ "Iacute",
+ "Icircumflex",
+ "Idieresis",
+ "Igrave",
+/* 0xd0 */
+ "Oacute",
+ "Ocircumflex",
+ "applelogo",
+ "Ograve",
+ "Uacute",
+ "Ucircumflex",
+ "Ugrave",
+ "dotlessi",
+ "circumflex",
+ "tilde",
+ "macron",
+ "breve",
+ "dotaccent",
+ "ring",
+ "cedilla",
+ "hungarumlaut",
+/* 0xe0 */
+ "ogonek",
+ "caron",
+ "Lslash",
+ "lslash",
+ "Scaron",
+ "scaron",
+ "Zcaron",
+ "zcaron",
+ "brokenbar",
+ "Eth",
+ "eth",
+ "Yacute",
+ "yacute",
+ "Thorn",
+ "thorn",
+ "minus",
+/* 0xf0 */
+ "multiply",
+ "onesuperior",
+ "twosuperior",
+ "threesuperior",
+ "onehalf",
+ "onequarter",
+ "threequarters",
+ "franc",
+ "Gbreve",
+ "gbreve",
+ "Idot",
+ "Scedilla",
+ "scedilla",
+ "Cacute",
+ "cacute",
+ "Ccaron",
+/* 0x100 */
+ "ccaron",
+ "dmacron"
+};
+
+const char *ambiguous_names[] = {
+ "Delta", /* increment */
+ "Omega", /* Ohm */
+ "Pi", /* product */
+ "Sigma", /* summation */
+ "dmacron", /* dslash */
+ "macron", /* overscore */
+ "periodcentered", /* middot */
+ NULL
+};
diff --git a/Build/source/texk/web2c/luatexdir/font/mapfile.c b/Build/source/texk/web2c/luatexdir/font/mapfile.c
new file mode 100644
index 00000000000..1c444e5c1d4
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/mapfile.c
@@ -0,0 +1,967 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: mapfile.c 1013 2008-02-14 00:09:02Z oneiros $
+
+*/
+
+#include <math.h>
+#include "ptexlib.h"
+#include <kpathsea/c-auto.h>
+#include <kpathsea/c-memstr.h>
+#include <string.h>
+#include "luatex-api.h"
+
+#define FM_BUF_SIZE 1024
+
+static FILE *fm_file;
+
+static unsigned char *fm_buffer = NULL;
+static integer fm_size = 0;
+static integer fm_curbyte = 0;
+
+#define fm_open() \
+ open_input (&fm_file, kpse_fontmap_format, FOPEN_RBIN_MODE)
+#define fm_read_file() \
+ readbinfile(fm_file,&fm_buffer,&fm_size)
+#define fm_close() xfclose(fm_file, cur_file_name)
+#define fm_getchar() fm_buffer[fm_curbyte++]
+#define fm_eof() (fm_curbyte>=fm_size)
+
+typedef enum { FM_DUPIGNORE, FM_REPLACE, FM_DELETE } updatemode;
+typedef enum { MAPFILE, MAPLINE } maptype;
+
+typedef struct mitem {
+ updatemode mode; /* FM_DUPIGNORE or FM_REPLACE or FM_DELETE */
+ maptype type; /* map file or map line */
+ char *line; /* pointer to map file name or map line */
+ int lineno; /* line number in map file */
+} mapitem;
+mapitem *mitem = NULL;
+
+static const char nontfm[] = "<nontfm>";
+
+#define read_field(r, q, buf) do { \
+ q = buf; \
+ while (*r != ' ' && *r != '<' && *r != '"' && *r != '\0') \
+ *q++ = *r++; \
+ *q = '\0'; \
+ skip (r, ' '); \
+} while (0)
+
+#define set_field(F) do { \
+ if (q > buf) \
+ fm->F = xstrdup(buf); \
+ if (*r == '\0') \
+ goto done; \
+} while (0)
+
+fm_entry *new_fm_entry(void)
+{
+ fm_entry *fm;
+ fm = xtalloc(1, fm_entry);
+ fm->tfm_name = NULL;
+ fm->sfd_name = NULL;
+ fm->ps_name = NULL;
+ fm->fd_flags = 4;
+ fm->ff_name = NULL;
+ fm->encname = NULL;
+ fm->type = 0;
+ fm->slant = 0;
+ fm->extend = 0;
+ fm->links = 0;
+ fm->pid = -1;
+ fm->eid = -1;
+ fm->subfont = NULL;
+ fm->in_use = false;
+ return fm;
+}
+
+void delete_fm_entry(fm_entry * fm)
+{
+ xfree(fm->tfm_name);
+ xfree(fm->sfd_name);
+ xfree(fm->ps_name);
+ xfree(fm->ff_name);
+ xfree(fm);
+}
+
+static ff_entry *new_ff_entry (void)
+{
+ ff_entry *ff;
+ ff = xtalloc (1, ff_entry);
+ ff->ff_name = NULL;
+ ff->ff_path = NULL;
+ return ff;
+}
+
+static void delete_ff_entry (ff_entry * ff)
+{
+ xfree (ff->ff_name);
+ xfree (ff->ff_path);
+ xfree (ff);
+}
+
+static fm_entry *dummy_fm_entry ()
+{
+ static const fm_entry const_fm_entry;
+ return (fm_entry *) & const_fm_entry;
+}
+
+/**********************************************************************/
+
+struct avl_table *tfm_tree = NULL;
+struct avl_table *ps_tree = NULL;
+struct avl_table *ff_tree = NULL;
+struct avl_table *encname_tree = NULL;
+
+/* AVL sort fm_entry into tfm_tree by tfm_name */
+
+static int comp_fm_entry_tfm (const void *pa, const void *pb, void *p)
+{
+ return strcmp (((const fm_entry *) pa)->tfm_name,
+ ((const fm_entry *) pb)->tfm_name);
+}
+
+/* AVL sort fm_entry into ps_tree by ps_name, slant, and extend */
+
+static int comp_fm_entry_ps(const void *pa, const void *pb, void *p)
+{
+ int i;
+ const fm_entry *p1 = (const fm_entry *) pa, *p2 = (const fm_entry *) pb;
+ assert(p1->ps_name != NULL && p2->ps_name != NULL);
+ if ((i = strcmp(p1->ps_name, p2->ps_name)))
+ return i;
+ cmp_return(p1->slant, p2->slant);
+ cmp_return(p1->extend, p2->extend);
+ return 0;
+}
+
+/* AVL sort ff_entry into ff_tree by ff_name */
+
+static int comp_ff_entry (const void *pa, const void *pb, void *p)
+{
+ return strcmp (((const ff_entry *) pa)->ff_name,
+ ((const ff_entry *) pb)->ff_name);
+}
+
+static void create_avl_trees ()
+{
+ assert(tfm_tree == NULL);
+ tfm_tree = avl_create(comp_fm_entry_tfm, NULL, &avl_xallocator);
+ assert(tfm_tree != NULL);
+ assert(ps_tree == NULL);
+ ps_tree = avl_create(comp_fm_entry_ps, NULL, &avl_xallocator);
+ assert(ps_tree != NULL);
+ assert(ff_tree == NULL);
+ ff_tree = avl_create(comp_ff_entry, NULL, &avl_xallocator);
+ assert(ff_tree != NULL);
+ assert(encname_tree == NULL);
+ encname_tree = avl_create(comp_string_entry, NULL, &avl_xallocator);
+ assert(encname_tree != NULL);
+}
+
+/*
+The function avl_do_entry() is not completely symmetrical with regards
+to tfm_name and ps_name handling, e. g. a duplicate tfm_name gives a
+"goto exit", and no ps_name link is tried. This is to keep it compatible
+with the original version.
+*/
+
+int avl_do_entry(fm_entry * fm, int mode)
+{
+ fm_entry *p;
+ void *a;
+ void **aa;
+
+ /* handle tfm_name link */
+
+ if (strcmp(fm->tfm_name, nontfm)) {
+ p = (fm_entry *) avl_find(tfm_tree, fm);
+ if (p != NULL) {
+ switch (mode) {
+ case FM_DUPIGNORE:
+ pdftex_warn
+ ("fontmap entry for `%s' already exists, duplicates ignored",
+ fm->tfm_name);
+ goto exit;
+ break;
+ case FM_REPLACE:
+ case FM_DELETE:
+ if (p->in_use) {
+ pdftex_warn
+ ("fontmap entry for `%s' has been used, replace/delete not allowed",
+ fm->tfm_name);
+ goto exit;
+ }
+ a = avl_delete(tfm_tree, p);
+ assert(a != NULL);
+ unset_tfmlink(p);
+ if (!has_pslink(p))
+ delete_fm_entry(p);
+ break;
+ default:
+ assert(0);
+ }
+ }
+ if (mode != FM_DELETE) {
+ aa = avl_probe(tfm_tree, fm);
+ assert(aa != NULL);
+ set_tfmlink(fm);
+ }
+ }
+
+ /* handle ps_name link */
+
+ if (fm->ps_name != NULL) {
+ p = (fm_entry *) avl_find(ps_tree, fm);
+ if (p != NULL) {
+ switch (mode) {
+ case FM_DUPIGNORE:
+ goto exit;
+ break;
+ case FM_REPLACE:
+ case FM_DELETE:
+ if (p->in_use)
+ goto exit;
+ a = avl_delete(ps_tree, p);
+ assert(a != NULL);
+ unset_pslink(p);
+ if (!has_tfmlink(p))
+ delete_fm_entry(p);
+ break;
+ default:
+ assert(0);
+ }
+ }
+ if (mode != FM_DELETE && is_t1fontfile(fm) && is_included(fm)) {
+ aa = avl_probe(ps_tree, fm);
+ assert(aa != NULL);
+ set_pslink(fm);
+ }
+ }
+ exit:
+ if (!has_tfmlink(fm) && !has_pslink(fm)) /* e. g. after FM_DELETE */
+ return 1; /* deallocation of fm_entry structure required */
+ else
+ return 0;
+}
+
+/* add the encoding name to an AVL tree. this has nothing to do with writeenc.c */
+
+char *add_encname(char *s)
+{
+ char *p;
+ void **aa;
+ assert(s != NULL);
+ assert(encname_tree != NULL);
+ if ((p = (char *) avl_find(encname_tree, s)) == NULL) { /* encoding name not yet registered */
+ p = xstrdup(s);
+ aa = avl_probe(encname_tree, p);
+ assert(aa != NULL);
+ }
+ return p;
+}
+
+/**********************************************************************/
+/* consistency check for map entry, with warn flag */
+
+int check_fm_entry(fm_entry * fm, boolean warn)
+{
+ int a = 0;
+ assert(fm != NULL);
+
+ if (is_fontfile(fm) && !is_included(fm)) {
+ if (warn)
+ pdftex_warn
+ ("ambiguous entry for `%s': font file present but not included, "
+ "will be treated as font file not present", fm->tfm_name);
+ xfree(fm->ff_name);
+ /* do not set variable |a| as this entry will be still accepted */
+ }
+
+ /* if both ps_name and font file are missing, drop this entry */
+ if (fm->ps_name == NULL && !is_fontfile(fm)) {
+ if (warn)
+ pdftex_warn
+ ("invalid entry for `%s': both ps_name and font file missing",
+ fm->tfm_name);
+ a += 1;
+ }
+
+ /* TrueType fonts cannot be reencoded without subsetting */
+ if (is_truetype(fm) && is_reencoded(fm) && !is_subsetted(fm)) {
+ if (warn)
+ pdftex_warn
+ ("invalid entry for `%s': only subsetted TrueType font can be reencoded",
+ fm->tfm_name);
+ a += 2;
+ }
+
+ /* SlantFont and ExtendFont can be used only with Type1 fonts */
+ if ((fm->slant != 0 || fm->extend != 0)
+ && !(is_t1fontfile(fm) && is_included(fm))) {
+ if (warn)
+ pdftex_warn
+ ("invalid entry for `%s': SlantFont/ExtendFont can be used only with embedded Type1 fonts",
+ fm->tfm_name);
+ a += 4;
+ }
+
+ /* the value of SlantFont and ExtendFont must be reasonable */
+ if (abs(fm->slant) > 1000) {
+ if (warn)
+ pdftex_warn
+ ("invalid entry for `%s': too big value of SlantFont (%g)",
+ fm->tfm_name, fm->slant / 1000.0);
+ a += 8;
+ }
+ if (abs(fm->extend) > 2000) {
+ if (warn)
+ pdftex_warn
+ ("invalid entry for `%s': too big value of ExtendFont (%g)",
+ fm->tfm_name, fm->extend / 1000.0);
+ a += 16;
+ }
+
+ /* subfonts must be used with subsetted non-reencoded TrueType fonts */
+ if (fm->pid != -1 &&
+ !(is_truetype(fm) && is_subsetted(fm) && !is_reencoded(fm))) {
+ if (warn)
+ pdftex_warn
+ ("invalid entry for `%s': PidEid can be used only with subsetted non-reencoded TrueType fonts",
+ fm->tfm_name);
+ a += 32;
+ }
+
+ return a;
+}
+
+/**********************************************************************/
+/* returns true if s is one of the 14 std. font names; speed-trimmed. */
+
+boolean check_std_t1font(char *s)
+{
+ static const char *std_t1font_names[] = {
+ "Courier", /* 0:7 */
+ "Courier-Bold", /* 1:12 */
+ "Courier-Oblique", /* 2:15 */
+ "Courier-BoldOblique", /* 3:19 */
+ "Helvetica", /* 4:9 */
+ "Helvetica-Bold", /* 5:14 */
+ "Helvetica-Oblique", /* 6:17 */
+ "Helvetica-BoldOblique", /* 7:21 */
+ "Symbol", /* 8:6 */
+ "Times-Roman", /* 9:11 */
+ "Times-Bold", /* 10:10 */
+ "Times-Italic", /* 11:12 */
+ "Times-BoldItalic", /* 12:16 */
+ "ZapfDingbats" /* 13:12 */
+ };
+ static const int index[] =
+ { -1, -1, -1, -1, -1, -1, 8, 0, -1, 4, 10, 9, -1, -1, 5, 2, 12, 6, -1,
+ 3, -1, 7
+ };
+ const size_t n = strlen(s);
+ int k = -1;
+ if (n > 21)
+ return false;
+ if (n == 12) { /* three names have length 12 */
+ switch (*s) {
+ case 'C':
+ k = 1; /* Courier-Bold */
+ break;
+ case 'T':
+ k = 11; /* Times-Italic */
+ break;
+ case 'Z':
+ k = 13; /* ZapfDingbats */
+ break;
+ default:
+ return false;
+ }
+ } else
+ k = index[n];
+ if (k > -1 && !strcmp(std_t1font_names[k], s))
+ return true;
+ return false;
+};
+
+/**********************************************************************/
+
+static void fm_scan_line()
+{
+ int a, b, c, j, u = 0, v = 0;
+ float d;
+ fm_entry *fm;
+ char fm_line[FM_BUF_SIZE], buf[FM_BUF_SIZE];
+ char *p, *q, *r, *s;
+ switch (mitem->type) {
+ case MAPFILE:
+ p = fm_line;
+ do {
+ c = fm_getchar();
+ append_char_to_buf(c, p, fm_line, FM_BUF_SIZE);
+ }
+ while (c != 10 && !fm_eof());
+ *(--p) = '\0';
+ r = fm_line;
+ break;
+ case MAPLINE:
+ r = mitem->line; /* work on string from makecstring() */
+ break;
+ default:
+ assert(0);
+ }
+ if (*r == '\0' || is_cfg_comment(*r))
+ return;
+ fm = new_fm_entry();
+ read_field(r, q, buf);
+ set_field(tfm_name);
+ if (!isdigit(*r)) { /* 2nd field ps_name may not start with a digit */
+ read_field(r, q, buf);
+ set_field(ps_name);
+ }
+ if (isdigit(*r)) { /* font descriptor /Flags given? */
+ for (s = r; isdigit(*s); s++);
+ if (*s == ' ' || *s == '"' || *s == '<' || *s == '\0') { /* not e. g. 8r.enc */
+ fm->fd_flags = atoi(r);
+ while (isdigit(*r))
+ r++;
+ }
+ }
+ while (1) { /* loop through "specials", encoding, font file */
+ skip(r, ' ');
+ switch (*r) {
+ case '\0':
+ goto done;
+ case '"': /* opening quote */
+ r++;
+ u = v = 0;
+ do {
+ skip(r, ' ');
+ if (sscanf(r, "%f %n", &d, &j) > 0) {
+ s = r + j; /* jump behind number, eat also blanks, if any */
+ if (*(s - 1) == 'E' || *(s - 1) == 'e')
+ s--; /* e. g. 0.5ExtendFont: %f = 0.5E */
+ if (str_prefix(s, "SlantFont")) {
+ d *= 1000.0; /* correct rounding also for neg. numbers */
+ fm->slant = (integer) (d > 0 ? d + 0.5 : d - 0.5);
+ r = s + strlen("SlantFont");
+ } else if (str_prefix(s, "ExtendFont")) {
+ d *= 1000.0;
+ fm->extend = (integer) (d > 0 ? d + 0.5 : d - 0.5);
+ if (fm->extend == 1000)
+ fm->extend = 0;
+ r = s + strlen("ExtendFont");
+ } else { /* unknown name */
+ for (r = s; *r != ' ' && *r != '"' && *r != '\0'; r++); /* jump over name */
+ c = *r; /* remember char for temporary end of string */
+ *r = '\0';
+ pdftex_warn
+ ("invalid entry for `%s': unknown name `%s' ignored",
+ fm->tfm_name, s);
+ *r = c;
+ }
+ } else
+ for (; *r != ' ' && *r != '"' && *r != '\0'; r++);
+ }
+ while (*r == ' ');
+ if (*r == '"') /* closing quote */
+ r++;
+ else {
+ pdftex_warn
+ ("invalid entry for `%s': closing quote missing",
+ fm->tfm_name);
+ goto bad_line;
+ }
+ break;
+ case 'P': /* handle cases for subfonts like 'PidEid=3,1' */
+ if (sscanf(r, "PidEid=%i, %i %n", &a, &b, &c) >= 2) {
+ fm->pid = a;
+ fm->eid = b;
+ r += c;
+ break;
+ }
+ default: /* encoding or font file specification */
+ a = b = 0;
+ if (*r == '<') {
+ a = *r++;
+ if (*r == '<' || *r == '[')
+ b = *r++;
+ }
+ read_field(r, q, buf);
+ /* encoding, formats: '8r.enc' or '<8r.enc' or '<[8r.enc' */
+ if (strlen(buf) > 4 && strcasecmp(strend(buf) - 4, ".enc") == 0) {
+ fm->encname = add_encname(buf);
+ u = v = 0; /* u, v used if intervening blank: "<< foo" */
+ } else if (strlen(buf) > 0) { /* file name given */
+ /* font file, formats:
+ * subsetting: '<cmr10.pfa'
+ * no subsetting: '<<cmr10.pfa'
+ * no embedding: 'cmr10.pfa'
+ */
+ if (a == '<' || u == '<') {
+ set_included(fm);
+ if ((a == '<' && b == 0) || (a == 0 && v == 0))
+ set_subsetted(fm);
+ /* otherwise b == '<' (or '[') => no subsetting */
+ }
+ set_field(ff_name);
+ u = v = 0;
+ } else {
+ u = a;
+ v = b;
+ }
+ }
+ }
+ done:
+ if (fm->ps_name != NULL && check_std_t1font(fm->ps_name))
+ set_std_t1font(fm);
+ if (is_fontfile(fm)) {
+ if (strcasecmp(strend(fm_fontfile(fm)) - 4, ".ttf") == 0)
+ set_truetype(fm);
+ else if (strcasecmp(strend(fm_fontfile(fm)) - 4, ".otf") == 0)
+ set_opentype(fm);
+ else
+ set_type1(fm);
+ } else
+ set_type1(fm); /* assume a builtin font is Type1 */
+ if (check_fm_entry(fm, true) != 0)
+ goto bad_line;
+ /*
+ Until here the map line has been completely scanned without errors;
+ fm points to a valid, freshly filled-out fm_entry structure.
+ Now follows the actual work of registering/deleting.
+ */
+ if (handle_subfont_fm(fm, mitem->mode)) /* is this a subfont? */
+ return;
+ if (avl_do_entry(fm, mitem->mode) == 0) /* if success */
+ return;
+ bad_line:
+ delete_fm_entry(fm);
+}
+
+/**********************************************************************/
+
+void fm_read_info ()
+{
+ int callback_id;
+ int file_opened = 0;
+ char *ftemp = NULL;
+ if (tfm_tree == NULL)
+ create_avl_trees ();
+ if (mitem->line == NULL) /* nothing to do */
+ return;
+ mitem->lineno = 1;
+ switch (mitem->type) {
+ case MAPFILE:
+ set_cur_file_name (mitem->line);
+ if (fm_buffer!=NULL) {
+ xfree(fm_buffer);
+ fm_buffer=NULL;
+ }
+ fm_curbyte=0;
+ fm_size=0;
+ callback_id=callback_defined(find_map_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",(char *)(nameoffile+1),&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(nameoffile);
+ namelength = strlen(ftemp);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),ftemp);
+ free(ftemp);
+ }
+ }
+ }
+ callback_id=callback_defined(read_map_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",(char *)(nameoffile+1),
+ &file_opened, &fm_buffer,&fm_size)) {
+ if(file_opened) {
+ if (fm_size>0) {
+ cur_file_name = (char *) nameoffile + 1;
+ if (tracefilenames)
+ tex_printf ("{%s", cur_file_name);
+ while (!fm_eof ()) {
+ fm_scan_line ();
+ mitem->lineno++;
+ }
+ if (tracefilenames)
+ tex_printf ("}");
+ fm_file = NULL;
+ }
+ } else {
+ pdftex_warn ("cannot open font map file");
+ }
+ } else {
+ pdftex_warn ("cannot open font map file");
+ }
+ } else {
+ if (!fm_open ()) {
+ pdftex_warn ("cannot open font map file");
+ } else {
+ fm_read_file();
+ cur_file_name = (char *) nameoffile + 1;
+ tex_printf ("{%s", cur_file_name);
+ while (!fm_eof ()) {
+ fm_scan_line ();
+ mitem->lineno++;
+ }
+ fm_close ();
+ tex_printf ("}");
+ fm_file = NULL;
+ }
+ }
+ break;
+ case MAPLINE:
+ cur_file_name = NULL; /* makes pdftex_warn() shorter */
+ fm_scan_line ();
+ break;
+ default:
+ assert (0);
+ }
+ mitem->line = NULL; /* done with this line */
+ cur_file_name = NULL;
+ return;
+}
+
+/**********************************************************************/
+
+static fm_entry_ptr fmlookup(internalfontnumber f)
+{
+ char *tfm;
+ fm_entry *fm;
+ fm_entry tmp;
+ if (tfm_tree == NULL)
+ fm_read_info(); /* only to read default map file */
+ tfm = font_name(f);
+ assert(strcmp(tfm, nontfm));
+
+ /* Look up for full <tfmname>[+-]<expand> */
+ tmp.tfm_name = tfm;
+ fm = (fm_entry *) avl_find(tfm_tree, &tmp);
+ if (fm != NULL) {
+ fm->in_use = true;
+ return (fm_entry_ptr) fm;
+ }
+ return (fm_entry_ptr) dummy_fm_entry();
+}
+
+boolean hasfmentry(internalfontnumber f)
+{
+ if (font_map(f) == NULL)
+ set_font_map(f, (fm_entry_ptr) fmlookup(f));
+ assert(font_map(f) != NULL);
+ return font_map(f) != (fm_entry_ptr) dummy_fm_entry();
+}
+
+/* check whether a map entry is valid for font replacement */
+
+static boolean fm_valid_for_font_replacement(fm_entry * fm)
+{
+ ff_entry *ff;
+
+ assert(fm != NULL);
+ assert(is_fontfile(fm)); /* ps_tree should contain only entries with font file */
+ assert(is_type1(fm)); /* ps_tree should contain only Type1 entries */
+
+ ff = check_ff_exist(fm->ff_name, false);
+ assert(ff != NULL);
+ if (ff->ff_path == NULL) /* ...there is no font file available */
+ return false;
+ return true; /* all tests passed */
+}
+
+/**********************************************************************/
+/*
+ * lookup fontmap by ps_name;
+ * used for Type1 font replacement when embedding of PDF files
+ */
+
+fm_entry *lookup_fontmap(char *ps_name)
+{
+ fm_entry *fm, *fm2, tmp;
+ char *a, *b, *c, *d, *e, *s;
+ int i, sl, ex;
+ struct avl_traverser t, t2;
+ if (tfm_tree == NULL)
+ fm_read_info(); /* only to read default map file */
+ assert(ps_name != NULL);
+ s = ps_name;
+ if (strlen(ps_name) > 7) { /* check for subsetted name tag */
+ for (i = 0; i < 6; i++, s++)
+ if (*s < 'A' || *s > 'Z')
+ break;
+ if (i == 6 && *s == '+')
+ s++; /* if name tag found, skip behind it */
+ else
+ s = ps_name;
+ }
+
+ /*
+ * Scan -Slant_<slant> and -Extend_<extend> font name extensions;
+ * three valid formats:
+ * <fontname>-Slant_<slant>
+ * <fontname>-Slant_<slant>-Extend_<extend>
+ * <fontname>-Extend_<extend>
+ * Slant entry must come _before_ Extend entry
+ */
+
+ tmp.slant = 0;
+ tmp.extend = 0;
+ if ((a = strstr(s, "-Slant_")) != NULL) {
+ b = a + strlen("-Slant_");
+ sl = (int) strtol(b, &e, 10);
+ if ((e != b) && (e == strend(b))) {
+ tmp.slant = sl;
+ *a = '\0'; /* ps_name string ends before "-Slant_" */
+ } else {
+ if (e != b) { /* only if <slant> is valid number */
+ if ((c = strstr(e, "-Extend_")) != NULL) {
+ d = c + strlen("-Extend_");
+ ex = (int) strtol(d, &e, 10);
+ if ((e != d) && (e == strend(d))) {
+ tmp.slant = sl;
+ tmp.extend = ex;
+ *a = '\0'; /* ps_name string ends before "-Slant_" */
+ }
+ }
+ }
+ }
+ } else {
+ if ((a = strstr(s, "-Extend_")) != NULL) {
+ b = a + strlen("-Extend_");
+ ex = (int) strtol(b, &e, 10);
+ if ((e != b) && (e == strend(b))) {
+ tmp.extend = ex;
+ *a = '\0'; /* ps_name string ends before "-Extend_" */
+ }
+ }
+ }
+ tmp.ps_name = s;
+
+ fm = (fm_entry *) avl_t_find(&t, ps_tree, &tmp);
+ if (fm == NULL)
+ return NULL; /* no entry found */
+
+ /* at this point we know there is at least one fm_entry with given ps_name;
+ * we test all such entries and return the first one that is valid for font
+ * replacement */
+
+ t2 = t;
+ fm2 = (fm_entry *) avl_t_prev(&t2);
+
+ /* search forward */
+ do {
+ if (fm_valid_for_font_replacement(fm))
+ return fm;
+ fm = (fm_entry *) avl_t_next(&t);
+ } while (fm != NULL && comp_fm_entry_ps(fm, &tmp, NULL) == 0);
+
+ /* search backward */
+ while (fm2 != NULL && comp_fm_entry_ps(fm2, &tmp, NULL) == 0) {
+ if (fm_valid_for_font_replacement(fm2))
+ return fm2;
+ fm2 = (fm_entry *) avl_t_prev(&t2);
+ }
+
+ return NULL;
+}
+
+/**********************************************************************/
+/*
+ * Process map file given by its name or map line contents. Items not
+ * beginning with [+-=] flush default map file, if it has not yet been
+ * read. Leading blanks and blanks immediately following [+-=] are
+ * ignored.
+ */
+
+void process_map_item(char *s, int type)
+{
+ char *p;
+ int mode;
+ if (*s == ' ')
+ s++; /* ignore leading blank */
+ switch (*s) {
+ case '+': /* +mapfile.map, +mapline */
+ mode = FM_DUPIGNORE; /* insert entry, if it is not duplicate */
+ s++;
+ break;
+ case '=': /* =mapfile.map, =mapline */
+ mode = FM_REPLACE; /* try to replace earlier entry */
+ s++;
+ break;
+ case '-': /* -mapfile.map, -mapline */
+ mode = FM_DELETE; /* try to delete entry */
+ s++;
+ break;
+ default:
+ mode = FM_DUPIGNORE; /* like +, but also: */
+ mitem->line = NULL; /* flush default map file name */
+ }
+ if (*s == ' ')
+ s++; /* ignore blank after [+-=] */
+ p = s; /* map item starts here */
+ switch (type) {
+ case MAPFILE: /* remove blank at end */
+ while (*p != '\0' && *p != ' ')
+ p++;
+ *p = '\0';
+ break;
+ case MAPLINE: /* blank at end allowed */
+ break;
+ default:
+ assert(0);
+ }
+ if (mitem->line != NULL) /* read default map file first */
+ fm_read_info();
+ if (*s != '\0') { /* only if real item to process */
+ mitem->mode = mode;
+ mitem->type = type;
+ mitem->line = s;
+ fm_read_info();
+ }
+}
+
+void pdfmapfile(integer t)
+{
+ process_map_item(makecstring(tokens_to_string(t)), MAPFILE);
+ flush_str(last_tokens_string);
+}
+
+void pdfmapline(integer t)
+{
+ process_map_item(makecstring(tokens_to_string(t)), MAPLINE);
+ flush_str(last_tokens_string);
+}
+
+void pdf_init_map_file(string map_name)
+{
+ assert(mitem == NULL);
+ mitem = xtalloc(1, mapitem);
+ mitem->mode = FM_DUPIGNORE;
+ mitem->type = MAPFILE;
+ mitem->line = xstrdup(map_name);
+}
+
+
+/**********************************************************************/
+/*
+ * Early check whether a font file exists. Search tree ff_tree is used
+ * in 1st instance, as it may be faster than the kpse_find_file(), and
+ * kpse_find_file() is called only once per font file name + expansion
+ * parameter. This might help keeping speed, if many PDF pages with
+ * same fonts are to be embedded.
+ *
+ * The ff_tree contains only font files, which are actually needed,
+ * so this tree typically is much smaller than the tfm_tree or ps_tree.
+ */
+
+ff_entry *check_ff_exist(char *ff_name, boolean is_tt)
+{
+ ff_entry *ff;
+ ff_entry tmp;
+ void **aa;
+ int callback_id;
+ char *filepath=NULL;
+
+ assert(ff_name != NULL);
+ tmp.ff_name = ff_name;
+ ff = (ff_entry *) avl_find(ff_tree, &tmp);
+ if (ff == NULL) { /* not yet in database */
+ ff = new_ff_entry();
+ ff->ff_name = xstrdup(ff_name);
+ if (is_tt) {
+ callback_id=callback_defined(find_truetype_file_callback);
+ if (callback_id>0) {
+ run_callback(callback_id,"S->S",ff_name,&filepath);
+ if (filepath && strlen(filepath)==0)
+ filepath=NULL;
+ ff->ff_path = filepath;
+ } else {
+ ff->ff_path = kpse_find_file (ff_name, kpse_truetype_format, 0);
+ }
+ }
+ else {
+ callback_id=callback_defined(find_type1_file_callback);
+ if (callback_id>0) {
+ run_callback(callback_id,"S->S",ff_name,&filepath);
+ if (filepath && strlen(filepath)==0)
+ filepath=NULL;
+ ff->ff_path = filepath;
+ } else {
+ ff->ff_path = kpse_find_file (ff_name, kpse_type1_format, 0);
+ }
+ }
+ aa = avl_probe(ff_tree, ff);
+ assert(aa != NULL);
+ }
+ return ff;
+}
+
+/**********************************************************************/
+/* cleaning up... */
+
+static void destroy_fm_entry_tfm(void *pa, void *pb)
+{
+ fm_entry *fm;
+ fm = (fm_entry *) pa;
+ if (!has_pslink(fm))
+ delete_fm_entry(fm);
+ else
+ unset_tfmlink(fm);
+}
+
+static void destroy_fm_entry_ps(void *pa, void *pb)
+{
+ fm_entry *fm;
+ fm = (fm_entry *) pa;
+ if (!has_tfmlink(fm))
+ delete_fm_entry(fm);
+ else
+ unset_pslink(fm);
+}
+
+static void destroy_ff_entry(void *pa, void *pb)
+{
+ ff_entry *ff;
+ ff = (ff_entry *) pa;
+ delete_ff_entry(ff);
+}
+
+void fm_free(void)
+{
+ if (tfm_tree != NULL) {
+ avl_destroy(tfm_tree, destroy_fm_entry_tfm);
+ tfm_tree = NULL;
+ }
+ if (ps_tree != NULL) {
+ avl_destroy(ps_tree, destroy_fm_entry_ps);
+ ps_tree = NULL;
+ }
+ if (ff_tree != NULL) {
+ avl_destroy(ff_tree, destroy_ff_entry);
+ ff_tree = NULL;
+ }
+}
+
+/**********************************************************************/
+/* end of mapfile.c */
diff --git a/Build/source/texk/web2c/luatexdir/font/pkin.c b/Build/source/texk/web2c/luatexdir/font/pkin.c
new file mode 100644
index 00000000000..5067d6dbd66
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/pkin.c
@@ -0,0 +1,439 @@
+/*
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: pkin.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+/*
+ * NAME
+ * pkin.c - implementation of readchar()
+ * DESCRIPTION
+ * This implementation of readchar() uses parts of the program dvips
+ * written by Tomas Rokicki--the inventor of the pkformat--(loadfont.c,
+ * download.c and unpack.c). Dvips in turn is derived from pktype.
+ * Pktype(TeX) is described in debt in ``The PKtype processor'',
+ * which is available as pktype.weave as part of the METAFONTware.
+ * What was needed to implement readchar() is rearranged in pkfile.c to
+ * get more modularity in the style of MODULA2.
+ * BUGFIXES
+ * May 1997: Eric Delaunay <delaunay@lix.polytechnique.fr> reports a
+ * problem with huge fonts (greater than 1008 DPI). The code for
+ * handling PK characters in `extended format' was wrongly derived
+ * from dvips. Made some minor improvements regarding error handling.
+ * REDESIGN
+ * Piet Tutelaers
+ * rcpt@urc.tue.nl
+ *
+ * Modified for use with pdftex by Han The Thanh <thanh@fi.muni.cz>.
+ */
+
+#include "ptexlib.h"
+
+/*
+ * Now we have some routines to get stuff from the pk file. pkbyte returns
+ * the next byte from the pk file.
+ */
+
+
+/*
+static FILE *pkfile ;
+*/
+
+extern FILE *t3_file;
+#define pkfile t3_file
+
+static shalfword pkbyte(void)
+{
+ register shalfword i;
+
+ if ((i = xgetc(pkfile)) == EOF)
+ pdftex_fail("unexpected eof in pk file");
+ return (i);
+}
+
+static integer pkduo(void)
+{
+ register integer i;
+
+ i = pkbyte();
+ if (i > 127)
+ i -= 256;
+ i = i * 256 + pkbyte();
+ return (i);
+}
+
+static integer pktrio(void)
+{
+ register integer i;
+
+ i = pkbyte();
+ if (i > 127)
+ i -= 256;
+ i = i * 256 + pkbyte();
+ i = i * 256 + pkbyte();
+ return (i);
+}
+
+static integer pkquad(void)
+{
+ register integer i;
+
+ i = pkbyte();
+ if (i > 127)
+ i -= 256;
+ i = i * 256 + pkbyte();
+ i = i * 256 + pkbyte();
+ i = i * 256 + pkbyte();
+ return (i);
+}
+
+/*
+ * The next part is devoted to unpacking the character data.
+ */
+
+/*
+ * We need procedures to get a nybble, bit, and packed word from the
+ * packed data structure.
+ */
+
+static halfword inputbyte, flagbyte;
+static halfword bitweight;
+static halfword dynf;
+static halfword repeatcount;
+
+static shalfword getnyb(void)
+{
+ halfword temp;
+ if (bitweight == 0) {
+ bitweight = 16;
+ inputbyte = pkbyte();
+ temp = inputbyte >> 4;
+ } else {
+ bitweight = 0;
+ temp = inputbyte & 15;
+ }
+ return (temp);
+}
+
+static boolean getbit(void)
+{
+ bitweight >>= 1;
+ if (bitweight == 0) {
+ inputbyte = pkbyte();
+ bitweight = 128;
+ }
+ return (inputbyte & bitweight);
+}
+
+static halfword(*realfunc) (void);
+long pk_remainder;
+static halfword handlehuge(halfword i, halfword k);
+
+static halfword pkpackednum(void)
+{
+ register halfword i, j;
+ i = getnyb();
+ if (i == 0) {
+ do {
+ j = getnyb();
+ i++;
+ } while (!(j != 0));
+ if (i > 3) {
+/*
+ * Damn, we got a huge count! We *fake* it by giving an artificially
+ * large repeat count.
+ */
+ return (handlehuge(i, j));
+ } else {
+ while (i > 0) {
+ j = j * 16 + getnyb();
+ i--;
+ }
+ return (j - 15 + (13 - dynf) * 16 + dynf);
+ }
+ } else if (i <= dynf)
+ return (i);
+ else if (i < 14)
+ return ((i - dynf - 1) * 16 + getnyb() + dynf + 1);
+ else {
+ if (i == 14)
+ repeatcount = pkpackednum();
+ else
+ repeatcount = 1;
+#ifdef DEBUG
+ printf("[%d]", (int) repeatcount);
+#endif
+ return ((*realfunc) ());
+ }
+}
+
+static halfword rest(void)
+{
+ halfword i;
+
+ if (pk_remainder < 0) {
+ pk_remainder = -pk_remainder;
+ return (0);
+ } else if (pk_remainder > 0) {
+ if (pk_remainder > 4000) {
+ pk_remainder = 4000 - pk_remainder;
+ return (4000);
+ } else {
+ i = pk_remainder;
+ pk_remainder = 0;
+ realfunc = pkpackednum;
+ return (i);
+ }
+ } else {
+ pdftex_fail("shouldn't happen");
+ return 0;
+ /*NOTREACHED*/}
+}
+
+static halfword handlehuge(halfword i, halfword k)
+{
+ register long j = k;
+
+ while (i) {
+ j = (j << 4L) + getnyb();
+ i--;
+ }
+ pk_remainder = j - 15 + (13 - dynf) * 16 + dynf;
+ realfunc = rest;
+ return (rest());
+}
+
+/*
+ * And now we have our unpacking routine.
+ */
+
+static halfword gpower[17] = { 0, 1, 3, 7, 15, 31, 63, 127,
+ 255, 511, 1023, 2047, 4095, 8191, 16383, 32767, 65535
+};
+
+static void unpack(chardesc * cd)
+{
+ register integer i, j;
+ register halfword word, wordweight;
+ halfword *raster;
+ shalfword rowsleft;
+ boolean turnon;
+ shalfword hbit;
+ halfword count;
+ shalfword wordwidth;
+
+ wordwidth = (cd->cwidth + 15) / 16;
+ i = 2 * cd->cheight * (long) wordwidth;
+ if (i <= 0)
+ i = 2;
+ if (i > cd->rastersize) {
+ xfree(cd->raster);
+ cd->rastersize = i;
+ cd->raster = xtalloc(cd->rastersize, halfword);
+ }
+ raster = cd->raster;
+ realfunc = pkpackednum;
+ dynf = flagbyte / 16;
+ turnon = flagbyte & 8;
+ if (dynf == 14) {
+ bitweight = 0;
+ for (i = 1; i <= cd->cheight; i++) {
+ word = 0;
+ wordweight = 32768;
+ for (j = 1; j <= cd->cwidth; j++) {
+ if (getbit())
+ word += wordweight;
+ wordweight >>= 1;
+ if (wordweight == 0) {
+ *raster++ = word;
+ word = 0;
+ wordweight = 32768;
+ }
+ }
+ if (wordweight != 32768)
+ *raster++ = word;
+ }
+ } else {
+ rowsleft = cd->cheight;
+ hbit = cd->cwidth;
+ repeatcount = 0;
+ wordweight = 16;
+ word = 0;
+ bitweight = 0;
+ while (rowsleft > 0) {
+ count = (*realfunc) ();
+#ifdef DEBUG
+ if (turnon)
+ printf("(%d) ", (int) count);
+ else
+ printf("%d ", (int) count);
+#endif
+ while (count != 0) {
+ if ((count < wordweight) && (count < hbit)) {
+ if (turnon)
+ word += gpower[wordweight] - gpower[wordweight - count];
+ hbit -= count;
+ wordweight -= count;
+ count = 0;
+ } else if ((count >= hbit) && (hbit <= wordweight)) {
+ if (turnon)
+ word += gpower[wordweight] - gpower[wordweight - hbit];
+ *raster++ = word;
+ for (i = 1; i <= repeatcount; i++) {
+ for (j = 1; j <= wordwidth; j++) {
+ *raster = *(raster - wordwidth);
+ raster++;
+ }
+ }
+ rowsleft -= repeatcount + 1;
+ repeatcount = 0;
+ word = 0;
+ wordweight = 16;
+ count -= hbit;
+ hbit = cd->cwidth;
+ } else {
+ if (turnon)
+ word += gpower[wordweight];
+ *raster++ = word;
+ word = 0;
+ count -= wordweight;
+ hbit -= wordweight;
+ wordweight = 16;
+ }
+ }
+ turnon = !turnon;
+ }
+ if ((rowsleft != 0) || ((integer) hbit != cd->cwidth))
+ pdftex_fail("error while unpacking; more bits than required");
+ }
+}
+
+/*
+ * readchar(): the main routine
+ * Reads the character definition of character `c' into `cd' if available,
+ * return FALSE (0) otherwise.
+ */
+
+/*
+ * readchar(): the main routine
+ * check pk preamble if necessary,
+ * read the next character definition into `cd',
+ * return EOF if no character definition is available
+ */
+
+int readchar(boolean check_preamble, chardesc * cd)
+{
+ register shalfword i;
+ register integer k;
+ register integer length = 0;
+
+/*
+ * Check the preamble of the pkfile
+ */
+ if (check_preamble) {
+ if (pkbyte() != 247)
+ pdftex_fail("bad pk file, expected pre");
+ if (pkbyte() != 89)
+ pdftex_fail("bad version of pk file");
+ for (i = pkbyte(); i > 0; i--) /* creator of pkfile */
+ (void) pkbyte();
+ (void) pkquad(); /* design size */
+ k = pkquad(); /* checksum */
+ k = pkquad(); /* hppp */
+ k = pkquad(); /* vppp */
+ }
+/*
+ * Now we skip to the desired character definition
+ */
+ while ((flagbyte = pkbyte()) != 245) {
+ if (flagbyte < 240) {
+ switch (flagbyte & 7) {
+ case 0:
+ case 1:
+ case 2:
+ case 3:
+ length = (flagbyte & 7) * 256 + pkbyte() - 3;
+ cd->charcode = pkbyte();
+ (void) pktrio(); /* TFMwidth */
+ cd->xescape = pkbyte(); /* pixel width */
+ cd->cwidth = pkbyte();
+ cd->cheight = pkbyte();
+ cd->xoff = pkbyte();
+ cd->yoff = pkbyte();
+ if (cd->xoff > 127)
+ cd->xoff -= 256;
+ if (cd->yoff > 127)
+ cd->yoff -= 256;
+ break;
+ case 4:
+ case 5:
+ case 6:
+ length = (flagbyte & 3) * 65536L + pkbyte() * 256L;
+ length = length + pkbyte() - 4L;
+ cd->charcode = pkbyte();
+ (void) pktrio(); /* TFMwidth */
+ cd->xescape = pkduo(); /* pixelwidth */
+ cd->cwidth = pkduo();
+ cd->cheight = pkduo();
+ cd->xoff = pkduo();
+ cd->yoff = pkduo();
+ break;
+ case 7:
+ length = pkquad() - 9L;
+ cd->charcode = pkquad();
+ (void) pkquad(); /* TFMwidth */
+ cd->xescape = pkquad(); /* pixelwidth */
+ k = pkquad();
+ cd->cwidth = pkquad();
+ cd->cheight = pkquad();
+ cd->xoff = pkquad();
+ cd->yoff = pkquad();
+ }
+ if (length <= 0)
+ pdftex_fail("packet length (%i) too small", (int) length);
+ unpack(cd);
+ return 1;
+ } else {
+ k = 0;
+ switch (flagbyte) {
+ case 243:
+ k = pkbyte();
+ if (k > 127)
+ k -= 256;
+ case 242:
+ k = k * 256 + pkbyte();
+ case 241:
+ k = k * 256 + pkbyte();
+ case 240:
+ k = k * 256 + pkbyte();
+ while (k-- > 0)
+ i = pkbyte();
+ break;
+ case 244:
+ k = pkquad();
+ break;
+ case 246:
+ break;
+ default:
+ pdftex_fail("unexpected command (%i)", (int) flagbyte);
+ }
+ }
+ }
+ return 0; /* character not found */
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/sfnt.c b/Build/source/texk/web2c/luatexdir/font/sfnt.c
new file mode 100644
index 00000000000..95453a531a0
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/sfnt.c
@@ -0,0 +1,647 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/sfnt.c,v 1.12 2004/09/11 14:50:29 hirata Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+/* Based on dvipdfmx-0.13.2c */
+
+#if HAVE_CONFIG_H
+#include "config.h"
+#endif /* HAVE_CONFIG_H_ */
+
+#include <string.h>
+
+#ifndef pdfTeX
+#include "system.h"
+
+#include "error.h"
+#include "mem.h"
+#include "mfileio.h"
+#else
+extern void pdftex_fail (const char *fmt, ...); /* utils.c */
+#endif
+
+#include "sfnt.h"
+
+#ifdef XETEX
+UNSIGNED_BYTE
+ft_unsigned_byte(sfnt* f)
+{
+ unsigned char byte;
+ unsigned long length = 1;
+
+ if (FT_Load_Sfnt_Table(f->ft_face, 0, f->loc, &byte, &length) != 0)
+ TT_ERROR("sfnt: Freetype failure...");
+ f->loc += 1;
+
+ return byte;
+}
+
+SIGNED_BYTE
+ft_signed_byte(sfnt* f)
+{
+ int b = ft_unsigned_byte(f);
+ if (b >= 0x80)
+ b -= 0x100;
+ return (SIGNED_BYTE)b;
+}
+
+UNSIGNED_PAIR
+ft_unsigned_pair(sfnt* f)
+{
+ unsigned char buf[2];
+ unsigned long length = 2;
+
+ if (FT_Load_Sfnt_Table(f->ft_face, 0, f->loc, buf, &length) != 0)
+ TT_ERROR("sfnt: Freetype failure...");
+ f->loc += 2;
+
+ return (UNSIGNED_PAIR)((unsigned)buf[0] << 8) + buf[1];
+}
+
+SIGNED_PAIR
+ft_signed_pair(sfnt* f)
+{
+ int p = ft_unsigned_pair(f);
+ if (p >= 0x8000U)
+ p -= 0x10000U;
+
+ return (SIGNED_PAIR)p;
+}
+
+UNSIGNED_QUAD
+ft_unsigned_quad(sfnt* f)
+{
+ unsigned char buf[4];
+ unsigned long length = 4;
+
+ if (FT_Load_Sfnt_Table(f->ft_face, 0, f->loc, buf, &length) != 0)
+ TT_ERROR("sfnt: Freetype failure...");
+ f->loc += 4;
+
+ return ((unsigned long)buf[0] << 24) + ((unsigned long)buf[1] << 16)
+ + ((unsigned long)buf[2] << 8) + (unsigned long)buf[3];
+}
+
+unsigned long
+ft_read(unsigned char* buf, unsigned long len, sfnt* f)
+{
+ unsigned long length = len;
+ if (FT_Load_Sfnt_Table(f->ft_face, 0, f->loc, buf, &length) != 0)
+ TT_ERROR("sfnt: Freetype failure...");
+ f->loc += len;
+
+ return length;
+}
+#endif
+
+
+/*
+ * type:
+ * `true' (0x74727565): TrueType (Mac)
+ * `typ1' (0x74797031) (Mac): PostScript font housed in a sfnt wrapper
+ * 0x00010000: TrueType (Win)/OpenType
+ * `OTTO': PostScript CFF font with OpenType wrapper
+ * `ttcf': TrueType Collection
+*/
+#define SFNT_TRUETYPE 0x00010000UL
+#define SFNT_MAC_TRUE 0x74727565UL
+#define SFNT_OPENTYPE 0x00010000UL
+#define SFNT_POSTSCRIPT 0x4f54544fUL
+#define SFNT_TTC 0x74746366UL
+
+#ifdef XETEX
+sfnt *
+sfnt_open (FT_Face face, int accept_types)
+{
+ sfnt *sfont;
+ ULONG type;
+
+ if (!face || !FT_IS_SFNT(face))
+ return NULL;
+
+ sfont = NEW(1, sfnt);
+ sfont->ft_face = face;
+ sfont->loc = 0;
+ sfont->type = 0;
+
+ type = sfnt_get_ulong(sfont);
+
+ if (type == SFNT_TRUETYPE || type == SFNT_MAC_TRUE) {
+ sfont->type = SFNT_TYPE_TRUETYPE;
+ } else if (type == SFNT_OPENTYPE) {
+ sfont->type = SFNT_TYPE_OPENTYPE;
+ } else if (type == SFNT_POSTSCRIPT) {
+ sfont->type = SFNT_TYPE_POSTSCRIPT;
+ } else if (type == SFNT_TTC) {
+ sfont->type = SFNT_TYPE_TTC;
+ }
+
+ if ((sfont->type & accept_types) == 0) {
+ RELEASE(sfont);
+ return NULL;
+ }
+
+ sfont->loc = 0;
+
+ sfont->directory = NULL;
+
+ return sfont;
+}
+#else /* not XETEX */
+#ifdef pdfTeX
+sfnt *
+sfnt_open (unsigned char *buffer, integer buflen)
+{
+ sfnt *sfont;
+ ULONG type;
+
+ sfont = xmalloc(sizeof(sfnt));
+ sfont->loc = 0;
+ sfont->buffer = buffer;
+ sfont->buflen = buflen;
+
+ type = sfnt_get_ulong(sfont);
+
+ if (type == SFNT_TRUETYPE || type == SFNT_MAC_TRUE) {
+ sfont->type = SFNT_TYPE_TRUETYPE;
+ } else if (type == SFNT_OPENTYPE) {
+ sfont->type = SFNT_TYPE_OPENTYPE;
+ } else if (type == SFNT_POSTSCRIPT) {
+ sfont->type = SFNT_TYPE_POSTSCRIPT;
+ } else if (type == SFNT_TTC) {
+ sfont->type = SFNT_TYPE_TTC;
+ }
+
+ sfont->loc=0;
+ sfont->directory = NULL;
+ return sfont;
+}
+#else
+sfnt *
+sfnt_open (FILE *fp)
+{
+ sfnt *sfont;
+ ULONG type;
+
+ ASSERT(fp);
+
+ rewind(fp);
+
+ sfont = NEW(1, sfnt);
+
+ sfont->stream = fp;
+
+ type = sfnt_get_ulong(sfont);
+
+ if (type == SFNT_TRUETYPE || type == SFNT_MAC_TRUE) {
+ sfont->type = SFNT_TYPE_TRUETYPE;
+ } else if (type == SFNT_OPENTYPE) {
+ sfont->type = SFNT_TYPE_OPENTYPE;
+ } else if (type == SFNT_POSTSCRIPT) {
+ sfont->type = SFNT_TYPE_POSTSCRIPT;
+ } else if (type == SFNT_TTC) {
+ sfont->type = SFNT_TYPE_TTC;
+ }
+
+ rewind(sfont->stream);
+
+ sfont->directory = NULL;
+
+ return sfont;
+}
+#endif
+#endif
+
+static void
+release_directory (struct sfnt_table_directory *td)
+{
+ long i;
+
+ if (td) {
+ if (td->tables) {
+ for (i = 0; i < td->num_tables; i++) {
+ if (td->tables[i].data)
+ RELEASE(td->tables[i].data);
+ }
+ RELEASE(td->tables);
+ }
+ if (td->flags)
+ RELEASE(td->flags);
+ RELEASE(td);
+ }
+
+ return;
+}
+
+void
+sfnt_close (sfnt *sfont)
+{
+
+ if (sfont) {
+ if (sfont->directory)
+ release_directory(sfont->directory);
+ RELEASE(sfont);
+ }
+
+ return;
+}
+
+int
+put_big_endian (void *s, LONG q, int n)
+{
+ int i;
+ char *p;
+
+ p = (char *) s;
+ for (i = n - 1; i >= 0; i--) {
+ p[i] = (char) (q & 0xff);
+ q >>= 8;
+ }
+
+ return n;
+}
+
+/* Convert four-byte number to big endianess
+ * in a machine independent way.
+ */
+static void
+convert_tag (char *tag, unsigned long u_tag)
+{
+ int i;
+
+ for (i = 3; i >= 0; i--) {
+ tag[i] = (char) (u_tag % 256);
+ u_tag /= 256;
+ }
+
+ return;
+}
+
+/*
+ * Computes the max power of 2 <= n
+ */
+static unsigned
+max2floor (unsigned n)
+{
+ int val = 1;
+
+ while (n > 1) {
+ n /= 2;
+ val *= 2;
+ }
+
+ return val;
+}
+
+/*
+ * Computes the log2 of the max power of 2 <= n
+ */
+static unsigned
+log2floor (unsigned n)
+{
+ unsigned val = 0;
+
+ while (n > 1) {
+ n /= 2;
+ val++;
+ }
+
+ return val;
+}
+
+static ULONG
+sfnt_calc_checksum(void *data, ULONG length)
+{
+ ULONG chksum = 0;
+ BYTE *p, *endptr;
+ int count = 0;
+
+ p = (BYTE *) data;
+ endptr = p + length;
+ while (p < endptr) {
+ chksum += (p[0] << (8 * ( 3 - count)));
+ count = ((count + 1) & 3);
+ p++;
+ }
+
+ return chksum;
+}
+
+static int
+find_table_index (struct sfnt_table_directory *td, const char *tag)
+{
+ int idx;
+
+ if (!td)
+ return -1;
+
+ for (idx = 0; idx < td->num_tables; idx++) {
+ if (!memcmp(td->tables[idx].tag, tag, 4))
+ return idx;
+ }
+
+ return -1;
+}
+
+void
+sfnt_set_table (sfnt *sfont, const char *tag, void *data, ULONG length)
+{
+ struct sfnt_table_directory *td;
+ int idx;
+
+ ASSERT(sfont);
+
+ td = sfont->directory;
+ idx = find_table_index(td, tag);
+
+ if (idx < 0) {
+ idx = td->num_tables;
+ td->num_tables++;
+ td->tables = RENEW(td->tables, td->num_tables, struct sfnt_table);
+ memcpy(td->tables[idx].tag, tag, 4);
+ }
+
+ td->tables[idx].check_sum = sfnt_calc_checksum(data, length);
+ td->tables[idx].offset = 0L;
+ td->tables[idx].length = length;
+ td->tables[idx].data = data;
+
+ return;
+}
+
+ULONG
+sfnt_find_table_len (sfnt *sfont, const char *tag)
+{
+ ULONG length;
+ struct sfnt_table_directory *td;
+ int idx;
+
+ ASSERT(sfont && tag);
+
+ td = sfont->directory;
+ idx = find_table_index(td, tag);
+ if (idx < 0)
+ length = 0;
+ else {
+ length = td->tables[idx].length;
+ }
+
+ return length;
+}
+
+ULONG
+sfnt_find_table_pos (sfnt *sfont, const char *tag)
+{
+ ULONG offset;
+ struct sfnt_table_directory *td;
+ int idx;
+
+ ASSERT(sfont && tag);
+
+ td = sfont->directory;
+ idx = find_table_index(td, tag);
+ if (idx < 0)
+ offset = 0;
+ else {
+ offset = td->tables[idx].offset;
+ }
+
+ return offset;
+}
+
+ULONG
+sfnt_locate_table (sfnt *sfont, const char *tag)
+{
+ ULONG offset;
+
+ ASSERT(sfont && tag);
+
+ offset = sfnt_find_table_pos(sfont, tag);
+ if (offset == 0)
+ TT_ERROR("sfnt: table not found...");
+
+ sfnt_seek_set(sfont, offset);
+
+ return offset;
+}
+
+int
+sfnt_read_table_directory (sfnt *sfont, ULONG offset)
+{
+ struct sfnt_table_directory *td;
+ unsigned long i, u_tag;
+
+ ASSERT(sfont);
+
+ if (sfont->directory)
+ release_directory(sfont->directory);
+ sfont->directory = td = NEW (1, struct sfnt_table_directory);
+
+#ifdef XETEX
+ ASSERT(sfont->ft_face);
+#elif defined(pdfTeX)
+ ASSERT(sfont->buffer);
+#else
+ ASSERT(sfont->stream);
+#endif
+
+ sfnt_seek_set(sfont, offset);
+
+ td->version = sfnt_get_ulong(sfont);
+ td->num_tables = sfnt_get_ushort(sfont);
+ td->search_range = sfnt_get_ushort(sfont);
+ td->entry_selector = sfnt_get_ushort(sfont);
+ td->range_shift = sfnt_get_ushort(sfont);
+
+ td->flags = NEW(td->num_tables, char);
+ td->tables = NEW(td->num_tables, struct sfnt_table);
+
+ for (i = 0; i < td->num_tables; i++) {
+ u_tag = sfnt_get_ulong(sfont);
+
+ convert_tag(td->tables[i].tag, u_tag);
+ td->tables[i].check_sum = sfnt_get_ulong(sfont);
+ td->tables[i].offset = sfnt_get_ulong(sfont);
+ td->tables[i].length = sfnt_get_ulong(sfont);
+ td->tables[i].data = NULL;
+
+ td->flags[i] = 0;
+ }
+
+ td->num_kept_tables = 0;
+
+ return 0;
+}
+
+int
+sfnt_require_table (sfnt *sfont, const char *tag, int must_exist)
+{
+ struct sfnt_table_directory *td;
+ int idx;
+
+ ASSERT(sfont && sfont->directory);
+
+ td = sfont->directory;
+ idx = find_table_index(td, tag);
+ if (idx < 0) {
+ if (must_exist)
+ return -1;
+ } else {
+ td->flags[idx] |= SFNT_TABLE_REQUIRED;
+ td->num_kept_tables++;
+ }
+
+ return 0;
+}
+
+#ifndef pdfTeX
+#include "pdfobj.h"
+#endif
+
+/*
+ * o All tables begin on four byte boundries, and pad any remaining space
+ * between tables with zeros
+ *
+ * o Entries in the Table Directory must be sorted in ascending order by tag
+ *
+ * o The head table contains checksum of the whole font file.
+ * To compute: first set it to 0, sum the entire font as ULONG,
+ * then store 0xB1B0AFBA - sum.
+ */
+
+#ifdef pdfTeX
+extern pdf_obj *pdf_new_stream(void);
+extern void pdf_add_stream(pdf_obj *, unsigned char *, long);
+extern void pdf_release_obj(pdf_obj *);
+#undef MIN
+#define MIN(a, b) (((a) < (b)) ? (a) : (b))
+#define STREAM_COMPRESS
+#endif
+
+static unsigned char wbuf[1024], padbytes[4] = {0, 0, 0, 0};
+
+pdf_obj *
+sfnt_create_FontFile_stream (sfnt *sfont)
+{
+ pdf_obj *stream;
+#ifndef pdfTeX
+ pdf_obj *stream_dict;
+#endif
+ struct sfnt_table_directory *td;
+ long offset, nb_read, length;
+ int i, sr;
+ char *p;
+
+ ASSERT(sfont && sfont->directory);
+
+ stream = pdf_new_stream(STREAM_COMPRESS);
+
+ td = sfont->directory;
+
+ /* Header */
+ p = (char *) wbuf;
+ p += sfnt_put_ulong (p, td->version);
+ p += sfnt_put_ushort(p, td->num_kept_tables);
+ sr = max2floor(td->num_kept_tables) * 16;
+ p += sfnt_put_ushort(p, sr);
+ p += sfnt_put_ushort(p, log2floor(td->num_kept_tables));
+ p += sfnt_put_ushort(p, td->num_kept_tables * 16 - sr);
+
+ pdf_add_stream(stream, wbuf, 12);
+
+ /*
+ * Compute start of actual tables (after headers).
+ */
+ offset = 12 + 16 * td->num_kept_tables;
+ for (i = 0; i < td->num_tables; i++) {
+ /* This table must exist in FontFile */
+ if (td->flags[i] & SFNT_TABLE_REQUIRED) {
+ if ((offset % 4) != 0) {
+ offset += 4 - (offset % 4);
+ }
+
+ p = (char *) wbuf;
+ memcpy(p, td->tables[i].tag, 4);
+ p += 4;
+ p += sfnt_put_ulong(p, td->tables[i].check_sum);
+ p += sfnt_put_ulong(p, offset);
+ p += sfnt_put_ulong(p, td->tables[i].length);
+ pdf_add_stream(stream, wbuf, 16);
+
+ offset += td->tables[i].length;
+ }
+ }
+
+ offset = 12 + 16 * td->num_kept_tables;
+ for (i = 0; i < td->num_tables; i++) {
+ if (td->flags[i] & SFNT_TABLE_REQUIRED) {
+ if ((offset % 4) != 0) {
+ length = 4 - (offset % 4);
+ pdf_add_stream(stream, padbytes, length);
+ offset += length;
+ }
+ if (!td->tables[i].data) {
+#ifdef XETEX
+ if (!sfont->ft_face)
+#elif defined(pdfTeX)
+ if (!sfont->buffer)
+#else
+ if (!sfont->stream)
+#endif
+ {
+ pdf_release_obj(stream);
+ TT_ERROR("Font file not opened or already closed...");
+ return NULL;
+ }
+
+ length = td->tables[i].length;
+ sfnt_seek_set(sfont, td->tables[i].offset);
+ while (length > 0) {
+ nb_read = sfnt_read(wbuf, MIN(length, 1024), sfont);
+ if (nb_read < 0) {
+ pdf_release_obj(stream);
+ TT_ERROR("Reading file failed...");
+ return NULL;
+ } else if (nb_read > 0) {
+ pdf_add_stream(stream, wbuf, nb_read);
+ }
+ length -= nb_read;
+ }
+ } else {
+ pdf_add_stream(stream,
+ (unsigned char *)td->tables[i].data,
+ td->tables[i].length);
+ RELEASE(td->tables[i].data);
+ td->tables[i].data = NULL;
+ }
+ /* Set offset for next table */
+ offset += td->tables[i].length;
+ }
+ }
+
+#ifndef pdfTeX
+ stream_dict = pdf_stream_dict(stream);
+ pdf_add_dict(stream_dict,
+ pdf_new_name("Length1"),
+ pdf_new_number(offset));
+#endif
+ return stream;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/sfnt.h b/Build/source/texk/web2c/luatexdir/font/sfnt.h
new file mode 100644
index 00000000000..8db54dd9c39
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/sfnt.h
@@ -0,0 +1,197 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/sfnt.h,v 1.9 2004/09/11 14:50:29 hirata Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+#ifndef _SFNT_H_
+#define _SFNT_H_
+
+#if HAVE_CONFIG_H
+#include "config.h"
+#endif /* HAVE_CONFIG_H_ */
+
+#ifndef pdfTeX
+#include "mfileio.h"
+#include "numbers.h"
+#include "pdfobj.h"
+#endif
+
+#ifdef XETEX
+#include "ft2build.h"
+#include FT_FREETYPE_H
+#include FT_TRUETYPE_TABLES_H
+#endif
+
+/* Data Types as described in Apple's TTRefMan */
+typedef unsigned char BYTE;
+typedef signed char ICHAR;
+typedef unsigned short USHORT;
+typedef signed short SHORT;
+typedef unsigned long ULONG;
+typedef signed long LONG;
+typedef unsigned long Fixed; /* 16.16-bit signed fixed-point number */
+typedef short FWord;
+typedef unsigned short uFWord;
+typedef short F2Dot14; /* 16-bit signed fixed number with the low
+ 14 bits representing fraction. */
+
+struct sfnt_table
+{
+ /* table header */
+ char tag[4];
+ ULONG check_sum;
+ ULONG offset;
+ ULONG length;
+ char *data; /* table data */
+};
+
+#define SFNT_TABLE_REQUIRED (1 << 0)
+
+struct sfnt_table_directory
+{
+ ULONG version; /* Fixed for Win */
+ USHORT num_tables;
+ USHORT search_range;
+ USHORT entry_selector;
+ USHORT range_shift;
+ USHORT num_kept_tables; /* number of kept tables */
+ char *flags; /* keep or omit */
+ struct sfnt_table *tables;
+};
+
+/* sfnt resource */
+#define SFNT_TYPE_TRUETYPE (1 << 0)
+#define SFNT_TYPE_OPENTYPE (1 << 1)
+#define SFNT_TYPE_POSTSCRIPT (1 << 2)
+#define SFNT_TYPE_TTC (1 << 4)
+
+typedef struct
+{
+ int type;
+ struct sfnt_table_directory *directory;
+#ifdef XETEX
+ FT_Face ft_face;
+ long loc;
+#elif defined(pdfTeX)
+ BYTE *buffer;
+ long buflen;
+ long loc;
+#else
+ FILE *stream;
+#endif
+} sfnt;
+
+/* Convert sfnt "fixed" type to double */
+#define fixed(a) ((double)((a)%0x10000L)/(double)(0x10000L) + \
+ (a)/0x10000L - (((a)/0x10000L > 0x7fffL) ? 0x10000L : 0))
+
+#ifdef XETEX
+UNSIGNED_BYTE ft_unsigned_byte(sfnt* f);
+SIGNED_BYTE ft_signed_byte(sfnt* f);
+UNSIGNED_PAIR ft_unsigned_pair(sfnt* f);
+SIGNED_PAIR ft_signed_pair(sfnt* f);
+UNSIGNED_QUAD ft_unsigned_quad(sfnt* f);
+unsigned long ft_read(unsigned char* buf, unsigned long len, sfnt* f);
+
+#define sfnt_get_byte(s) ((BYTE) ft_unsigned_byte(s))
+#define sfnt_get_char(s) ((ICHAR) ft_signed_byte (s))
+#define sfnt_get_ushort(s) ((USHORT) ft_unsigned_pair(s))
+#define sfnt_get_short(s) ((SHORT) ft_signed_pair (s))
+#define sfnt_get_ulong(s) ((ULONG) ft_unsigned_quad(s))
+#define sfnt_get_long(s) ((LONG) ft_signed_quad (s))
+
+#define sfnt_seek_set(s,o) (s)->loc = (o)
+#define sfnt_read(b,l,s) ft_read((b), (l), (s))
+#elif defined(pdfTeX)
+BYTE get_unsigned_byte(sfnt* f);
+ICHAR get_signed_byte(sfnt* f);
+USHORT get_unsigned_pair(sfnt* f);
+SHORT get_signed_pair(sfnt* f);
+ULONG get_unsigned_quad(sfnt* f);
+int do_sfnt_read (unsigned char *dest, int len, sfnt *f);
+
+#define sfnt_get_byte(s) ((BYTE) get_unsigned_byte(s))
+#define sfnt_get_char(s) ((ICHAR) get_signed_byte (s))
+#define sfnt_get_ushort(s) ((USHORT) get_unsigned_pair(s))
+#define sfnt_get_short(s) ((SHORT) get_signed_pair (s))
+#define sfnt_get_ulong(s) ((ULONG) get_unsigned_quad(s))
+#define sfnt_get_long(s) ((LONG) get_signed_quad (s))
+
+#define sfnt_seek_set(s,o) (s)->loc = (o)
+#define sfnt_read(b,l,s) do_sfnt_read((b), (l), (s))
+#else
+/* get_***_*** from numbers.h */
+#define sfnt_get_byte(s) ((BYTE) get_unsigned_byte((s)->stream))
+#define sfnt_get_char(s) ((ICHAR) get_signed_byte ((s)->stream))
+#define sfnt_get_ushort(s) ((USHORT) get_unsigned_pair((s)->stream))
+#define sfnt_get_short(s) ((SHORT) get_signed_pair ((s)->stream))
+#define sfnt_get_ulong(s) ((ULONG) get_unsigned_quad((s)->stream))
+#define sfnt_get_long(s) ((LONG) get_signed_quad ((s)->stream))
+
+#define sfnt_seek_set(s,o) seek_absolute((s)->stream, (o))
+#define sfnt_read(b,l,s) fread((b), 1, (l), (s)->stream)
+#endif
+
+extern int put_big_endian (void *s, LONG q, int n);
+
+#define sfnt_put_ushort(s,v) put_big_endian((s), v, 2);
+#define sfnt_put_short(s,v) put_big_endian((s), v, 2);
+#define sfnt_put_ulong(s,v) put_big_endian((s), v, 4);
+#define sfnt_put_long(s,v) put_big_endian((s), v, 4);
+
+#ifdef XETEX
+extern sfnt *sfnt_open (FT_Face face, int accept_types);
+#elif defined(pdfTeX)
+extern sfnt *sfnt_open (unsigned char *buffer, integer buflen);
+#else
+extern sfnt *sfnt_open (FILE *fp);
+#endif
+extern void sfnt_close (sfnt *sfont);
+
+/* table directory */
+extern int sfnt_read_table_directory (sfnt *sfont, ULONG offset);
+extern ULONG sfnt_find_table_len (sfnt *sfont, const char *tag);
+extern ULONG sfnt_find_table_pos (sfnt *sfont, const char *tag);
+extern ULONG sfnt_locate_table (sfnt *sfont, const char *tag);
+
+extern void sfnt_set_table (sfnt *sfont,
+ const char *tag, void *data, ULONG length);
+extern int sfnt_require_table (sfnt *sfont, const char *tag, int must_exist);
+
+#ifdef pdfTeX
+typedef struct
+{
+ ULONG length;
+ BYTE *data;
+} pdf_obj;
+
+#define ASSERT(a) assert(a)
+#define RELEASE(a) free(a)
+#define NEW(a,b) xmalloc((a)*sizeof(b))
+#define RENEW(a,b,c) xrealloc(a, ((b)*sizeof(c)))
+#define TT_ERROR pdftex_fail
+#define WARN printf
+
+
+#endif
+
+extern pdf_obj *sfnt_create_FontFile_stream (sfnt *sfont);
+
+#endif /* _SFNT_H_ */
diff --git a/Build/source/texk/web2c/luatexdir/font/subfont.c b/Build/source/texk/web2c/luatexdir/font/subfont.c
new file mode 100644
index 00000000000..836985c10fd
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/subfont.c
@@ -0,0 +1,264 @@
+/*
+Copyright (c) 2005-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*/
+
+#include "ptexlib.h"
+#include <string.h>
+
+static struct avl_table *sfd_tree = NULL;
+
+static unsigned char *sfd_buffer = NULL;
+static integer sfd_size = 0;
+static integer sfd_curbyte = 0;
+
+#define SFD_BUF_SIZE SMALL_BUF_SIZE
+
+#define sfd_close() xfclose(sfd_file, cur_file_name)
+#define sfd_open() open_input(&sfd_file, kpse_sfd_format, FOPEN_RBIN_MODE)
+
+#define sfd_read_file() readbinfile(sfd_file,&sfd_buffer,&sfd_size)
+#define sfd_getchar() sfd_buffer[sfd_curbyte++]
+#define sfd_eof() (sfd_curbyte>sfd_size)
+
+
+static FILE *sfd_file;
+static char sfd_line[SFD_BUF_SIZE];
+
+static subfont_entry *new_subfont_entry (void)
+{
+ int i;
+ subfont_entry *subfont;
+ subfont = xtalloc (1, subfont_entry);
+ subfont->infix = NULL;
+ for (i = 0; i < 256; ++i)
+ subfont->charcodes[i] = -1; /* unassigned */
+ subfont->next = NULL;
+ return subfont;
+}
+
+static sfd_entry *new_sfd_entry (void)
+{
+ sfd_entry *sfd;
+ sfd = xtalloc (1, sfd_entry);
+ sfd->name = NULL;
+ sfd->subfont = NULL;
+ return sfd;
+}
+
+static void destroy_sfd_entry (void *pa, void *pb)
+{
+ subfont_entry *p, *q;
+ sfd_entry *sfd;
+ sfd = (sfd_entry *) pa;
+ p = sfd->subfont;
+ while (p != NULL) {
+ q = p->next;
+ xfree (p->infix);
+ xfree (p);
+ p = q;
+ }
+ xfree (sfd->name);
+}
+
+static int comp_sfd_entry (const void *pa, const void *pb, void *p)
+{
+ return strcmp (((const sfd_entry *) pa)->name,
+ ((const sfd_entry *) pb)->name);
+}
+
+void sfd_free (void)
+{
+ if (sfd_tree != NULL)
+ avl_destroy (sfd_tree, destroy_sfd_entry);
+}
+
+static void sfd_getline (boolean expect_eof)
+{
+ char *p;
+ int c;
+ restart:
+ if (sfd_eof ()) {
+ if (expect_eof)
+ return;
+ else
+ pdftex_fail ("unexpected end of file");
+ }
+ p = sfd_line;
+ do {
+ c = sfd_getchar ();
+ append_char_to_buf (c, p, sfd_line, SFD_BUF_SIZE);
+ } while (c != 10 && !sfd_eof());
+ append_eol (p, sfd_line, SFD_BUF_SIZE);
+ if (p - sfd_line < 2 || *sfd_line == '#')
+ goto restart;
+}
+
+static sfd_entry *read_sfd (char *sfd_name)
+{
+ void **aa;
+ sfd_entry *sfd, tmp_sfd;
+ subfont_entry *sf;
+ char *ftemp = NULL;
+ char buf[SMALL_BUF_SIZE], *p;
+ long int i, j, k;
+ int n;
+ int callback_id=0;
+ int file_opened=0;
+ /* check whether this sfd has been read */
+ tmp_sfd.name = sfd_name;
+ if (sfd_tree == NULL) {
+ sfd_tree = avl_create (comp_sfd_entry, NULL, &avl_xallocator);
+ assert (sfd_tree != NULL);
+ }
+ sfd = (sfd_entry *) avl_find (sfd_tree, &tmp_sfd);
+ if (sfd != NULL)
+ return sfd;
+ set_cur_file_name (sfd_name);
+ if (sfd_buffer!=NULL) {
+ xfree(sfd_buffer);
+ sfd_buffer=NULL;
+ }
+ sfd_curbyte=0;
+ sfd_size=0;
+
+ callback_id=callback_defined(find_sfd_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",cur_file_name,&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ if (cur_file_name)
+ free(cur_file_name);
+ cur_file_name = xstrdup(ftemp);
+ free(ftemp);
+ }
+ }
+ }
+ callback_id=callback_defined(read_sfd_file_callback);
+ if (callback_id>0) {
+ if(! (run_callback(callback_id,"S->bSd",cur_file_name,
+ &file_opened, &sfd_buffer,&sfd_size) &&
+ file_opened &&
+ sfd_size>0 ) ) {
+ pdftex_warn ("cannot open SFD file for reading");
+ cur_file_name = NULL;
+ return NULL;
+ }
+ sfd_read_file();
+ sfd_close();
+ }
+ tex_printf ("{");
+ tex_printf (cur_file_name);
+ sfd = new_sfd_entry ();
+ sfd->name = xstrdup (sfd_name);
+ while (!sfd_eof ()) {
+ sfd_getline (true);
+ if (*sfd_line == 10) /* empty line indicating eof */
+ break;
+ sf = new_subfont_entry ();
+ sf->next = sfd->subfont;
+ sfd->subfont = sf;
+ sscanf (sfd_line, "%s %n", buf, &n);
+ sf->infix = xstrdup (buf);
+ p = sfd_line + n; /* skip to the next word */
+ k = 0;
+ read_ranges:
+ for (;;) {
+ if (*p == '\\') { /* continue on next line */
+ sfd_getline (false);
+ p = sfd_line;
+ goto read_ranges;
+ } else if (*p == 0) /* end of subfont */
+ break;
+ if (sscanf (p, " %li %n", &i, &n) == 0)
+ pdftex_fail ("invalid token:\n%s", p);
+ p += n;
+ if (*p == ':') { /* offset */
+ k = i;
+ p++;
+ } else if (*p == '_') { /* range */
+ if (sscanf (p + 1, " %li %n", &j, &n) == 0)
+ pdftex_fail ("invalid token:\n%s", p);
+ if (i > j || k + (j - i) > 255)
+ pdftex_fail ("invalid range:\n%s", p);
+ while (i <= j)
+ sf->charcodes[k++] = i++;
+ p += n + 1;
+ } else /* codepoint */
+ sf->charcodes[k++] = i;
+ }
+ }
+ tex_printf ("}");
+ aa = avl_probe (sfd_tree, sfd);
+ assert (aa != NULL);
+ return sfd;
+}
+
+boolean handle_subfont_fm (fm_entry * fm, int mode)
+{
+ size_t l;
+ char *p, *q, *r;
+ sfd_entry *sfd;
+ subfont_entry *sf;
+ fm_entry *fm2;
+ char buf[SMALL_BUF_SIZE];
+ assert (fm->tfm_name != NULL);
+ p = fm->tfm_name;
+ q = strchr (p, '@'); /* search for the first '@' */
+ if (q == NULL)
+ return false;
+ r = strchr (q + 1, '@'); /* search for the second '@' */
+ if (r == NULL)
+ return false;
+ if (q <= p || r <= q + 1 /* prefix or sfd name is empty */
+ || r - p != strlen (p) - 1) /* or the second '@' is not the last char yet */
+ return false;
+ l = r - (q + 1); /* length of sfd name */
+ strncpy (buf, q + 1, l);
+ buf[l] = 0;
+ check_buf(strlen(buf) + 4, SMALL_BUF_SIZE);
+ strcat (buf, ".sfd");
+ sfd = read_sfd (buf);
+ if (sfd == NULL)
+ return false;
+ /* at this point we know fm is a subfont */
+ set_subfont (fm);
+ xfree (fm->ps_name);
+ fm->ps_name = NULL;
+ /* set default values for PidEid */
+ if (fm->pid == -1) {
+ fm->pid = 3;
+ fm->eid = 1;
+ }
+ l = q - p; /* length of base tfm name (prefix) */
+ for (sf = sfd->subfont; sf != NULL; sf = sf->next) {
+ strncpy (buf, p, l);
+ buf[l] = 0;
+ strcat (buf, sf->infix);
+ fm2 = new_fm_entry ();
+ fm2->tfm_name = xstrdup (buf);
+ fm2->ff_name = xstrdup (fm->ff_name);
+ fm2->type = fm->type;
+ fm2->pid = fm->pid;
+ fm2->eid = fm->eid;
+ fm2->subfont = sf;
+ if (avl_do_entry (fm2, mode) != 0) /* try to insert the entry */
+ delete_fm_entry (fm2); /* delete it if failed */
+ }
+ delete_fm_entry (fm);
+ return true;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/subfont.txt b/Build/source/texk/web2c/luatexdir/font/subfont.txt
new file mode 100644
index 00000000000..9fe053cbb9c
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/subfont.txt
@@ -0,0 +1,74 @@
+map entry:
+
+cyberb@Unicode@ <cyberbit.ttf PidEid=3,1
+
+means
+
+cyberb<INFIX> => look at Unicode.sfd => find the mapping => charcode
+ => PidEid=3,1 => glyphs
+
+eg cyberb01 => subfont 01 in Unicode.sfd => charcodes
+
+Infix can be anything, thus the question: given a tfm name, how to find out
+whether this is a subfont?
+
+It is safe to limit the infix to be composed from hexadecimal digits only?
+
+If so, one possibility is:
+
+(1)
+while last-char-of-tfmname is a hexdigit do
+ remove the last char from tfmname
+ do a lookup for the tfmname
+ if found an entry with subfont flag then
+ break
+enddo
+
+(2)
+Or, when a map entry with subfont flag is scanned, let pdftex create all
+the relevant entries. Which may be a safer and faster solution (but wastes more
+memory)
+
+
+Let's do (2), as infix can be any word.
+
+
+
+Implementation:
+
+- let's have a map entry:
+
+cyberb@Unicode@ <cyberbit.ttf PidEid=3,1
+
+- actions:
+ - read Unicode.sfd
+ - create corresponding sfd mapping like ("01", "Unicode") => long[256]
+ - added those subfont to an AVL tree
+ - create map entries for cyberb01--cyberbff, each has a pointer to the
+ corresponding sfd mapping entry
+
+- extended attributes for map entry:
+ - Pid
+ - Eid
+ - sfd_map
+
+- sfd_mapping:
+ - name: sfd name, eg "Unicode"
+ - infix, eg "01"
+ - mapping: long[256]
+
+- how to find out whether a sfd has been loaded:
+ - lookup for any entry with the given sfd name
+
+- functions:
+ - load_sfd
+ - lookup_subfont
+ - extend reading map entries
+
+- when writting ttf:
+ - if re-encoded --> process like in case of type1 fonts
+ - if PidEid is being used:
+ - read cmap tables: store (ttfname, pid, eid)
+ - search for used chars
+ - use sfd to find the charcodes
+ - look into cmap to
diff --git a/Build/source/texk/web2c/luatexdir/font/texfont.c b/Build/source/texk/web2c/luatexdir/font/texfont.c
new file mode 100644
index 00000000000..150c2cba769
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/texfont.c
@@ -0,0 +1,1094 @@
+/*
+ Copyright (c) 1996-2006 Taco Hoekwater <taco@luatex.org>
+
+ This file is part of LuaTeX.
+
+ LuaTeX is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with LuaTeX; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ $Id: texfont.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+/* Main font API implementation for the pascal parts */
+
+/* stuff to watch out for:
+ *
+ * - Knuth had a 'null_character' that was used when a character could
+ * not be found by the fetch() routine, to signal an error. This has
+ * been deleted, but it may mean that the output of luatex is
+ * incompatible with TeX after fetch() has detected an error condition.
+ *
+ * - Knuth also had a font_glue() optimization. I've removed that
+ * because it was a bit of dirty programming and it also was
+ * problematic if 0 != null.
+ */
+
+#include "ptexlib.h"
+#include "luatex-api.h"
+
+#define proper_char_index(c) (c<=font_ec(f) && c>=font_bc(f))
+#define dxfree(a,b) { xfree(a); a = b ; }
+#define do_realloc(a,b,d) a = xrealloc(a,(b)*sizeof(d))
+
+texfont **font_tables = NULL;
+
+static integer font_arr_max = 0;
+static integer font_id_maxval = 0;
+
+static void grow_font_table (integer id) {
+ int j;
+ if (id>=font_arr_max) {
+ font_bytes += (font_arr_max-id+8)*sizeof(texfont *);
+ font_tables = xrealloc(font_tables,(id+8)*sizeof(texfont *));
+ j = 8;
+ while (j--) {
+ font_tables[id+j] = NULL;
+ }
+ font_arr_max = id+8;
+ }
+}
+
+integer
+new_font_id (void) {
+ int i;
+ for (i=0;i<font_arr_max;i++) {
+ if (font_tables[i]==NULL) {
+ break;
+ }
+ }
+ if (i>=font_arr_max)
+ grow_font_table (i);
+ if (i>font_id_maxval)
+ font_id_maxval = i;
+ return i;
+}
+
+integer
+max_font_id (void) {
+ return font_id_maxval;
+}
+
+void
+set_max_font_id (integer i) {
+ font_id_maxval = i;
+}
+
+integer
+new_font (void) {
+ int k;
+ int id;
+ charinfo *ci;
+ id = new_font_id();
+ font_bytes += sizeof(texfont);
+ /* most stuff is zero */
+ font_tables[id] = xcalloc(1,sizeof(texfont));
+ font_tables[id]->_font_name = NULL;
+ font_tables[id]->_font_area = NULL;
+ font_tables[id]->_font_filename = NULL;
+ font_tables[id]->_font_fullname = NULL;
+ font_tables[id]->_font_encodingname = NULL;
+ font_tables[id]->_font_cidregistry = NULL;
+ font_tables[id]->_font_cidordering = NULL;
+ font_tables[id]->_left_boundary = NULL;
+ font_tables[id]->_right_boundary = NULL;
+ font_tables[id]->_param_base = NULL;
+
+ set_font_bc(id, 1); /* ec = 0 */
+ set_hyphen_char(id,'-');
+ set_skew_char(id,-1);
+
+ /* allocate eight values including 0 */
+ set_font_params(id,7);
+ for (k=0;k<=7;k++) {
+ set_font_param(id,k,0);
+ }
+ /* character info zero is reserved for notdef */
+ font_tables[id]->characters = new_sa_tree(1, 0); /* stack size 1, default item value 0 */
+
+ ci = xcalloc(1,sizeof(charinfo));
+ set_charinfo_name(ci,xstrdup(".notdef"));
+ font_tables[id]->charinfo = ci;
+ font_tables[id]->charinfo_cache = NULL;
+
+ return id;
+}
+
+#define Charinfo_count(a) font_tables[a]->charinfo_count
+#define Charinfo_size(a) font_tables[a]->charinfo_size
+#define Characters(a) font_tables[a]->characters
+
+charinfo *
+get_charinfo (internal_font_number f, integer c) {
+ sa_tree_item glyph;
+ charinfo *ci;
+ if (proper_char_index(c)) {
+ glyph = get_sa_item(Characters(f), c);
+ if (!glyph) {
+ /* this could be optimized using controlled growth */
+ font_bytes += sizeof(charinfo);
+ glyph = ++font_tables[f]->charinfo_count;
+ do_realloc(font_tables[f]->charinfo, (glyph+1), charinfo);
+ memset (&(font_tables[f]->charinfo[glyph]),0,sizeof(charinfo));
+ font_tables[f]->charinfo[glyph].ef = 1000; /* init */
+ font_tables[f]->charinfo_size = glyph;
+ set_sa_item(font_tables[f]->characters, c, glyph, 1); /* 1= global */
+ }
+ return &(font_tables[f]->charinfo[glyph]);
+ } else if (c == left_boundarychar) {
+ if (left_boundary(f)==NULL) {
+ ci = xcalloc(1,sizeof(charinfo));
+ font_bytes += sizeof(charinfo);
+ set_left_boundary(f,ci);
+ }
+ return left_boundary(f);
+ } else if (c == right_boundarychar) {
+ if (right_boundary(f)==NULL) {
+ ci = xcalloc(1,sizeof(charinfo));
+ font_bytes += sizeof(charinfo);
+ set_right_boundary(f,ci);
+ }
+ return right_boundary(f);
+ }
+ return &(font_tables[f]->charinfo[0]);
+}
+
+void
+set_charinfo (internal_font_number f, integer c, charinfo *ci) {
+ sa_tree_item glyph;
+ if (proper_char_index(c)) {
+ glyph = get_sa_item(Characters(f), c);
+ if (glyph) {
+ font_tables[f]->charinfo[glyph] = *ci;
+ } else {
+ pdftex_fail("font: %s","character insertion failed");
+ }
+ } else if (c == left_boundarychar) {
+ set_left_boundary(f,ci);
+ } else if (c == right_boundarychar) {
+ set_right_boundary(f,ci);
+ }
+}
+
+
+
+charinfo *
+copy_charinfo (charinfo *ci) {
+ int x;
+ kerninfo *kern;
+ liginfo *lig;
+ real_eight_bits *packet;
+ charinfo *co = NULL;
+ if (ci==NULL)
+ return NULL;
+ co = xmalloc(sizeof(charinfo));
+ memcpy(co,ci,sizeof(charinfo));
+ set_charinfo_used(co,false);
+ co->name = NULL;
+ co->tounicode = NULL;
+ co->packets = NULL;
+ co->ligatures = NULL;
+ co->kerns = NULL;
+ co->extensible = NULL;
+ if (ci->name!=NULL) {
+ co->name = xstrdup(ci->name);
+ }
+ if (ci->tounicode!=NULL) {
+ co->tounicode = xstrdup(ci->tounicode);
+ }
+ /* kerns */
+ if ((kern = get_charinfo_kerns(ci)) != NULL) {
+ x = 0;
+ while (!kern_end(kern[x])) { x++; } x++;
+ co->kerns = xmalloc (x*sizeof(kerninfo));
+ memcpy(co->kerns,ci->kerns,(x*sizeof(kerninfo)));
+ }
+ /* ligs */
+ if ((lig = get_charinfo_ligatures(ci)) != NULL) {
+ x = 0;
+ while (!lig_end(lig[x])) { x++; } x++;
+ co->ligatures = xmalloc (x*sizeof(liginfo));
+ memcpy(co->ligatures,ci->ligatures,(x*sizeof(liginfo)));
+ }
+ /* packets */
+ if ((packet = get_charinfo_packets(ci)) != NULL) {
+ x = vf_packet_bytes(ci);
+ co->packets = xmalloc (x);
+ memcpy(co->packets,ci->packets,x);
+ }
+ if (get_charinfo_tag(ci)==ext_tag) {
+ int top, bot, rep, mid;
+ top = get_charinfo_extensible(ci,EXT_TOP);
+ bot = get_charinfo_extensible(ci,EXT_BOT);
+ mid = get_charinfo_extensible(ci,EXT_MID);
+ rep = get_charinfo_extensible(ci,EXT_REP);
+ set_charinfo_extensible(co,top,bot,mid,rep);
+ }
+ return co;
+}
+
+#if 0
+int
+find_charinfo_id (internal_font_number f, integer c) {
+ register int g=0;
+ if (font_tables[f]->charinfo_cache==NULL) {
+ int i = (font_ec(f)+1)*sizeof(int);
+ font_tables[f]->charinfo_cache = xmalloc(i);
+ memset(font_tables[f]->charinfo_cache,0,i);
+ } else {
+ g = font_tables[f]->charinfo_cache[c];
+ }
+ if (g==0) {
+ g = get_sa_item(font_tables[f]->characters, c);
+ font_tables[f]->charinfo_cache[c] = g;
+ }
+ return g;
+}
+#else
+#define find_charinfo_id(f,c) get_sa_item(font_tables[f]->characters,c)
+#endif
+
+
+charinfo *
+char_info (internal_font_number f, integer c) {
+ if (f>font_id_maxval)
+ return 0;
+ if (proper_char_index(c)) {
+ register int glyph = find_charinfo_id(f,c);
+ return &(font_tables[f]->charinfo[glyph]);
+ } else if (c == left_boundarychar && left_boundary(f)!=NULL) {
+ return left_boundary(f);
+ } else if (c == right_boundarychar && right_boundary(f)!=NULL) {
+ return right_boundary(f);
+ }
+ return &(font_tables[f]->charinfo[0]);
+}
+
+charinfo_short
+char_info_short (internal_font_number f, integer c) {
+ charinfo_short s;
+ charinfo *i;
+ i = char_info(f,c);
+ s.ci_wd = i->width;
+ s.ci_dp = i->depth;
+ s.ci_ht = i->height;
+ return s;
+}
+
+integer
+char_exists (internal_font_number f, integer c) {
+ if (f>font_id_maxval)
+ return 0;
+ if (proper_char_index(c)) {
+ return find_charinfo_id(f,c);
+ } else if ((c == left_boundarychar) && has_left_boundary(f)) {
+ return 1;
+ } else if ((c == right_boundarychar) && has_right_boundary(f)) {
+ return 1;
+ }
+ return 0;
+}
+
+int
+lua_char_exists_callback (internal_font_number f, integer c) {
+ integer callback_id ;
+ lua_State *L = Luas[0];
+ int ret=0;
+ callback_id = callback_defined(char_exists_callback);
+ if (callback_id!=0) {
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2);
+ return 0;
+ }
+ lua_pushnumber(L,f);
+ lua_pushnumber(L,c);
+ if (lua_pcall(L,2,1,0) != 0) { /* two args, 1 result */
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ error();
+ } else {
+ ret = lua_toboolean(L,-1);
+ }
+ }
+ return ret;
+}
+
+
+void set_charinfo_width (charinfo *ci, scaled val) { ci->width = val; }
+void set_charinfo_height (charinfo *ci, scaled val) { ci->height = val; }
+void set_charinfo_depth (charinfo *ci, scaled val) { ci->depth = val; }
+void set_charinfo_italic (charinfo *ci, scaled val) { ci->italic = val; }
+void set_charinfo_tag (charinfo *ci, scaled val) { ci->tag = val; }
+void set_charinfo_remainder (charinfo *ci, scaled val) { ci->remainder = val; }
+void set_charinfo_used (charinfo *ci, scaled val) { ci->used = val; }
+void set_charinfo_index (charinfo *ci, scaled val) { ci->index = val; }
+void set_charinfo_name (charinfo *ci, char *val) { dxfree(ci->name,val); }
+void set_charinfo_tounicode (charinfo *ci, char *val) { dxfree(ci->tounicode,val); }
+void set_charinfo_ligatures (charinfo *ci, liginfo *val) { dxfree(ci->ligatures,val); }
+void set_charinfo_kerns (charinfo *ci, kerninfo *val) { dxfree(ci->kerns,val); }
+void set_charinfo_packets (charinfo *ci, real_eight_bits *val){ dxfree(ci->packets,val); }
+void set_charinfo_ef (charinfo *ci, scaled val) { ci->ef = val; }
+void set_charinfo_lp (charinfo *ci, scaled val) { ci->lp = val; }
+void set_charinfo_rp (charinfo *ci, scaled val) { ci->rp = val; }
+
+
+
+void set_charinfo_extensible (charinfo *ci, int top, int bot, int mid, int rep) {
+ if (top == 0 && bot == 0 && mid == 0 && rep == 0) {
+ if (ci->extensible != NULL) {
+ free(ci->extensible);
+ ci->extensible = NULL;
+ }
+ } else {
+ if (ci->extensible == NULL) {
+ ci->extensible = xmalloc(4*sizeof(integer));
+ }
+ ci->extensible[EXT_TOP] = top;
+ ci->extensible[EXT_BOT] = bot;
+ ci->extensible[EXT_MID] = mid;
+ ci->extensible[EXT_REP] = rep;
+ }
+}
+
+scaled get_charinfo_width (charinfo *ci) { return ci->width; }
+scaled get_charinfo_height (charinfo *ci) { return ci->height; }
+scaled get_charinfo_depth (charinfo *ci) { return ci->depth; }
+scaled get_charinfo_italic (charinfo *ci) { return ci->italic; }
+char get_charinfo_tag (charinfo *ci) { return ci->tag; }
+integer get_charinfo_remainder (charinfo *ci) { return ci->remainder; }
+char get_charinfo_used (charinfo *ci) { return ci->used; }
+integer get_charinfo_index (charinfo *ci) { return ci->index; }
+char *get_charinfo_name (charinfo *ci) { return ci->name; }
+char *get_charinfo_tounicode (charinfo *ci) { return ci->tounicode; }
+liginfo *get_charinfo_ligatures (charinfo *ci) { return ci->ligatures; }
+kerninfo *get_charinfo_kerns (charinfo *ci) { return ci->kerns; }
+real_eight_bits *get_charinfo_packets (charinfo *ci) { return ci->packets; }
+integer get_charinfo_ef (charinfo *ci) { return ci->ef; }
+integer get_charinfo_rp (charinfo *ci) { return ci->rp; }
+integer get_charinfo_lp (charinfo *ci) { return ci->lp; }
+
+integer get_charinfo_extensible (charinfo *ci, int whch) {
+ int w = 0;
+ if (ci->extensible != NULL)
+ w = ci->extensible[whch];
+ return w;
+}
+
+integer ext_top (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ integer w = get_charinfo_extensible(ci,EXT_TOP);
+ /* fprintf(stdout,"top of char 0x%4x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+
+integer ext_bot (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ integer w = get_charinfo_extensible(ci,EXT_BOT);
+ /*fprintf(stdout,"bot of char 0x%4x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+integer ext_mid (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ integer w = get_charinfo_extensible(ci,EXT_MID);
+ /*fprintf(stdout,"mid of char 0x%4x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+integer ext_rep (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ integer w = get_charinfo_extensible(ci,EXT_REP);
+ /*fprintf(stdout,"rep of char 0x%4x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+
+scaled char_width (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ scaled w = get_charinfo_width(ci);
+ /*fprintf(stdout,"width of char 0x%x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+
+scaled char_depth (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ scaled w = get_charinfo_depth(ci);
+ /*fprintf(stdout,"depth of char 0x%x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+
+scaled char_height (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ scaled w = get_charinfo_height(ci);
+ /*fprintf(stdout,"height of char 0x%x in font %s: %i\n",c,font_name(f),w);*/
+ return w;
+}
+
+scaled char_italic (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_italic(ci);
+}
+
+integer char_remainder (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_remainder(ci);
+}
+
+char char_tag (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_tag(ci);
+}
+
+char char_used (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_used(ci);
+}
+
+char *char_name (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_name(ci);
+}
+
+integer char_index (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_index(ci);
+}
+
+liginfo * char_ligatures (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_ligatures(ci);
+}
+
+kerninfo * char_kerns (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_kerns(ci);
+}
+
+real_eight_bits * char_packets (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_packets(ci);
+}
+
+
+void
+set_font_params(internal_font_number f, int b) {
+ int i;
+ i = font_params(f);
+ if (i!=b) {
+ font_bytes += (b-font_params(f))*sizeof(scaled);
+ do_realloc(param_base(f), (b+1), integer);
+ font_params(f) = b;
+ if (b>i) {
+ while (i<b) {
+ i++;
+ set_font_param(f,i,0);
+ }
+ }
+ }
+}
+
+
+integer
+copy_font (integer f) {
+ int i;
+ charinfo *ci , *co;
+ integer k = new_font();
+ memcpy(font_tables[k],font_tables[f],sizeof(texfont));
+
+ set_font_cache_id(k,0);
+ set_font_used(k,0);
+ set_font_touched(k,0);
+
+ font_tables[k]->_font_name = NULL;
+ font_tables[k]->_font_filename = NULL;
+ font_tables[k]->_font_fullname = NULL;
+ font_tables[k]->_font_encodingname = NULL;
+ font_tables[k]->_font_area = NULL;
+ font_tables[k]->_font_cidregistry = NULL;
+ font_tables[k]->_font_cidordering = NULL;
+ font_tables[k]->_left_boundary = NULL;
+ font_tables[k]->_right_boundary = NULL;
+
+ set_font_name(k,xstrdup(font_name(f)));
+ if (font_filename(f)!= NULL)
+ set_font_filename(k,xstrdup(font_filename(f)));
+ if (font_fullname(f)!= NULL)
+ set_font_fullname(k,xstrdup(font_fullname(f)));
+ if (font_encodingname(f)!= NULL)
+ set_font_encodingname(k,xstrdup(font_encodingname(f)));
+ if (font_area(f)!= NULL)
+ set_font_area(k,xstrdup(font_area(f)));
+ if (font_cidregistry(f)!= NULL)
+ set_font_cidregistry(k,xstrdup(font_cidregistry(f)));
+ if (font_cidordering(f)!= NULL)
+ set_font_cidordering(k,xstrdup(font_cidordering(f)));
+
+ i = sizeof(*param_base(f))*font_params(f);
+ font_bytes += i;
+ param_base(k) = xmalloc (i);
+ memcpy(param_base(k),param_base(f), i);
+
+ i = sizeof(charinfo)*(Charinfo_size(f)+1);
+ font_bytes += i;
+ font_tables[k]->charinfo = xmalloc(i);
+ memset(font_tables[k]->charinfo,0,i);
+ for(i=0;i<=Charinfo_size(k);i++) {
+ ci = copy_charinfo(&font_tables[f]->charinfo[i]);
+ font_tables[k]->charinfo[i] = *ci;
+ }
+
+ if (left_boundary(f)!= NULL ) {
+ ci = copy_charinfo(left_boundary(f));
+ set_charinfo(k,left_boundarychar,ci);
+ }
+
+ if (right_boundary(f)!= NULL ) {
+ ci = copy_charinfo(right_boundary(f));
+ set_charinfo(k,right_boundarychar,ci);
+ }
+ return k;
+}
+
+void delete_font (integer f) {
+ int i;
+ charinfo *co;
+ assert(f>0);
+ if (font_tables[f]!=NULL) {
+ set_font_name(f,NULL);
+ set_font_filename(f,NULL);
+ set_font_fullname(f,NULL);
+ set_font_encodingname(f,NULL);
+ set_font_area(f,NULL);
+ set_font_cidregistry(f,NULL);
+ set_font_cidordering(f,NULL);
+ set_left_boundary(f,NULL);
+ set_right_boundary(f,NULL);
+
+ for(i=font_bc(f); i<=font_ec(f); i++) {
+ if (char_exists(f,i)) {
+ co = char_info(f,i);
+ set_charinfo_name(co,NULL);
+ set_charinfo_tounicode(co,NULL);
+ set_charinfo_packets(co,NULL);
+ set_charinfo_ligatures(co,NULL);
+ set_charinfo_kerns(co,NULL);
+ set_charinfo_extensible(co,0,0,0,0);
+ }
+ }
+ /* free .notdef */
+ set_charinfo_name(font_tables[f]->charinfo+0,NULL);
+ free(font_tables[f]->charinfo);
+ destroy_sa_tree(font_tables[f]->characters);
+
+ free(param_base(f));
+ free(font_tables[f]);
+ font_tables[f] = NULL;
+
+ if (font_id_maxval==f) {
+ font_id_maxval--;
+ }
+ }
+}
+
+void
+create_null_font (void) {
+ int i = new_font();
+ assert(i==0);
+ set_font_name(i,xstrdup("nullfont"));
+ set_font_area(i,xstrdup(""));
+ set_font_touched(i,1);
+}
+
+boolean
+is_valid_font (integer id) {
+ int ret=0;
+ if (id>=0 && id<=font_id_maxval && font_tables[id]!=NULL)
+ ret=1;
+ return ret;
+}
+
+/* return 1 == identical */
+boolean
+cmp_font_name (integer id, strnumber t) {
+ char *tid , *tt;
+ if (!is_valid_font(id))
+ return 0;
+ tt = makecstring(t);
+ tid = font_name(id);
+ if (tt == NULL && tid == NULL)
+ return 1;
+ if (tt == NULL || tid == NULL || strcmp(tid,tt)!=0)
+ return 0;
+ return 1;
+}
+
+boolean
+cmp_font_area (integer id, strnumber t) {
+ char *tt = NULL;
+ char *tid = font_area(id);
+ if (t == 0) {
+ if (tid == NULL || strlen(tid)==0)
+ return 1;
+ else
+ return 0;
+ }
+ tt = makecstring(t);
+ if ((tt == NULL || strlen(tt)==0) && (tid == NULL || strlen(tid)==0))
+ return 1;
+ if (tt == NULL || strcmp(tid,tt)!=0)
+ return 0;
+ return 1;
+}
+
+
+static boolean
+same_font_name (integer id, integer t) {
+ int ret = 0;
+ if (font_name(t) == NULL ||
+ font_name(id) == NULL ||
+ strcmp(font_name(t),font_name(id))!=0) {
+ ;
+ } else {
+ ret =1 ;
+ }
+ return ret;
+}
+
+boolean
+font_shareable (internal_font_number f, internal_font_number k) {
+ int ret = 0;
+ if (font_cidregistry(f) == NULL) {
+ if ( hasfmentry ( k )
+ && ( font_map ( k ) == font_map ( f ) )
+ && ( same_font_name ( k , f )
+ ||
+ ( pdf_font_auto_expand (f)
+ && ( pdf_font_blink (f) != 0 ) /* 0 = nullfont */
+ && same_font_name ( k , pdf_font_blink (f) ) ) ) ) {
+ ret = 1;
+ }
+ } else {
+ if ((font_filename(k) != NULL && font_filename(f) != NULL &&
+ strcmp(font_filename(k),font_filename(f)) == 0)
+ ||
+ ( pdf_font_auto_expand (f)
+ && ( pdf_font_blink (f) != 0 ) /* 0 = nullfont */
+ && same_font_name ( k , pdf_font_blink (f) ) ) ) {
+ ret = 1;
+ }
+ }
+ return ret;
+}
+
+integer
+test_no_ligatures (internal_font_number f) {
+ integer c;
+ for (c=font_bc(f);c<=font_ec(f);c++) {
+ if (has_lig(f,c)) /* char_exists(f,c) */
+ return 0;
+ }
+ return 1;
+}
+
+integer
+get_tag_code (internal_font_number f, integer c) {
+ small_number i;
+ if (char_exists(f,c)) {
+ i = char_tag(f,c);
+ if (i==lig_tag) return 1;
+ else if (i==list_tag) return 2;
+ else if (i==ext_tag) return 4;
+ else return 0;
+ }
+ return -1;
+}
+
+integer
+get_lp_code (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_lp(ci);
+}
+
+integer
+get_rp_code (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_rp(ci);
+}
+
+integer
+get_ef_code (internal_font_number f, integer c) {
+ charinfo *ci = char_info(f,c);
+ return get_charinfo_ef(ci);
+}
+
+void
+set_tag_code (internal_font_number f, integer c, integer i) {
+ integer fixedi;
+ charinfo * co;
+ if (char_exists(f,c)) {
+ /* abs(fix_int(i-7,0)) */
+ fixedi = - (i<-7 ? -7 : (i>0 ? 0 : i )) ;
+ co = char_info(f,c);
+ if (fixedi >= 4) {
+ if (char_tag(f,c) == ext_tag)
+ set_charinfo_tag(co,(char_tag(f,c)- ext_tag));
+ fixedi = fixedi - 4;
+ }
+ if (fixedi >= 2) {
+ if (char_tag(f,c) == list_tag)
+ set_charinfo_tag(co,(char_tag(f,c)- list_tag));
+ fixedi = fixedi - 2;
+ };
+ if (fixedi >= 1) {
+ if (has_lig(f,c))
+ set_charinfo_ligatures(co,NULL);
+ if (has_kern(f,c))
+ set_charinfo_kerns(co,NULL);
+ }
+ }
+}
+
+
+void
+set_lp_code(internal_font_number f, integer c, integer i) {
+ charinfo * co;
+ if (char_exists(f,c)) {
+ co = char_info(f,c);
+ set_charinfo_lp(co,i);
+ }
+}
+
+void
+set_rp_code(internal_font_number f, integer c, integer i) {
+ charinfo * co;
+ if (char_exists(f,c)) {
+ co = char_info(f,c);
+ set_charinfo_rp(co,i);
+ }
+}
+
+void
+set_ef_code(internal_font_number f, integer c, integer i) {
+ charinfo * co;
+ if (char_exists(f,c)) {
+ co = char_info(f,c);
+ set_charinfo_ef(co,i);
+ }
+}
+
+void
+set_no_ligatures (internal_font_number f) {
+ integer c;
+ charinfo * co;
+
+ if (font_tables[f]->ligatures_disabled)
+ return;
+
+ co = char_info(f,left_boundarychar);
+ set_charinfo_ligatures(co,NULL);
+ co = char_info(f,right_boundarychar); /* this is weird */
+ set_charinfo_ligatures(co,NULL);
+ for (c=0;c<font_tables[f]->charinfo_count;c++) {
+ co = font_tables[f]->charinfo+c;
+ set_charinfo_ligatures(co,NULL);
+ }
+ font_tables[f]->ligatures_disabled =1;
+}
+
+liginfo
+get_ligature (internal_font_number f, integer lc, integer rc) {
+ liginfo t, u;
+ charinfo * co;
+ t.lig = 0;
+ t.type = 0;
+ t.adj = 0;
+ if (lc == non_boundarychar || rc == non_boundarychar || (!has_lig(f,lc)) )
+ return t;
+ k = 0;
+ co = char_info(f,lc);
+ while (1) {
+ u = charinfo_ligature(co,k);
+ if (lig_end(u))
+ break;
+ if (lig_char(u) == rc) {
+ if (lig_disabled(u)) {
+ return t;
+ } else {
+ return u;
+ }
+ }
+ k++;
+ }
+ return t;
+}
+
+
+scaled
+get_kern(internal_font_number f, integer lc, integer rc)
+{
+ integer k;
+ kerninfo u;
+ charinfo * co;
+ if (lc == non_boundarychar || rc == non_boundarychar || (!has_kern(f,lc)) )
+ return 0;
+ k = 0;
+ co = char_info(f,lc);
+ while (1) {
+ u = charinfo_kern(co,k);
+ if (kern_end(u))
+ break;
+ if (kern_char(u) == rc) {
+ if (kern_disabled(u))
+ return 0;
+ else
+ return kern_kern(u);
+ }
+ k++;
+ }
+ return 0;
+}
+
+
+/* dumping and undumping fonts */
+
+#define dump_string(a) \
+ if (a!=NULL) { \
+ x = strlen(a)+1; \
+ dump_int(x); dump_things(*a, x); \
+ } else { \
+ x = 0; dump_int(x); \
+ }
+
+void
+dump_charinfo (int f , int c) {
+ charinfo *co;
+ int x;
+ liginfo *lig;
+ kerninfo *kern;
+
+ dump_int(c);
+ co = char_info(f,c);
+ set_charinfo_used(co,0);
+ dump_int(get_charinfo_width(co));
+ dump_int(get_charinfo_height(co));
+ dump_int(get_charinfo_depth(co));
+ dump_int(get_charinfo_italic(co));
+ dump_int(get_charinfo_tag(co));
+ dump_int(get_charinfo_ef(co));
+ dump_int(get_charinfo_rp(co));
+ dump_int(get_charinfo_lp(co));
+ dump_int(get_charinfo_remainder(co));
+ dump_int(get_charinfo_used(co));
+ dump_int(get_charinfo_index(co));
+ dump_string(get_charinfo_name(co));
+ dump_string(get_charinfo_tounicode(co));
+
+ /* ligatures */
+ x = 0;
+ if ((lig = get_charinfo_ligatures(co)) != NULL) {
+ while (!lig_end(lig[x])) { x++; }
+ x++;
+ dump_int(x); dump_things(*lig, x);
+ } else {
+ dump_int(x);
+ }
+ /* kerns */
+ x = 0;
+ if ((kern = get_charinfo_kerns(co)) != NULL) {
+ while (!kern_end(kern[x])) { x++; }
+ x++;
+ dump_int(x); dump_things(*kern, x);
+ } else {
+ dump_int(x);
+ }
+ /* packets */
+ x= vf_packet_bytes(co);
+ dump_int(x);
+ if (x>0) {
+ dump_things(*get_charinfo_packets(co), x);
+ }
+
+ if (get_charinfo_tag(co)==ext_tag) {
+ x = get_charinfo_extensible(co,EXT_TOP); dump_int(x);
+ x = get_charinfo_extensible(co,EXT_BOT); dump_int(x);
+ x = get_charinfo_extensible(co,EXT_MID); dump_int(x);
+ x = get_charinfo_extensible(co,EXT_REP); dump_int(x);
+ }
+}
+
+void
+dump_font (int f) {
+ int i,x;
+
+ set_font_used(f,0);
+ font_tables[f]->charinfo_cache = NULL;
+ dump_things(*(font_tables[f]), 1);
+ dump_string(font_name(f));
+ dump_string(font_area(f));
+ dump_string(font_filename(f));
+ dump_string(font_fullname(f));
+ dump_string(font_encodingname(f));
+ dump_string(font_cidregistry(f));
+ dump_string(font_cidordering(f));
+
+ dump_things(*param_base(f),(font_params(f)+1));
+
+ if (has_left_boundary(f)) {
+ dump_int(1); dump_charinfo(f,left_boundarychar);
+ } else {
+ dump_int(0);
+ }
+ if (has_right_boundary(f)) {
+ dump_int(1); dump_charinfo(f,right_boundarychar);
+ } else {
+ dump_int(0);
+ }
+
+ for(i=font_bc(f); i<=font_ec(f); i++) {
+ if (char_exists(f,i)) {
+ dump_charinfo(f,i);
+ }
+ }
+}
+
+int
+undump_charinfo (int f) {
+ charinfo *co;
+ int x,i;
+ char *s = NULL;
+ liginfo *lig = NULL;
+ kerninfo *kern = NULL;
+ real_eight_bits *packet = NULL;
+ int top = 0, bot = 0, mid = 0, rep = 0;
+
+ undump_int(i);
+ co = get_charinfo(f,i);
+ undump_int(x); set_charinfo_width(co,x);
+ undump_int(x); set_charinfo_height(co,x);
+ undump_int(x); set_charinfo_depth(co,x);
+ undump_int(x); set_charinfo_italic(co,x);
+ undump_int(x); set_charinfo_tag(co,x);
+ undump_int(x); set_charinfo_ef(co,x);
+ undump_int(x); set_charinfo_rp(co,x);
+ undump_int(x); set_charinfo_lp(co,x);
+ undump_int(x); set_charinfo_remainder(co,x);
+ undump_int(x); set_charinfo_used(co,x);
+ undump_int(x); set_charinfo_index(co,x);
+
+ /* name */
+ undump_int (x);
+ if (x>0) {
+ font_bytes += x;
+ s = xmalloc(x);
+ undump_things(*s,x);
+ }
+ set_charinfo_name(co,s);
+
+ /* tounicode */
+ undump_int (x);
+ if (x>0) {
+ font_bytes += x;
+ s = xmalloc(x);
+ undump_things(*s,x);
+ }
+ set_charinfo_tounicode(co,s);
+
+ /* ligatures */
+ undump_int (x);
+ if (x>0) {
+ font_bytes += x*sizeof(liginfo);
+ lig = xmalloc(x*sizeof(liginfo));
+ undump_things(*lig,x);
+ }
+ set_charinfo_ligatures(co,lig);
+
+ /* kerns */
+ undump_int (x);
+ if (x>0) {
+ font_bytes += x*sizeof(kerninfo);
+ kern = xmalloc(x*sizeof(kerninfo));
+ undump_things(*kern,x);
+ }
+ set_charinfo_kerns(co,kern);
+
+ /* packets */
+ undump_int (x);
+ if (x>0) {
+ font_bytes += x;
+ packet = xmalloc(x);
+ undump_things(*packet,x);
+ }
+ set_charinfo_packets(co,packet);
+
+ if (get_charinfo_tag(co)==ext_tag) {
+ undump_int(top);
+ undump_int(bot);
+ undump_int(mid);
+ undump_int(rep);
+ set_charinfo_extensible(co,top,bot,mid,rep);
+ }
+ return i;
+}
+
+#define undump_font_string(a) undump_int (x); \
+ if (x>0) { \
+ font_bytes += x; \
+ s = xmalloc(x); undump_things(*s,x); \
+ a(f,s); }
+
+
+void
+undump_font(int f)
+{
+ int x, i;
+ texfont *tt;
+ charinfo *ci;
+ char *s;
+ grow_font_table (f);
+ font_tables[f] = NULL;
+ font_bytes += sizeof(texfont);
+ tt = xmalloc(sizeof(texfont));
+ undump_things(*tt,1);
+ font_tables[f] = tt;
+
+ undump_font_string(set_font_name);
+ undump_font_string(set_font_area);
+ undump_font_string(set_font_filename);
+ undump_font_string(set_font_fullname);
+ undump_font_string(set_font_encodingname);
+ undump_font_string(set_font_cidregistry);
+ undump_font_string(set_font_cidordering);
+
+ i = sizeof(*param_base(f))*(font_params(f)+1);
+ font_bytes += i;
+ param_base(f) = xmalloc (i);
+ undump_things(*param_base(f), (font_params(f)+1));
+
+ font_tables[f]->_left_boundary = NULL;
+ undump_int(x);
+ if (x) { i = undump_charinfo(f); } /* left boundary */
+
+ font_tables[f]->_right_boundary = NULL;
+ undump_int(x);
+ if (x) { i = undump_charinfo(f); } /* right boundary */
+
+
+ font_tables[f]->characters = new_sa_tree(1, 0); /* stack size 1, default item value 0 */
+ ci = xcalloc(1,sizeof(charinfo));
+ set_charinfo_name(ci,xstrdup(".notdef"));
+ font_tables[f]->charinfo = ci;
+
+ i = font_bc(f);
+ while(i<font_ec(f)) {
+ i = undump_charinfo(f);
+ }
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/font/texfont.h b/Build/source/texk/web2c/luatexdir/font/texfont.h
new file mode 100644
index 00000000000..21b79f1e876
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/texfont.h
@@ -0,0 +1,524 @@
+/*
+ Copyright (c) 1996-2006 Taco Hoekwater <taco@luatex.org>
+
+ This file is part of LuaTeX.
+
+ LuaTeX is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with LuaTeX; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ $Id: texfont.h 1117 2008-03-21 15:26:12Z hhenkel $ */
+
+/* Here we have the interface to LuaTeX's font system, as seen from the
+ main pascal program. There is a companion list in luatex.defines to
+ keep web2c happy */
+
+/* this file is read at the end of ptexlib.h, which is called for at
+ the end of luatexcoerce.h, as well as from the C sources
+*/
+
+#ifndef TEXFONT_H
+#define TEXFONT_H 1
+
+#include "luatexdir/managed-sa.h"
+
+#define pointer halfword
+
+typedef struct liginfo {
+ integer adj;
+ integer lig;
+ char type;
+} liginfo;
+
+typedef struct kerninfo {
+ integer adj;
+ scaled sc;
+} kerninfo;
+
+typedef struct charinfo {
+ char *name; /* postscript character name */
+ liginfo *ligatures; /* ligature items */
+ kerninfo *kerns; /* kern items */
+ real_eight_bits *packets; /* virtual commands. */
+ integer *extensible; /* extensible recipe (if any) */
+ unsigned short index; /* CID index */
+ integer remainder; /* spare value for odd items, could be union-ed with extensible */
+ scaled width; /* width */
+ scaled height; /* height */
+ scaled depth; /* depth */
+ scaled italic; /* italic correction */
+ integer ef; /* font expansion factor */
+ integer lp; /* left protruding factor */
+ integer rp; /* right protruding factor */
+ char tag ; /* list / ext taginfo */
+ char used ; /* char is typeset ? */
+ char *tounicode; /* unicode equivalent */
+} charinfo;
+
+
+/* this is for speed reasons, it is called from the web source
+ when more than two of the traditional four char values are needed
+ at the same time. the structure |charinfo_short| is defined in
+ web */
+
+#ifndef luaTeX
+typedef struct charinfo_short {
+ scaled ci_wd; /* width */
+ scaled ci_ht; /* height */
+ scaled ci_dp; /* depth */
+} charinfo_short;
+#endif
+
+
+extern charinfo_short char_info_short (internal_font_number f, integer c);
+
+
+
+typedef struct texfont {
+ integer _font_size ;
+ integer _font_dsize ;
+ char * _font_name ;
+ char * _font_area ;
+ char * _font_filename ;
+ char * _font_fullname ;
+ char * _font_encodingname ;
+ char * _font_cidregistry ;
+ char * _font_cidordering ;
+ integer _font_cidversion ;
+ integer _font_cidsupplement ;
+
+ integer _font_ec ;
+ integer _font_checksum ; /* internal information */
+ char _font_used ; /* internal information */
+ char _font_touched ; /* internal information */
+ integer _font_cache_id ; /* internal information */
+ char _font_encodingbytes ; /* 1 or 2 bytes */
+ integer _font_slant ; /* a slant in ppt */
+ integer _font_extend ; /* an extension in ppt, or 0 */
+ char _font_tounicode ; /* 1 if info is present */
+ fm_entry_ptr _font_map;
+ integer _font_type;
+ integer _font_format;
+ integer _font_embedding;
+ integer _font_bc ;
+ integer _hyphen_char ;
+ integer _skew_char ;
+ integer _font_natural_dir;
+
+ charinfo *_left_boundary;
+ charinfo *_right_boundary;
+
+ integer _font_params;
+ scaled *_param_base;
+
+ sa_tree characters;
+ integer charinfo_count;
+ integer charinfo_size;
+ charinfo *charinfo;
+ int *charinfo_cache;
+ integer ligatures_disabled;
+
+ integer _pdf_font_num; /* maps to a PDF resource ID */
+ scaled _pdf_font_size; /* maps to a PDF font size */
+ internal_font_number _pdf_font_blink; /* link to base font for expanded fonts */
+ internal_font_number _pdf_font_elink; /* link to expanded fonts for base font */
+ integer _pdf_font_expand_ratio; /* expansion ratio of a particular font */
+ internal_font_number _pdf_font_shrink; /* font at limit of shrinking */
+ internal_font_number _pdf_font_stretch; /* font at limit of stretching */
+ integer _pdf_font_step; /* amount of one step of expansion */
+ boolean _pdf_font_auto_expand; /* this font is auto-expanded? */
+ str_number _pdf_font_attr; /* pointer to additional attributes */
+} texfont;
+
+typedef enum {
+ unknown_font_type=0, /* new font (has not been used yet) */
+ virtual_font_type, /* virtual font */
+ real_font_type, /* real font */
+} font_types;
+
+typedef enum {
+ unknown_format=0,
+ type1_format,
+ type3_format,
+ truetype_format,
+ opentype_format,
+} font_formats;
+
+typedef enum {
+ unknown_embedding=0,
+ no_embedding,
+ subset_embedding,
+ full_embedding,
+} font_embedding_option;
+
+extern char *font_type_strings[];
+extern char *font_format_strings[];
+extern char *font_embedding_strings[];
+
+
+#define font_checksum(a) font_tables[a]->_font_checksum
+#define set_font_checksum(a,b) font_checksum(a) = b
+
+#define font_check_0(a) ((font_tables[a]->_font_checksum&0xFF000000)>>24)
+#define font_check_1(a) ((font_tables[a]->_font_checksum&0x00FF0000)>>16)
+#define font_check_2(a) ((font_tables[a]->_font_checksum&0x0000FF00)>>8)
+#define font_check_3(a) (font_tables[a]->_font_checksum&0x000000FF)
+
+#define font_size(a) font_tables[a]->_font_size
+#define set_font_size(a,b) font_size(a) = b
+#define font_dsize(a) font_tables[a]->_font_dsize
+#define set_font_dsize(a,b) font_dsize(a) = b
+
+#define font_name(a) font_tables[a]->_font_name
+#define get_font_name(a) (unsigned char *)font_name(a)
+#define set_font_name(f,b) font_name(f) = b
+#define tex_font_name(a) maketexstring(font_name(a))
+
+boolean cmp_font_name (integer, strnumber);
+
+#define font_area(a) font_tables[a]->_font_area
+#define get_font_area(a) (unsigned char *)font_area(a)
+#define set_font_area(f,b) font_area(f) = b
+#define tex_font_area(a) maketexstring(font_area(a))
+
+boolean cmp_font_area (integer, strnumber);
+
+#define font_reassign(a,b) { if (a!=NULL) free(a); a = b; }
+
+#define font_filename(a) font_tables[a]->_font_filename
+#define set_font_filename(f,b) font_reassign(font_filename(f),b)
+
+#define font_fullname(a) font_tables[a]->_font_fullname
+#define set_font_fullname(f,b) font_reassign(font_fullname(f),b)
+
+#define font_encodingname(a) font_tables[a]->_font_encodingname
+#define set_font_encodingname(f,b) font_reassign(font_encodingname(f),b)
+
+boolean font_shareable(internal_font_number,internal_font_number);
+
+#define cmp_font_filename(a,b) (!(font_filename(a)!=NULL || font_filename(b)!=NULL || \
+ strcmp(font_filename(a),font_filename(b))))
+#define cmp_font_fullname(a,b) (!(font_fullname(a)!=NULL || font_fullname(b)!=NULL || \
+ strcmp(font_fullname(a),font_fullname(b))))
+#define cmp_font_encodingname(a,b) (!(font_encoding(a)!=NULL || font_encodingname(b)!=NULL || \
+ strcmp(font_encodingname(a),font_encodingname(b))))
+
+#define font_bc(a) font_tables[a]->_font_bc
+#define set_font_bc(f,b) font_bc(f) = b
+
+#define font_ec(a) font_tables[a]->_font_ec
+#define set_font_ec(f,b) font_ec(f) = b
+
+#define font_used(a) (font_tables[a]!=NULL && font_tables[a]->_font_used)
+#define set_font_used(a,b) font_tables[a]->_font_used = b
+
+#define font_touched(a) font_tables[a]->_font_touched
+#define set_font_touched(a,b) font_touched(a) = b
+
+#define font_type(a) font_tables[a]->_font_type
+#define set_font_type(a,b) { /* fprintf(stdout,"set font type of %s to %i: %s\n",font_name(a),b,__FILE__); */ \
+ font_type(a) = b; }
+
+#define font_format(a) font_tables[a]->_font_format
+#define font_format_name(a) font_format_strings[font_tables[a]->_font_format]
+#define set_font_format(a,b) font_format(a) = b
+
+#define font_embedding(a) font_tables[a]->_font_embedding
+#define set_font_embedding(a,b) font_embedding(a) = b
+
+#define font_cidversion(a) font_tables[a]->_font_cidversion
+#define set_font_cidversion(a,b) font_cidversion(a) = b
+
+#define font_cidsupplement(a) font_tables[a]->_font_cidsupplement
+#define set_font_cidsupplement(a,b) font_cidsupplement(a) = b
+
+#define font_cidordering(a) font_tables[a]->_font_cidordering
+#define set_font_cidordering(f,b) font_reassign(font_cidordering(f),b)
+
+#define font_cidregistry(a) font_tables[a]->_font_cidregistry
+#define set_font_cidregistry(f,b) font_reassign(font_cidregistry(f),b)
+
+#define font_map(a) font_tables[a]->_font_map
+#define set_font_map(a,b) font_map(a) = b
+
+#define font_cache_id(a) font_tables[a]->_font_cache_id
+#define set_font_cache_id(a,b) font_cache_id(a) = b
+
+#define font_encodingbytes(a) font_tables[a]->_font_encodingbytes
+#define set_font_encodingbytes(a,b) font_encodingbytes(a) = b
+
+#define font_slant(a) font_tables[a]->_font_slant
+#define set_font_slant(a,b) font_slant(a) = b
+
+#define font_extend(a) font_tables[a]->_font_extend
+#define set_font_extend(a,b) font_extend(a) = b
+
+#define font_tounicode(a) font_tables[a]->_font_tounicode
+#define set_font_tounicode(a,b) font_tounicode(a) = b
+
+#define hyphen_char(a) font_tables[a]->_hyphen_char
+#define set_hyphen_char(a,b) hyphen_char(a) = b
+
+#define skew_char(a) font_tables[a]->_skew_char
+#define set_skew_char(a,b) skew_char(a) = b
+
+#define font_natural_dir(a) font_tables[a]->_font_natural_dir
+#define set_font_natural_dir(a,b) font_natural_dir(a) = b
+
+#define pdf_font_size(a) font_tables[a]->_pdf_font_size
+#define set_pdf_font_size(a,b) pdf_font_size(a) = b
+
+#define pdf_font_num(a) font_tables[a]->_pdf_font_num
+#define set_pdf_font_num(a,b) pdf_font_num(a) = b
+
+#define pdf_font_blink(a) font_tables[a]->_pdf_font_blink
+#define set_pdf_font_blink(a,b) pdf_font_blink(a) = b
+
+#define pdf_font_elink(a) font_tables[a]->_pdf_font_elink
+#define set_pdf_font_elink(a,b) pdf_font_elink(a) = b
+
+#define pdf_font_expand_ratio(a) font_tables[a]->_pdf_font_expand_ratio
+#define set_pdf_font_expand_ratio(a,b) pdf_font_expand_ratio(a) = b
+
+#define pdf_font_shrink(a) font_tables[a]->_pdf_font_shrink
+#define set_pdf_font_shrink(a,b) pdf_font_shrink(a) = b
+
+#define pdf_font_stretch(a) font_tables[a]->_pdf_font_stretch
+#define set_pdf_font_stretch(a,b) pdf_font_stretch(a) = b
+
+#define pdf_font_step(a) font_tables[a]->_pdf_font_step
+#define set_pdf_font_step(a,b) pdf_font_step(a) = b
+
+#define pdf_font_auto_expand(a) font_tables[a]->_pdf_font_auto_expand
+#define set_pdf_font_auto_expand(a,b) pdf_font_auto_expand(a) = b
+
+#define pdf_font_attr(a) font_tables[a]->_pdf_font_attr
+#define set_pdf_font_attr(a,b) pdf_font_attr(a) = b
+
+
+#define left_boundarychar -1
+#define right_boundarychar -2
+#define non_boundarychar -3
+
+#define left_boundary(a) font_tables[a]->_left_boundary
+#define has_left_boundary(a) (left_boundary(a)!=NULL)
+#define set_left_boundary(a,b) font_reassign(left_boundary(a),b)
+
+#define right_boundary(a) font_tables[a]->_right_boundary
+#define has_right_boundary(a) (right_boundary(a)!=NULL)
+#define set_right_boundary(a,b) font_reassign(right_boundary(a),b)
+
+#define font_bchar(a) (right_boundary(a)!=NULL ? right_boundarychar : non_boundarychar)
+
+/* font parameters */
+
+#define font_params(a) font_tables[a]->_font_params
+#define param_base(a) font_tables[a]->_param_base
+#define font_param(a,b) font_tables[a]->_param_base[b]
+
+extern void set_font_params(internal_font_number f, int b);
+
+#define set_font_param(f,n,b) \
+ { if (font_params(f)<n) set_font_params(f,n); \
+ font_param(f,n) = b; }
+
+/* Font parameters are sometimes referred to as |slant(f)|, |space(f)|, etc.*/
+
+typedef enum {
+ slant_code = 1,
+ space_code = 2,
+ space_stretch_code = 3,
+ space_shrink_code = 4,
+ x_height_code = 5,
+ quad_code = 6,
+ extra_space_code = 7 } font_parameter_codes ;
+
+#define slant(f) font_param(f,slant_code)
+#define space(f) font_param(f,space_code)
+#define space_stretch(f) font_param(f,space_stretch_code)
+#define space_shrink(f) font_param(f,space_shrink_code)
+#define x_height(f) font_param(f,x_height_code)
+#define quad(f) font_param(f,quad_code)
+#define extra_space(f) font_param(f,extra_space_code)
+
+/* now for characters */
+
+extern charinfo *get_charinfo (internal_font_number f, integer c) ;
+extern integer char_exists (internal_font_number f, integer c);
+extern charinfo *char_info (internal_font_number f, integer c);
+
+
+extern void set_charinfo_width (charinfo *ci, scaled val);
+extern void set_charinfo_height (charinfo *ci, scaled val);
+extern void set_charinfo_depth (charinfo *ci, scaled val);
+extern void set_charinfo_italic (charinfo *ci, scaled val);
+extern void set_charinfo_tag (charinfo *ci, scaled val);
+extern void set_charinfo_remainder (charinfo *ci, scaled val);
+extern void set_charinfo_used (charinfo *ci, scaled val);
+extern void set_charinfo_index (charinfo *ci, scaled val);
+extern void set_charinfo_name (charinfo *ci, char *val) ;
+extern void set_charinfo_tounicode (charinfo *ci, char *val) ;
+extern void set_charinfo_ligatures (charinfo *ci, liginfo *val);
+extern void set_charinfo_kerns (charinfo *ci, kerninfo *val);
+extern void set_charinfo_packets (charinfo *ci, real_eight_bits *val);
+extern void set_charinfo_extensible (charinfo *ci, int a, int b, int c, int d);
+
+#define set_char_used(f,a,b) set_charinfo_used(get_charinfo(f,a),b)
+
+extern scaled get_charinfo_width (charinfo *ci);
+extern scaled get_charinfo_height (charinfo *ci);
+extern scaled get_charinfo_depth (charinfo *ci);
+extern scaled get_charinfo_italic (charinfo *ci);
+extern char get_charinfo_tag (charinfo *ci);
+extern integer get_charinfo_remainder (charinfo *ci);
+extern char get_charinfo_used (charinfo *ci);
+extern integer get_charinfo_index (charinfo *ci);
+extern char * get_charinfo_name (charinfo *ci) ;
+extern char * get_charinfo_tounicode (charinfo *ci) ;
+extern liginfo * get_charinfo_ligatures (charinfo *ci);
+extern kerninfo *get_charinfo_kerns (charinfo *ci);
+extern real_eight_bits *get_charinfo_packets (charinfo *ci);
+extern integer get_charinfo_extensible (charinfo *ci, int which);
+
+extern integer ext_top (internal_font_number f, integer c);
+extern integer ext_bot (internal_font_number f, integer c);
+extern integer ext_rep (internal_font_number f, integer c);
+extern integer ext_mid (internal_font_number f, integer c);
+
+#define set_ligature_item(f,b,c,d) { f.type = b; f.adj = c; f.lig = d; }
+
+#define set_kern_item(f,b,c) { f.adj = b; f.sc = c; }
+
+
+/* character information */
+
+#define non_char 65536 /* a code that can't match a real character */
+#define non_address 0 /* a spurious |bchar_label| */
+
+
+/* character kerns and ligatures */
+
+#define end_kern 0x7FFFFF /* otherchar value meaning "stop" */
+#define ignored_kern 0x800000 /* otherchar value meaning "disabled" */
+
+#define charinfo_kern(b,c) b->kerns[c]
+
+#define kern_char(b) (b).adj
+#define kern_kern(b) (b).sc
+#define kern_end(b) ((b).adj == end_kern)
+#define kern_disabled(b) ((b).adj > end_kern)
+
+/* character ligatures */
+
+#define end_ligature 0x7FFFFF /* otherchar value meaning "stop" */
+#define ignored_ligature 0x800000 /* otherchar value meaning "disabled" */
+
+#define charinfo_ligature(b,c) b->ligatures[c]
+
+#define is_valid_ligature(a) ((a).type!=0)
+#define lig_type(a) ((a).type>>1)
+#define lig_char(a) (a).adj
+#define lig_replacement(a) (a).lig
+#define lig_end(a) (lig_char(a) == end_ligature)
+#define lig_disabled(a) (lig_char(a) > end_ligature)
+
+#define no_tag 0 /* vanilla character */
+#define lig_tag 1 /* character has a ligature/kerning program */
+#define list_tag 2 /* character has a successor in a charlist */
+#define ext_tag 3 /* character is extensible */
+
+extern scaled char_height (internal_font_number f, integer c);
+extern scaled char_width (internal_font_number f, integer c);
+extern scaled char_depth (internal_font_number f, integer c);
+extern scaled char_italic (internal_font_number f, integer c);
+
+extern liginfo * char_ligatures (internal_font_number f, integer c);
+extern kerninfo * char_kerns (internal_font_number f, integer c);
+extern real_eight_bits * char_packets (internal_font_number f, integer c);
+
+#define has_lig(f,b) (char_exists(f,b) &&( char_ligatures(f,b) != NULL))
+#define has_kern(f,b) (char_exists(f,b) && (char_kerns(f,b) != NULL))
+#define has_packet(f,b) (char_exists(f,b) && (char_packets(f,b) != NULL))
+
+extern integer char_remainder (internal_font_number f, integer c);
+extern char char_tag (internal_font_number f, integer c);
+extern char char_used (internal_font_number f, integer c);
+extern char * char_name (internal_font_number f, integer c);
+extern integer char_index (internal_font_number f, integer c);
+
+scaled get_kern(internalfontnumber f, integer lc, integer rc);
+liginfo get_ligature(internalfontnumber f, integer lc, integer rc);
+
+#define EXT_TOP 0
+#define EXT_BOT 1
+#define EXT_MID 2
+#define EXT_REP 3
+
+extern texfont **font_tables;
+
+integer new_font (void) ;
+integer copy_font (integer id) ;
+integer scale_font (integer id, integer atsize) ;
+integer max_font_id (void);
+void set_max_font_id (integer id);
+integer new_font_id (void);
+void create_null_font (void);
+void delete_font(integer id);
+boolean is_valid_font (integer id);
+
+void dump_font (int font_number);
+void undump_font (int font_number);
+
+integer test_no_ligatures (internal_font_number f) ;
+void set_no_ligatures (internal_font_number f) ;
+
+extern integer get_tag_code (internal_font_number f, integer c);
+extern integer get_lp_code (internal_font_number f, integer c);
+extern integer get_rp_code (internal_font_number f, integer c);
+extern integer get_ef_code (internal_font_number f, integer c);
+
+extern void set_tag_code (internal_font_number f, integer c, integer i) ;
+extern void set_lp_code(internal_font_number f, integer c, integer i) ;
+extern void set_rp_code(internal_font_number f, integer c, integer i) ;
+extern void set_ef_code(internal_font_number f, integer c, integer i) ;
+
+int read_tfm_info(internal_font_number f, char *nom, char *aire, scaled s);
+
+
+/* from dofont.c */
+
+extern int read_font_info (pointer u, strnumber nom, strnumber aire, scaled s, integer ndir);
+extern int find_font_id (char *nom, char *aire, scaled s);
+
+/* for and from vfpacket.c */
+
+#define scan_special 3 /* look into special text */ /* this is a hack */
+
+typedef enum { packet_char_code,
+ packet_font_code,
+ packet_pop_code,
+ packet_push_code,
+ packet_special_code,
+ packet_right_code,
+ packet_down_code,
+ packet_rule_code,
+ packet_node_code,
+ packet_nop_code,
+ packet_end_code } packet_command_codes;
+
+extern scaled sqxfw (scaled sq, integer fw);
+
+extern void do_vf_packet (internal_font_number vf_f, integer c);
+extern int vf_packet_bytes (charinfo *co);
+
+#endif
diff --git a/Build/source/texk/web2c/luatexdir/font/tfmofm.c b/Build/source/texk/web2c/luatexdir/font/tfmofm.c
new file mode 100644
index 00000000000..db82f94deba
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/tfmofm.c
@@ -0,0 +1,1005 @@
+/*
+Copyright (c) 1996-2006 Taco Hoekwater <taco@luatex.org>
+
+This file is part of LuaTeX.
+
+LuaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+LuaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with LuaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: tfmofm.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+
+#include "luatex-api.h"
+
+/* Here are some macros that help process ligatures and kerns */
+
+#define lig_kern_start(f,c) char_remainder(f,c)
+#define stop_flag 128 /* value indicating `\.{STOP}' in a lig/kern program */
+#define kern_flag 128 /* op code for a kern step */
+
+#define skip_byte(z) lig_kerns[z].b0
+#define next_char(z) lig_kerns[z].b1
+#define op_byte(z) lig_kerns[z].b2
+#define rem_byte(z) lig_kerns[z].b3
+#define lig_kern_restart(c) (256*op_byte(c)+rem_byte(c))
+
+/*
+
+The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
+Since the number of bytes is always a multiple of 4, we could
+also regard the file as a sequence of 32-bit words, but \TeX\ uses the
+byte interpretation. The format of \.{TFM} files was designed by
+Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
+@^Ramshaw, Lyle Harold@>
+of information in a compact but useful form.
+
+$\Omega$ is capable of reading not only \.{TFM} files, but also
+\.{OFM} files, which can describe fonts with up to 65536 characters
+and with huge lig/kern tables. These fonts will often be virtual
+fonts built up from real fonts with 256 characters, but $\Omega$
+is not aware of this.
+
+The documentation below describes \.{TFM} files, with slight additions
+to show where \.{OFM} files differ.
+ */
+/*
+@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
+integers that give the lengths of the various subsequent portions
+of the file. These twelve integers are, in order:
+$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
+|lf|&length of the entire file, in words;\cr
+|lh|&length of the header data, in words;\cr
+|bc|&smallest character code in the font;\cr
+|ec|&largest character code in the font;\cr
+|nw|&number of words in the width table;\cr
+|nh|&number of words in the height table;\cr
+|nd|&number of words in the depth table;\cr
+|ni|&number of words in the italic correction table;\cr
+|nl|&number of words in the lig/kern table;\cr
+|nk|&number of words in the kern table;\cr
+|ne|&number of words in the extensible character table;\cr
+|np|&number of font parameter words.\cr}}$$
+They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
+and
+$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
+Note that a \.{TFM} font may contain as many as 256 characters
+(if |bc=0| and |ec=255|), and as few as 0 characters (if |bc=ec+1|).
+
+Incidentally, when two or more 8-bit bytes are combined to form an integer of
+16 or more bits, the most significant bytes appear first in the file.
+This is called BigEndian order.
+@!@^BigEndian order@>
+
+The first 52 bytes (13 words) of an \.{OFM} file contains thirteen
+32-bit integers that give the lengths of the various subsequent
+portions of the file. The first word is 0 (future versions of
+\.{OFM} files could have different values; what is important is that
+the first two bytes be 0 to differentiate \.{TFM} and \.{OFM} files).
+The next twelve integers are as above, all nonegative and less
+than~$2^{31}$. We must have |bc-1<=ec<=65535|, and
+$$\hbox{|lf=13+lh+2*(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
+Note that an \.{OFM} font may contain as many as 65536 characters
+(if |bc=0| and |ec=65535|), and as few as 0 characters (if |bc=ec+1|).
+
+@ The rest of the \.{TFM} file may be regarded as a sequence of ten data
+arrays having the informal specification
+$$\def\arr$[#1]#2${\&{array} $[#1]$ \&{of} #2}
+\vbox{\halign{\hfil\\{#}&$\,:\,$\arr#\hfil\cr
+header&|[0..lh-1]@t\\{stuff}@>|\cr
+char\_info&|[bc..ec]char_info_word|\cr
+width&|[0..nw-1]fix_word|\cr
+height&|[0..nh-1]fix_word|\cr
+depth&|[0..nd-1]fix_word|\cr
+italic&|[0..ni-1]fix_word|\cr
+lig\_kern&|[0..nl-1]lig_kern_command|\cr
+kern&|[0..nk-1]fix_word|\cr
+exten&|[0..ne-1]extensible_recipe|\cr
+param&|[1..np]fix_word|\cr}}$$
+The most important data type used here is a |@!fix_word|, which is
+a 32-bit representation of a binary fraction. A |fix_word| is a signed
+quantity, with the two's complement of the entire word used to represent
+negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
+binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
+the smallest is $-2048$. We will see below, however, that all but two of
+the |fix_word| values must lie between $-16$ and $+16$.
+
+@ The first data array is a block of header information, which contains
+general facts about the font. The header must contain at least two words,
+|header[0]| and |header[1]|, whose meaning is explained below.
+Additional header information of use to other software routines might
+also be included, but \TeX82 does not need to know about such details.
+For example, 16 more words of header information are in use at the Xerox
+Palo Alto Research Center; the first ten specify the character coding
+scheme used (e.g., `\.{XEROX text}' or `\.{TeX math symbols}'), the next five
+give the font identifier (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
+last gives the ``face byte.'' The program that converts \.{DVI} files
+to Xerox printing format gets this information by looking at the \.{TFM}
+file, which it needs to read anyway because of other information that
+is not explicitly repeated in \.{DVI}~format.
+
+\yskip\hang|header[0]| is a 32-bit check sum that \TeX\ will copy into
+the \.{DVI} output file. Later on when the \.{DVI} file is printed,
+possibly on another computer, the actual font that gets used is supposed
+to have a check sum that agrees with the one in the \.{TFM} file used by
+\TeX. In this way, users will be warned about potential incompatibilities.
+(However, if the check sum is zero in either the font file or the \.{TFM}
+file, no check is made.) The actual relation between this check sum and
+the rest of the \.{TFM} file is not important; the check sum is simply an
+identification number with the property that incompatible fonts almost
+always have distinct check sums.
+@^check sum@>
+
+\yskip\hang|header[1]| is a |fix_word| containing the design size of
+the font, in units of \TeX\ points. This number must be at least 1.0; it is
+fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
+font, i.e., a font that was designed to look best at a 10-point size,
+whatever that really means. When a \TeX\ user asks for a font
+`\.{at} $\delta$ \.{pt}', the effect is to override the design size
+and replace it by $\delta$, and to multiply the $x$ and~$y$ coordinates
+of the points in the font image by a factor of $\delta$ divided by the
+design size. {\sl All other dimensions in the\/ \.{TFM} file are
+|fix_word|\kern-1pt\ numbers in design-size units}, with the exception of
+|param[1]| (which denotes the slant ratio). Thus, for example, the value
+of |param[6]|, which defines the \.{em} unit, is often the |fix_word| value
+$2^{20}=1.0$, since many fonts have a design size equal to one em.
+The other dimensions must be less than 16 design-size units in absolute
+value; thus, |header[1]| and |param[1]| are the only |fix_word|
+entries in the whole \.{TFM} file whose first byte might be something
+besides 0 or 255.
+
+@ Next comes the |char_info| array, which contains one |@!char_info_word|
+per character. Each word in this part of a \.{TFM} file contains six fields
+packed into four bytes as follows.
+
+\yskip\hang first byte: |@!width_index| (8 bits)\par
+\hang second byte: |@!height_index| (4 bits) times 16, plus |@!depth_index|
+ (4~bits)\par
+\hang third byte: |@!italic_index| (6 bits) times 4, plus |@!tag|
+ (2~bits)\par
+\hang fourth byte: |@!remainder| (8 bits)\par
+\yskip\noindent
+The actual width of a character is \\{width}|[width_index]|, in design-size
+units; this is a device for compressing information, since many characters
+have the same width. Since it is quite common for many characters
+to have the same height, depth, or italic correction, the \.{TFM} format
+imposes a limit of 16 different heights, 16 different depths, and
+64 different italic corrections.
+
+For \.{OFM} files, two words (eight bytes) are used.
+The arrangement is as follows.
+
+\yskip\hang first and second bytes: |@!width_index| (16 bits)\par
+\hang third byte: |@!height_index| (8 bits)\par
+\hang fourth byte: |@!depth_index| (8~bits)\par
+\hang fifth and sixth bytes:
+|@!italic_index| (14 bits) times 4, plus |@!tag| (2~bits)\par
+\hang seventh and eighth bytes: |@!remainder| (16 bits)\par
+\yskip\noindent
+Therefore the \.{OFM} format imposes a limit of 256 different heights,
+256 different depths, and 16384 different italic corrections.
+
+@!@^italic correction@>
+The italic correction of a character has two different uses.
+(a)~In ordinary text, the italic correction is added to the width only if
+the \TeX\ user specifies `\.{\\/}' after the character.
+(b)~In math formulas, the italic correction is always added to the width,
+except with respect to the positioning of subscripts.
+
+Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
+\\{italic}[0]=0$ should always hold, so that an index of zero implies a
+value of zero. The |width_index| should never be zero unless the
+character does not exist in the font, since a character is valid if and
+only if it lies between |bc| and |ec| and has a nonzero |width_index|.
+*/
+
+ /*
+@ \TeX\ checks the information of a \.{TFM} file for validity as the
+file is being read in, so that no further checks will be needed when
+typesetting is going on. The somewhat tedious subroutine that does this
+is called |read_font_info|. It has four parameters: the user font
+identifier~|u|, the file name and area strings |nom| and |aire|, and the
+``at'' size~|s|. If |s|~is negative, it's the negative of a scale factor
+to be applied to the design size; |s=-1000| is the normal case.
+Otherwise |s| will be substituted for the design size; in this
+case, |s| must be positive and less than $2048\rm\,pt$
+(i.e., it must be less than $2^{27}$ when considered as an integer).
+
+The subroutine opens and closes a global file variable called |tfm_file|.
+It returns the value of the internal font number that was just loaded.
+If an error is detected, an error message is issued and no font
+information is stored; |null_font| is returned in this case.
+
+@d bad_tfm=11 {label for |read_font_info|}
+@d abort==goto bad_tfm {do this when the \.{TFM} data is wrong}
+
+*/
+
+/*
+The |tag| field in a |char_info_word| has four values that explain how to
+interpret the |remainder| field.
+
+\yskip\hangg|tag=0| (|no_tag|) means that |remainder| is unused.\par
+\hangg|tag=1| (|lig_tag|) means that this character has a ligature/kerning
+program starting at position |remainder| in the |lig_kern| array.\par
+\hangg|tag=2| (|list_tag|) means that this character is part of a chain of
+characters of ascending sizes, and not the largest in the chain. The
+|remainder| field gives the character code of the next larger character.\par
+\hangg|tag=3| (|ext_tag|) means that this character code represents an
+extensible character, i.e., a character that is built up of smaller pieces
+so that it can be made arbitrarily large. The pieces are specified in
+|@!exten[remainder]|.\par
+\yskip\noindent
+Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
+unless they are used in special circumstances in math formulas. For example,
+the \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
+operation looks for both |list_tag| and |ext_tag|.
+*/
+
+/* The |lig_kern| array contains instructions in a simple programming language
+that explains what to do for special letter pairs. Each word in this array,
+in a \.{TFM} file, is a |@!lig_kern_command| of four bytes.
+
+\yskip\hang first byte: |skip_byte|, indicates that this is the final program
+ step if the byte is 128 or more, otherwise the next step is obtained by
+ skipping this number of intervening steps.\par
+\hang second byte: |next_char|, ``if |next_char| follows the current character,
+ then perform the operation and stop, otherwise continue.''\par
+\hang third byte: |op_byte|, indicates a ligature step if less than~128,
+ a kern step otherwise.\par
+\hang fourth byte: |remainder|.\par
+\yskip\noindent
+In an \.{OFM} file, eight bytes are used, two bytes for each field.
+
+In a kern step, an
+additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
+between the current character and |next_char|. This amount is
+often negative, so that the characters are brought closer together
+by kerning; but it might be positive.
+
+There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
+$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
+|remainder| is inserted between the current character and |next_char|;
+then the current character is deleted if $b=0$, and |next_char| is
+deleted if $c=0$; then we pass over $a$~characters to reach the next
+current character (which may have a ligature/kerning program of its own).
+
+If the very first instruction of the |lig_kern| array has |skip_byte=255|,
+the |next_char| byte is the so-called right boundary character of this font;
+the value of |next_char| need not lie between |bc| and~|ec|.
+If the very last instruction of the |lig_kern| array has |skip_byte=255|,
+there is a special ligature/kerning program for a left boundary character,
+beginning at location |256*op_byte+remainder|.
+The interpretation is that \TeX\ puts implicit boundary characters
+before and after each consecutive string of characters from the same font.
+These implicit characters do not appear in the output, but they can affect
+ligatures and kerning.
+
+If the very first instruction of a character's |lig_kern| program has
+|skip_byte>128|, the program actually begins in location
+|256*op_byte+remainder|. This feature allows access to large |lig_kern|
+arrays, because the first instruction must otherwise
+appear in a location |<=255| in a \.{TFM} file, |<=65535| in an \.{OFM} file.
+
+Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
+the condition
+$$\hbox{|256*op_byte+remainder<nl|.}$$
+If such an instruction is encountered during
+normal program execution, it denotes an unconditional halt; no ligature
+or kerning command is performed.
+*/
+
+/*
+ Extensible characters are specified by an |@!extensible_recipe|, which
+consists of four bytes in a \.{TFM} file,
+called |@!top|, |@!mid|, |@!bot|, and |@!rep| (in this order).
+In an \.{OFM} file, each field takes two bytes, for eight in total.
+These bytes are the character codes of individual pieces used to
+build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
+present in the built-up result. For example, an extensible vertical line is
+like an extensible bracket, except that the top and bottom pieces are missing.
+
+Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
+if the piece isn't present. Then the extensible characters have the form
+$TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
+in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
+The width of the extensible character is the width of $R$; and the
+height-plus-depth is the sum of the individual height-plus-depths of the
+components used, since the pieces are butted together in a vertical list.
+*/
+
+/*
+The final portion of a \.{TFM} file is the |param| array, which is another
+sequence of |fix_word| values.
+
+\yskip\hang|param[1]=slant| is the amount of italic slant, which is used
+to help position accents. For example, |slant=.25| means that when you go
+up one unit, you also go .25 units to the right. The |slant| is a pure
+number; it's the only |fix_word| other than the design size itself that is
+not scaled by the design size.
+
+\hang|param[2]=space| is the normal spacing between words in text.
+Note that character |" "| in the font need not have anything to do with
+blank spaces.
+
+\hang|param[3]=space_stretch| is the amount of glue stretching between words.
+
+\hang|param[4]=space_shrink| is the amount of glue shrinking between words.
+
+\hang|param[5]=x_height| is the size of one ex in the font; it is also
+the height of letters for which accents don't have to be raised or lowered.
+
+\hang|param[6]=quad| is the size of one em in the font.
+
+\hang|param[7]=extra_space| is the amount added to |param[2]| at the
+ends of sentences.
+
+\yskip\noindent
+If fewer than seven parameters are present, \TeX\ sets the missing parameters
+to zero. Fonts used for math symbols are required to have
+additional parameter information, which is explained later.
+*/
+
+/*
+ There are programs called \.{TFtoPL} and \.{PLtoTF} that convert
+ between the \.{TFM} format and a symbolic property-list format
+ that can be easily edited. These programs contain extensive
+ diagnostic information, so \TeX\ does not have to bother giving
+ precise details about why it rejects a particular \.{TFM} file.
+
+*/
+
+#define tfm_abort { font_tables[f]->_font_name = NULL; \
+ font_tables[f]->_font_area = NULL; \
+ xfree(tfm_buffer); xfree(kerns); \
+ xfree(widths); xfree(heights); xfree(depths); \
+ xfree(italics); xfree(extens); xfree(lig_kerns); \
+ xfree(xligs); xfree(xkerns); \
+ return 0; }
+
+#define tfm_success { xfree(tfm_buffer); xfree(kerns); \
+ xfree(widths); xfree(heights); xfree(depths); \
+ xfree(italics); xfree(extens); xfree(lig_kerns); \
+ xfree(xligs); xfree(xkerns); return 1; }
+
+
+int
+open_tfm_file(char *nom, char *aire, unsigned char **tfm_buf, integer *tfm_siz) {
+ boolean res; /* was the callback successful? */
+ boolean opened; /* was |tfm_file| successfully opened?*/
+ integer callback_id;
+ FILE *tfm_file;
+ /* packfilename(nom,aire,getnullstr()); */
+ if(nameoffile != NULL)
+ xfree(nameoffile);
+ nameoffile = malloc(strlen(nom)+2);
+ strcpy(stringcast(nameoffile+1),nom);
+ namelength = strlen(nom);
+ callback_id=callback_defined(read_font_file_callback);
+ if (callback_id>0) {
+ res = run_callback(callback_id,"S->bSd",stringcast(nameoffile+1),
+ &opened, tfm_buf, tfm_siz);
+ if (res && opened && (*tfm_siz>0)) {
+ return 1;
+ }
+ if (!opened)
+ return -1;
+ } else {
+ if (ofm_open_in(tfm_file)) {
+ res = read_tfm_file(tfm_file,tfm_buf,tfm_siz);
+ b_close(tfm_file);
+ if (res) {
+ return 1;
+ }
+ } else {
+ return -1;
+ }
+ }
+ return 0;
+}
+
+
+/*
+ Note: A malformed \.{TFM} file might be shorter than it claims to be;
+ thus |eof(tfm_file)| might be true when |read_font_info| refers to
+ |tfm_file^| or when it says |get(tfm_file)|. If such circumstances
+ cause system error messages, you will have to defeat them somehow,
+ for example by defining |fget| to be `\ignorespaces|begin get(tfm_file);|
+ |if eof(tfm_file) then abort; end|\unskip'.
+ @^system dependencies@>
+*/
+
+#define fget tfm_byte++
+#define fbyte tfm_buffer[tfm_byte]
+
+#define read_sixteen(a) \
+ { a=tfm_buffer[tfm_byte++]; \
+ if (a>127) { tfm_abort; } \
+ a=(a*256)+tfm_buffer[tfm_byte]; }
+
+#define read_sixteen_unsigned(a) \
+ { a=tfm_buffer[tfm_byte++]; \
+ a=(a*256)+tfm_buffer[tfm_byte]; }
+
+#define read_thirtytwo(a) \
+ { a=tfm_buffer[++tfm_byte]; \
+ if (a>127) { tfm_abort; } \
+ a=(a*256)+tfm_buffer[++tfm_byte]; \
+ a=(a*256)+tfm_buffer[++tfm_byte]; \
+ a=(a*256)+tfm_buffer[++tfm_byte]; }
+
+#define store_four_bytes(z) \
+ { a=tfm_buffer[++tfm_byte]; \
+ a=(a*256)+tfm_buffer[++tfm_byte]; \
+ a=(a*256)+tfm_buffer[++tfm_byte]; \
+ a=(a*256)+tfm_buffer[++tfm_byte]; \
+ z = a; }
+
+#define store_char_info(z) \
+ { if (font_level!=-1) { \
+ fget; read_sixteen_unsigned(a); \
+ ci._width_index=a; \
+ fget; read_sixteen_unsigned(b); \
+ ci._height_index=b>>8; \
+ ci._depth_index=b%256; \
+ fget; read_sixteen_unsigned(c); \
+ ci._italic_index=c>>8; \
+ ci._tag=c%4; \
+ fget; read_sixteen_unsigned(d); \
+ ci._remainder=d; \
+ } else { \
+ a=tfm_buffer[++tfm_byte]; \
+ ci._width_index=a; \
+ b=tfm_buffer[++tfm_byte]; \
+ ci._height_index=b>>4; \
+ ci._depth_index=b%16; \
+ c=tfm_buffer[++tfm_byte]; \
+ ci._italic_index=c>>2; \
+ ci._tag=c%4; \
+ d=tfm_buffer[++tfm_byte]; \
+ ci._remainder=d; \
+ } }
+
+#define read_four_quarters(q) \
+ { if (font_level!=-1) { \
+ fget; read_sixteen_unsigned(a); q.b0=a; \
+ fget; read_sixteen_unsigned(b); q.b1=b; \
+ fget; read_sixteen_unsigned(c); q.b2=c; \
+ fget; read_sixteen_unsigned(d); q.b3=d; \
+ } else { \
+ a=tfm_buffer[++tfm_byte]; q.b0=a; \
+ b=tfm_buffer[++tfm_byte]; q.b1=b; \
+ c=tfm_buffer[++tfm_byte]; q.b2=c; \
+ d=tfm_buffer[++tfm_byte]; q.b3=d; \
+ } }
+
+#define check_byte_range(z) { if ((z<bc)||(z>ec)) tfm_abort ; }
+
+
+/* A |fix_word| whose four bytes are $(a,b,c,d)$ from left to right represents
+ the number
+ $$x=\left\{\vcenter{\halign{$#$,\hfil\qquad&if $#$\hfil\cr
+ b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=0;\cr
+ -16+b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=255.\cr}}\right.$$
+ (No other choices of |a| are allowed, since the magnitude of a number in
+ design-size units must be less than 16.) We want to multiply this
+ quantity by the integer~|z|, which is known to be less than $2^{27}$.
+ If $|z|<2^{23}$, the individual multiplications $b\cdot z$,
+ $c\cdot z$, $d\cdot z$ cannot overflow; otherwise we will divide |z| by 2,
+ 4, 8, or 16, to obtain a multiplier less than $2^{23}$, and we can
+ compensate for this later. If |z| has thereby been replaced by
+ $|z|^\prime=|z|/2^e$, let $\beta=2^{4-e}$; we shall compute
+ $$\lfloor(b+c\cdot2^{-8}+d\cdot2^{-16})\,z^\prime/\beta\rfloor$$
+ if $a=0$, or the same quantity minus $\alpha=2^{4+e}z^\prime$ if $a=255$.
+ This calculation must be done exactly, in order to guarantee portability
+ of \TeX\ between computers.
+*/
+
+#define store_scaled(zz) \
+ { fget; a=fbyte; fget; b=fbyte; \
+ fget; c=fbyte; fget; d=fbyte; \
+ sw=(((((d*z)>>8)+(c*z))>>8)+(b*z)) / beta; \
+ if (a==0) { zz=sw; } else if (a==255) { zz=sw-alpha; } else tfm_abort; \
+ }
+
+#define check_existence(z) \
+ { check_byte_range(z); \
+ if (!char_exists(f,z)) tfm_abort; \
+ }
+
+typedef struct tfmcharacterinfo {
+ integer _kern_index;
+ integer _lig_index;
+ integer _width_index;
+ integer _height_index;
+ integer _depth_index;
+ integer _italic_index;
+ integer _remainder;
+ unsigned char _tag ;
+} tfmcharacterinfo;
+
+extern charinfo *copy_charinfo(charinfo *ci);
+
+int
+read_tfm_info(internalfontnumber f, char *cnom, char *caire, scaled s) {
+ integer k; /* index into |font_info| */
+ halfword lf,lh,bc,ec,nw,nh,nd,ni,nl,nk,ne,np,slh; /* sizes of subfiles */
+ scaled *widths, *heights, *depths, *italics, *kerns;
+ halfword font_dir;
+ integer a,b,c,d; /* byte variables */
+ integer i; /* counter */
+ integer font_level,header_length;
+ integer nco,ncw,npc,nlw,neew;
+ tfmcharacterinfo ci;
+ charinfo *co;
+ four_quarters qw;
+ four_quarters *lig_kerns, *extens;
+ scaled sw; /* accumulators */
+ integer bch_label; /* left boundary start location, or infinity */
+ int bchar; /* :0..too_big_char; */ /* right boundary character, or |too_big_char| */
+ integer first_two;
+ scaled z; /* the design size or the ``at'' size */
+ integer alpha;
+ char beta; /* :1..16*/
+ integer *xligs, *xkerns; /* aux. for ligkern processing */
+ liginfo *cligs;
+ kerninfo *ckerns;
+ int fligs, fkerns;
+ char *tmpnam;
+ integer tfm_byte = 0; /* index into |tfm_buffer| */
+ integer saved_tfm_byte = 0; /* saved index into |tfm_buffer| */
+ unsigned char *tfm_buffer = NULL; /* byte buffer for tfm files */
+ integer tfm_size = 0; /* total size of the tfm file */
+
+ widths=NULL;
+ heights=NULL;
+ depths = NULL;
+ italics = NULL;
+ kerns = NULL;
+ lig_kerns = NULL;
+ extens = NULL;
+ xkerns = NULL;
+ ckerns = NULL;
+ xligs = NULL;
+ cligs = NULL;
+
+ font_dir = 0;
+
+ memset(&ci,0,sizeof(tfmcharacterinfo));
+
+ if(open_tfm_file(cnom,caire,&tfm_buffer,&tfm_size)!=1)
+ tfm_abort;
+
+ /* cnom can be an absolute filename, xbasename() fixes that. */
+
+ tmpnam=strdup(xbasename(cnom));
+ if (strcmp(tmpnam+strlen(tmpnam)-4,".tfm")==0) {
+ *(tmpnam+strlen(tmpnam)-4) =0;
+ }
+ set_font_name(f,tmpnam);
+ set_font_area(f,xstrdup(caire)); /* perhaps it leaks, but it doesnt crash */
+
+ /* @<Read the {\.{TFM}} size fields@>; */
+ nco=0; ncw=0; npc=0;
+ read_sixteen(first_two);
+ if (first_two!=0) {
+ font_level=-1;
+ lf=first_two;
+ fget; read_sixteen(lh);
+ fget; read_sixteen(bc);
+ fget; read_sixteen(ec);
+ if ((bc>ec+1)||(ec>255)) tfm_abort;
+ if (bc>255) { /* |bc=256| and |ec=255| */
+ bc=1; ec=0;
+ };
+ fget; read_sixteen(nw);
+ fget; read_sixteen(nh);
+ fget; read_sixteen(nd);
+ fget; read_sixteen(ni);
+ fget; read_sixteen(nl);
+ fget; read_sixteen(nk);
+ fget; read_sixteen(ne);
+ fget; read_sixteen(np);
+ header_length=6;
+ ncw=(ec-bc+1);
+ nlw=nl;
+ neew=ne;
+ } else {
+ fget; read_sixteen(font_level);
+ if (font_level!=0) tfm_abort;
+ read_thirtytwo(lf);
+ read_thirtytwo(lh);
+ read_thirtytwo(bc);
+ read_thirtytwo(ec);
+ if ((bc>ec+1)||(ec>65535)) tfm_abort;
+ if (bc>65535) { /* |bc=65536| and |ec=65535| */
+ bc=1; ec=0;
+ };
+ read_thirtytwo(nw);
+ read_thirtytwo(nh);
+ read_thirtytwo(nd);
+ read_thirtytwo(ni);
+ read_thirtytwo(nl);
+ read_thirtytwo(nk);
+ read_thirtytwo(ne);
+ read_thirtytwo(np);
+ read_thirtytwo(font_dir); /* junk */
+ nlw=2*nl;
+ neew=2*ne;
+ header_length=14;
+ ncw=2*(ec-bc+1);
+ };
+ if (lf!=(header_length+lh+ncw+nw+nh+nd+ni+nlw+nk+neew+np)) tfm_abort;
+
+ /* @<Use size fields to allocate font information@>; */
+
+ set_font_natural_dir(f,font_dir);
+ set_font_bc(f,bc);
+ set_font_ec(f,ec);
+
+ /* read the arrays first */
+ widths = xmalloc(nw*sizeof(scaled));
+ heights = xmalloc(nh*sizeof(scaled));
+ depths = xmalloc(nd*sizeof(scaled));
+ italics = xmalloc(ni*sizeof(scaled));
+ extens = xmalloc(ne*sizeof(four_quarters));
+ lig_kerns = xmalloc(nl*sizeof(four_quarters));
+ kerns = xmalloc(nk*sizeof(scaled));
+
+ /* @<Read the {\.{TFM}} header@>; */
+
+ /* Only the first two words of the header are needed by \TeX82. */
+ slh = lh;
+ if (lh<2)
+ tfm_abort;
+ store_four_bytes(font_checksum(f));
+ fget; read_sixteen(z); /* this rejects a negative design size */
+ fget; z=z*256+fbyte; fget; z=(z*16)+(fbyte>>4);
+ if (z<unity) tfm_abort;
+ while (lh>2) {
+ fget;fget;fget;fget;
+ lh--; /* ignore the rest of the header */
+ };
+
+ /* read the arrays before the character info */
+
+ set_font_dsize(f,z);
+ if (s!=-1000) {
+ z = (s>=0 ? s : xn_over_d(z,-s,1000));
+ }
+ set_font_size(f,z);
+
+ if (np>7)
+ set_font_params(f,np);
+
+ saved_tfm_byte = tfm_byte;
+ tfm_byte = (header_length+slh+ncw)*4 - 1;
+
+ /* @<Replace |z| by $|z|^\prime$ and compute $\alpha,\beta$@>; */
+
+ alpha=16;
+ while (z>=040000000) {
+ z=z>>1; alpha=alpha+alpha;
+ };
+ beta=256/alpha; alpha=alpha*z;
+
+ /* @<Read box dimensions@>; */
+
+ for (k=0;k<nw;k++) {
+ store_scaled(sw); widths[k] = sw;
+ }
+ if (widths[0]!=0) /* \\{width}[0] must be zero */
+ tfm_abort;
+ for (k=0;k<nh;k++) {
+ store_scaled(sw); heights[k] = sw;
+ }
+ if (heights[0]!=0)
+ tfm_abort; /* \\{height}[0] must be zero */
+ for (k=0;k<nd;k++) {
+ store_scaled(sw); depths[k] = sw;
+ }
+ if (depths[0]!=0)
+ tfm_abort; /* \\{depth}[0] must be zero */
+ for (k=0;k<ni;k++) {
+ store_scaled(sw); italics[k] = sw;
+ }
+ if (italics[0]!=0)
+ tfm_abort; /* \\{italic}[0] must be zero */
+
+
+ /* @<Read ligature/kern program@>; */
+
+ bch_label=nl; /* infinity*/
+ bchar=65536;
+ if (nl>0) {
+ for (k=0;k<nl;k++) {
+ read_four_quarters(qw);
+ lig_kerns[k] = qw;
+ if (a>128) {
+ if (256*c+d>=nl) tfm_abort;
+ if (a==255 && k==0) bchar=b;
+ } else {
+ /* if (b!=bchar) check_existence(b); */
+ if (c<128) {
+ /* check_existence(d); */ /* check ligature */
+ } else if (256*(c-128)+d>=nk) {
+ tfm_abort; /* check kern */
+ }
+ if ((a<128) && (k-0+a+1>=nl)) tfm_abort;
+ };
+ };
+ if (a==255) bch_label=256*c+d;
+ };
+
+ /* the actual kerns */
+ for (k=0;k<nk;k++) {
+ store_scaled(sw); kerns[k] = sw;
+ }
+
+ /* @<Read extensible character recipes@>; */
+ for (k=0;k<ne;k++) {
+ read_four_quarters(qw); extens[k] = qw;
+ }
+
+ /* @<Read font parameters@>; */
+
+ if (np>7) {
+ set_font_params(f,np);
+ }
+ for (k=1;k<=np;k++) {
+ if (k==1) { /* the |slant| parameter is a pure number */
+ fget; sw=fbyte;
+ if (sw>127) sw=sw-256;
+ fget; sw=sw*256+fbyte;
+ fget; sw=sw*256+fbyte;
+ fget; sw=(sw*16)+(fbyte>>4);
+ set_font_param(f,k,sw);
+ } else {
+ store_scaled(font_param(f,k));
+ }
+ }
+
+ /*
+ We check to see that the \.{TFM} file doesn't end prematurely; but
+ no error message is given for files having more than |lf| words.
+ */
+
+ if (tfm_byte<tfm_size-1) tfm_abort;
+
+ tfm_byte = saved_tfm_byte ;
+
+ /* fix up the left boundary character */
+ fligs = 0;
+ fkerns = 0;
+ if (bch_label != nl ) {
+ k = bch_label;
+ /*
+ if (skip_byte(k) > stop_flag)
+ k = lig_kern_restart(k);
+ */
+ while (1) {
+ if (skip_byte(k) <= stop_flag) {
+ if(op_byte(k) >= kern_flag) { /* kern */
+ fkerns++;
+ } else { /* lig */
+ fligs++;
+ }
+ }
+ if (skip_byte(k) == 0) {
+ k++;
+ } else {
+ if (skip_byte(k) >= stop_flag)
+ break;
+ k += skip_byte(k) + 1;
+ }
+ }
+ }
+ if (fkerns >0 || fligs > 0) {
+ if (fligs>0) cligs = xcalloc((fligs+1),sizeof(liginfo));
+ if (fkerns>0) ckerns = xcalloc((fkerns+1),sizeof(kerninfo));
+ fligs = 0;
+ fkerns = 0;
+ k = bch_label;
+ /*
+ if (skip_byte(k) > stop_flag)
+ k = lig_kern_restart(k);
+ */
+ while (1) {
+ if (skip_byte(k) <= stop_flag) {
+ if(op_byte(k) >= kern_flag) { /* kern */
+ set_kern_item(ckerns[fkerns],next_char(k),kerns[256*(op_byte(k)-128)+rem_byte(k)]);
+ fkerns++;
+ } else { /* lig */
+ set_ligature_item(cligs[fligs],(op_byte(k)*2+1),next_char(k),rem_byte(k));
+ fligs++;
+ }
+ }
+ if (skip_byte(k) == 0) {
+ k++;
+ } else {
+ if (skip_byte(k) >= stop_flag)
+ break;
+ k += skip_byte(k) + 1;
+ }
+ }
+ if (fkerns>0 || fligs>0){
+ co = get_charinfo(f,left_boundarychar);
+ if (fkerns>0) {
+ set_kern_item(ckerns[fkerns],end_kern,0);
+ fkerns++;
+ set_charinfo_kerns(co,ckerns);
+ }
+ if (fligs>0){
+ set_ligature_item(cligs[fligs],0,end_ligature,0);
+ fligs++;
+ set_charinfo_ligatures(co,cligs);
+ }
+ set_charinfo_remainder(co,0);
+ }
+ }
+
+ /* @<Read character data@>; */
+ for (k=bc;k<=ec;k++) {
+ store_char_info(k);
+ if (ci._width_index==0)
+ continue;
+ if (ci._width_index>=nw||ci._height_index>=nh||
+ ci._depth_index>=nd||ci._italic_index>=ni) tfm_abort;
+ d = ci._remainder;
+ switch (ci._tag) {
+ case lig_tag: if (d>=nl) tfm_abort; break;
+ case ext_tag: if (d>=ne) tfm_abort; break;
+ case list_tag:
+ /* We want to make sure that there is no cycle of characters linked together
+ by |list_tag| entries, since such a cycle would get \TeX\ into an endless
+ loop. If such a cycle exists, the routine here detects it when processing
+ the largest character code in the cycle.
+ */
+ check_byte_range(d);
+ while (d<k) { /* current_character == k */
+ if (char_tag(f,d)!=list_tag)
+ goto NOT_FOUND; /* not a cycle */
+ d=char_remainder(f,d); /* next character on the list */
+ };
+ if (d==k) tfm_abort; /* yes, there's a cycle */
+ NOT_FOUND:
+ break;
+ }
+ /* put it in the actual font */
+ co = get_charinfo(f,k);
+ set_charinfo_index (co,k);
+ set_charinfo_tag (co,ci._tag);
+ if (ci._tag == ext_tag) {
+ set_charinfo_extensible(co,
+ extens[ci._remainder].b0, /* top */
+ extens[ci._remainder].b2, /* bot */
+ extens[ci._remainder].b1, /* mid */
+ extens[ci._remainder].b3); /* rep */
+ set_charinfo_remainder (co,0);
+ } else {
+ set_charinfo_remainder (co,ci._remainder);
+ }
+ set_charinfo_width (co,widths[ci._width_index]);
+ set_charinfo_height (co,heights[ci._height_index]);
+ set_charinfo_depth (co,depths[ci._depth_index]);
+ set_charinfo_italic (co,italics[ci._italic_index]);
+ };
+
+ /* first pass: count ligs and kerns */
+
+ xligs = xcalloc((ec+1),sizeof(integer));
+ xkerns = xcalloc((ec+1),sizeof(integer));
+
+ for (i=bc;i<=ec;i++) {
+ if (char_tag(f,i) == lig_tag) {
+ k = lig_kern_start(f,i);
+ if (skip_byte(k) > stop_flag)
+ k = lig_kern_restart(k);
+ /* now k is the start index */
+ while (1) {
+ if (skip_byte(k) <= stop_flag) {
+ if(op_byte(k) >= kern_flag) { /* kern */
+ xkerns[i]++;
+ if (next_char(k) == bchar)
+ xkerns[i]++;
+ } else { /* lig */
+ xligs[i]++;
+ if (next_char(k) == bchar)
+ xligs[i]++;
+ }
+ }
+ if (skip_byte(k) == 0) {
+ k++;
+ } else {
+ if (skip_byte(k) >= stop_flag)
+ break;
+ k += skip_byte(k) + 1;
+ }
+ }
+ }
+ }
+
+ cligs = NULL;
+ ckerns = NULL;
+
+ for (i=bc;i<=ec;i++) {
+ fligs = 0;
+ fkerns = 0;
+ if (char_tag(f,i) == lig_tag) {
+ k = lig_kern_start(f,i);
+ if (skip_byte(k) > stop_flag)
+ k = lig_kern_restart(k);
+ /* now k is the start index */
+ if (xligs[i]>0) cligs = xcalloc((xligs[i]+1),sizeof(liginfo));
+ if (xkerns[i]>0) ckerns = xcalloc((xkerns[i]+1),sizeof(kerninfo));
+ while (1) {
+ if (skip_byte(k) <= stop_flag) {
+ if(op_byte(k) >= kern_flag) { /* kern */
+ if (next_char(k) == bchar) {
+ set_kern_item(ckerns[fkerns],right_boundarychar,kerns[256*(op_byte(k)-128)+rem_byte(k)]);
+ fkerns++;
+ }
+ set_kern_item(ckerns[fkerns],next_char(k),kerns[256*(op_byte(k)-128)+rem_byte(k)]);
+ fkerns++;
+ } else { /* lig */
+ if (next_char(k) == bchar) {
+ set_ligature_item(cligs[fligs],(op_byte(k)*2+1),right_boundarychar,rem_byte(k));
+ fligs++;
+ }
+ set_ligature_item(cligs[fligs],(op_byte(k)*2+1),next_char(k),rem_byte(k));
+ fligs++;
+ }
+ }
+ if (skip_byte(k) == 0) {
+ k++;
+ } else {
+ if (skip_byte(k) >= stop_flag)
+ break;
+ k += skip_byte(k) + 1;
+ }
+ }
+ if (fkerns>0 || fligs>0){
+ co = get_charinfo(f,i);
+ if (fkerns>0) {
+ set_kern_item(ckerns[fkerns],end_kern,0);
+ fkerns++;
+ set_charinfo_kerns(co,ckerns);
+ }
+ if (fligs>0){
+ set_ligature_item(cligs[fligs],0,end_ligature,0);
+ fligs++;
+ set_charinfo_ligatures(co,cligs);
+ }
+ set_charinfo_remainder(co,0);
+ }
+ }
+ }
+
+
+ /* @<Make final adjustments and |goto done|@> */
+
+ /* Now to wrap it up, we have checked all the necessary things about the \.{TFM}
+ file, and all we need to do is put the finishing touches on the data for
+ the new font.
+ */
+
+ if (bchar!= 65536) {
+ co = copy_charinfo(char_info(f,bchar));
+ set_right_boundary(f,co);
+ }
+
+ tfm_success;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/font/tounicode.c b/Build/source/texk/web2c/luatexdir/font/tounicode.c
new file mode 100644
index 00000000000..ff86a8512e2
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/tounicode.c
@@ -0,0 +1,604 @@
+/*
+Copyright (c) 2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*/
+
+#include "ptexlib.h"
+
+#define isXdigit(c) (isdigit(c) || ('A' <= (c) && (c) <= 'F'))
+#define UNI_UNDEF -1
+#define UNI_STRING -2 /* string allocated by def_tounicode() */
+#define UNI_EXTRA_STRING -3 /* string allocated by set_glyph_unicode() */
+
+static struct avl_table *glyph_unicode_tree = NULL;
+
+static int comp_glyph_unicode_entry(const void *pa, const void *pb, void *p)
+{
+ return strcmp(((const glyph_unicode_entry *) pa)->name,
+ ((const glyph_unicode_entry *) pb)->name);
+}
+
+static glyph_unicode_entry *new_glyph_unicode_entry(void)
+{
+ glyph_unicode_entry *e;
+ e = xtalloc(1, glyph_unicode_entry);
+ e->name = NULL;
+ e->code = UNI_UNDEF;
+ e->unicode_seq = NULL;
+ return e;
+}
+
+static void destroy_glyph_unicode_entry(void *pa, void *pb)
+{
+ glyph_unicode_entry *e = (glyph_unicode_entry *) pa;
+ xfree(e->name);
+ if (e->code == UNI_STRING) {
+ assert(e->unicode_seq != NULL);
+ xfree(e->unicode_seq);
+ }
+}
+
+void glyph_unicode_free(void)
+{
+ if (glyph_unicode_tree != NULL)
+ avl_destroy(glyph_unicode_tree, destroy_glyph_unicode_entry);
+}
+
+void def_tounicode(strnumber glyph, strnumber unistr)
+{
+ char buf[SMALL_BUF_SIZE], *p;
+ char buf2[SMALL_BUF_SIZE], *q;
+ int valid_unistr; /* 0: invalid; 1: unicode value; 2: string */
+ int i, l;
+ glyph_unicode_entry *gu, t;
+ void **aa;
+
+ p = makecstring(glyph);
+ assert(strlen(p) < SMALL_BUF_SIZE);
+ strcpy(buf, p); /* copy the result to buf before next call of makecstring() */
+ p = makecstring(unistr);
+ while (*p == ' ')
+ p++; /* ignore leading spaces */
+ l = strlen(p);
+ while (l > 0 && p[l - 1] == ' ')
+ l--; /* ignore traling spaces */
+ valid_unistr = 1; /* a unicode value is the most common case */
+ for (i = 0; i < l; i++) {
+ if (p[i] == ' ')
+ valid_unistr = 2; /* if a space occurs we treat this entry as a string */
+ else if (!isXdigit(p[i])) {
+ valid_unistr = 0;
+ break;
+ }
+ }
+ if (l == 0 || valid_unistr == 0 || strlen(buf) == 0
+ || strcmp(buf, notdef) == 0) {
+ pdftex_warn("ToUnicode: invalid parameter(s): `%s' => `%s'", buf, p);
+ return;
+ }
+ if (glyph_unicode_tree == NULL) {
+ glyph_unicode_tree =
+ avl_create(comp_glyph_unicode_entry, NULL, &avl_xallocator);
+ assert(glyph_unicode_tree != NULL);
+ }
+ t.name = buf;
+ /* allow overriding existing entries */
+ if ((gu = (glyph_unicode_entry *) avl_find(glyph_unicode_tree, &t)) != NULL) {
+ if (gu->code == UNI_STRING) {
+ assert(gu->unicode_seq != NULL);
+ xfree(gu->unicode_seq);
+ }
+ } else { /* make new entry */
+ gu = new_glyph_unicode_entry();
+ gu->name = xstrdup(buf);
+ }
+ if (valid_unistr == 2) { /* a string with space(s) */
+ /* copy p to buf2, ignoring spaces */
+ for (q = buf2; *p != 0; p++)
+ if (*p != ' ')
+ *q++ = *p;
+ *q = 0;
+ gu->code = UNI_STRING;
+ gu->unicode_seq = xstrdup(buf2);
+ } else {
+ i = sscanf(p, "%lX", &(gu->code));
+ assert(i == 1);
+ }
+ aa = avl_probe(glyph_unicode_tree, gu);
+ assert(aa != NULL);
+}
+
+
+static long check_unicode_value(char *s, boolean multiple_value)
+{
+ int l = strlen(s);
+ int i;
+ long code;
+
+ if (l == 0)
+ return UNI_UNDEF;
+ if (multiple_value && l % 4 != 0)
+ return UNI_UNDEF;
+ if (!multiple_value && !(4 <= l && l <= 6))
+ return UNI_UNDEF;
+
+ for (i = 0; i < l; i++) {
+ if (!isXdigit(s[i]))
+ return UNI_UNDEF;
+ if (multiple_value) {
+ if (i % 4 == 3) {
+ if (sscanf(s + i - 3, "%4lX", &code) != 1)
+ return UNI_UNDEF;
+ if (!((0x0000 <= code && code <= 0xD7FF) ||
+ (0xE000 <= code && code <= 0xFFFF)))
+ return UNI_UNDEF;
+ }
+ } else { /* single value */
+ if (i == l - 1) {
+ if (sscanf(s, "%lX", &code) != 1)
+ return UNI_UNDEF;
+ if (!((0x0000 <= code && code <= 0xD7FF) ||
+ (0xE000 <= code && code <= 0x10FFFF)))
+ return UNI_UNDEF;
+ }
+ }
+ }
+ return code;
+}
+
+static char *utf16be_str(long code)
+{
+ static char buf[SMALL_BUF_SIZE];
+ long v;
+ unsigned vh, vl;
+
+ assert(code >= 0);
+
+ if (code <= 0xFFFF)
+ sprintf(buf, "%04lX", code);
+ else {
+ v = code - 0x10000;
+ vh = v / 0x400 + 0xD800;
+ vl = v % 0x400 + 0xDC00;
+ sprintf(buf, "%04X%04X", vh, vl);
+ }
+ return buf;
+}
+
+
+/* this function set proper values to *gp based on s; in case it returns
+ * gp->code == UNI_EXTRA_STRING then the caller is responsible for freeing
+ * gp->unicode_seq too */
+static void set_glyph_unicode(char *s, glyph_unicode_entry * gp)
+{
+ char buf[SMALL_BUF_SIZE], buf2[SMALL_BUF_SIZE], *p;
+ long code;
+ boolean last_component;
+ glyph_unicode_entry tmp, *ptmp;
+
+ /* skip dummy entries */
+ if (s == NULL || s == notdef)
+ return;
+
+ /* strip everything after the first dot */
+ p = strchr(s, '.');
+ if (p != NULL) {
+ *buf = 0;
+ strncat(buf, s, p - s);
+ s = buf;
+ }
+
+ if (strlen(s) == 0)
+ return;
+
+ /* check for case of multiple components separated by '_' */
+ p = strchr(s, '_');
+ if (p != NULL) {
+ assert(strlen(s) < sizeof(buf));
+ if (s != buf) {
+ strcpy(buf, s);
+ p = strchr(buf, '_');
+ s = buf;
+ }
+ *buf2 = 0;
+ last_component = false;
+ for (;;) {
+ *p = 0;
+ tmp.code = UNI_UNDEF;
+ set_glyph_unicode(s, &tmp);
+ switch (tmp.code) {
+ case UNI_UNDEF: /* not found, do nothing */
+ break;
+ case UNI_STRING: /* s matched an entry with string value in the database */
+ assert(tmp.unicode_seq != NULL);
+ assert(strlen(buf2) + strlen(tmp.unicode_seq) < sizeof(buf2));
+ strcat(buf2, tmp.unicode_seq);
+ break;
+ case UNI_EXTRA_STRING: /* s is a multiple value of form "uniXXXX" */
+ assert(strlen(buf2) + strlen(tmp.unicode_seq) < sizeof(buf2));
+ strcat(buf2, tmp.unicode_seq);
+ xfree(tmp.unicode_seq);
+ break;
+ default: /* s matched an entry with numeric value in the
+ database, or a value derived from "uXXXX" */
+ assert(tmp.code >= 0);
+ strcat(buf2, utf16be_str(tmp.code));
+ }
+ if (last_component)
+ break;
+ s = p + 1;
+ p = strchr(s, '_');
+ if (p == NULL) {
+ p = strend(s);
+ last_component = true;
+ }
+ }
+ gp->code = UNI_EXTRA_STRING;
+ gp->unicode_seq = xstrdup(buf2);
+ return;
+ }
+
+ /* lookup for glyph name in the database */
+ tmp.name = s;
+ tmp.code = UNI_UNDEF;
+ ptmp = (glyph_unicode_entry *) avl_find(glyph_unicode_tree, &tmp);
+ if (ptmp != NULL) {
+ gp->code = ptmp->code;
+ gp->unicode_seq = ptmp->unicode_seq;
+ return;
+ }
+
+ /* check for case of "uniXXXX" (multiple 4-hex-digit values allowed) */
+ if (str_prefix(s, "uni")) {
+ p = s + strlen("uni");
+ code = check_unicode_value(p, true);
+ if (code != UNI_UNDEF) {
+ if (strlen(p) == 4) /* single value */
+ gp->code = code;
+ else { /* multiple value */
+ gp->code = UNI_EXTRA_STRING;
+ gp->unicode_seq = xstrdup(p);
+ }
+ }
+ return; /* since the last case cannot happen */
+ }
+
+ /* check for case of "uXXXX" (single value up to 6 hex digits) */
+ if (str_prefix(s, "u")) {
+ p = s + strlen("u");
+ code = check_unicode_value(p, false);
+ if (code != UNI_UNDEF) {
+ assert(code >= 0);
+ gp->code = code;
+ }
+ }
+}
+
+static void set_cid_glyph_unicode(long index, glyph_unicode_entry * gp,
+ internal_font_number f) {
+ char *s;
+ if (font_tounicode(f)) {
+ if ((s = get_charinfo_tounicode(char_info(f,index)))!=NULL) {
+ gp->code = UNI_EXTRA_STRING;
+ gp->unicode_seq = xstrdup(s);
+ }
+ } else {
+ gp->code = index; /* fallback */
+ }
+}
+
+
+integer write_tounicode(char **glyph_names, char *name)
+{
+ char buf[SMALL_BUF_SIZE], *p;
+ static char builtin_suffix[] = "-builtin";
+ short range_size[257];
+ glyph_unicode_entry gtab[257];
+ integer objnum;
+ int i, j;
+ int bfchar_count, bfrange_count, subrange_count;
+ assert(strlen(name) + strlen(builtin_suffix) < SMALL_BUF_SIZE);
+ if (glyph_unicode_tree == NULL) {
+ pdftex_warn("no GlyphToUnicode entry has been inserted yet!");
+ fixed_gen_tounicode = 0;
+ return 0;
+ }
+ strcpy(buf, name);
+ if ((p = strrchr(buf, '.')) != NULL && strcmp(p, ".enc") == 0)
+ *p = 0; /* strip ".enc" from encoding name */
+ else
+ strcat(buf, builtin_suffix); /* ".enc" not present, this is a builtin
+ encoding so the name is eg "cmr10-builtin" */
+ objnum = pdf_new_objnum();
+ pdf_begin_dict(objnum, 0);
+ pdf_begin_stream();
+ pdf_printf("%%!PS-Adobe-3.0 Resource-CMap\n"
+ "%%%%DocumentNeededResources: ProcSet (CIDInit)\n"
+ "%%%%IncludeResource: ProcSet (CIDInit)\n"
+ "%%%%BeginResource: CMap (TeX-%s-0)\n"
+ "%%%%Title: (TeX-%s-0 TeX %s 0)\n"
+ "%%%%Version: 1.000\n"
+ "%%%%EndComments\n"
+ "/CIDInit /ProcSet findresource begin\n"
+ "12 dict begin\n"
+ "begincmap\n"
+ "/CIDSystemInfo\n"
+ "<< /Registry (TeX)\n"
+ "/Ordering (%s)\n"
+ "/Supplement 0\n"
+ ">> def\n"
+ "/CMapName /TeX-%s-0 def\n"
+ "/CMapType 2 def\n"
+ "1 begincodespacerange\n"
+ "<00> <FF>\n" "endcodespacerange\n", buf, buf, buf, buf, buf);
+
+ /* set gtab */
+ for (i = 0; i < 256; ++i) {
+ gtab[i].code = UNI_UNDEF;
+ set_glyph_unicode(glyph_names[i], &gtab[i]);
+ }
+ gtab[256].code = UNI_UNDEF;
+
+ /* set range_size */
+ for (i = 0; i < 256;) {
+ if (gtab[i].code == UNI_STRING || gtab[i].code == UNI_EXTRA_STRING) {
+ range_size[i] = 1; /* single entry */
+ i++;
+ } else if (gtab[i].code == UNI_UNDEF) {
+ range_size[i] = 0; /* no entry */
+ i++;
+ } else { /* gtab[i].code >= 0 */
+ j = i;
+ while (i < 256 && gtab[i + 1].code >= 0 &&
+ gtab[i].code + 1 == gtab[i + 1].code)
+ i++;
+ /* at this point i is the last entry of the subrange */
+ i++; /* move i to the next entry */
+ range_size[j] = i - j;
+ }
+ }
+
+ /* calculate bfrange_count and bfchar_count */
+ bfrange_count = 0;
+ bfchar_count = 0;
+ for (i = 0; i < 256;) {
+ if (range_size[i] == 1) {
+ bfchar_count++;
+ i++;
+ } else if (range_size[i] > 1) {
+ bfrange_count++;
+ i += range_size[i];
+ } else
+ i++;
+ }
+
+ /* write out bfrange */
+ i = 0;
+ write_bfrange:
+ if (bfrange_count > 100)
+ subrange_count = 100;
+ else
+ subrange_count = bfrange_count;
+ bfrange_count -= subrange_count;
+ pdf_printf("%i beginbfrange\n", subrange_count);
+ for (j = 0; j < subrange_count; j++) {
+ while (range_size[i] <= 1 && i < 256)
+ i++;
+ assert(i < 256);
+ pdf_printf("<%02X> <%02X> <%s>\n", i, i + range_size[i] - 1,
+ utf16be_str(gtab[i].code));
+ i += range_size[i];
+ }
+ pdf_printf("endbfrange\n");
+ if (bfrange_count > 0)
+ goto write_bfrange;
+
+ /* write out bfchar */
+ i = 0;
+ write_bfchar:
+ if (bfchar_count > 100)
+ subrange_count = 100;
+ else
+ subrange_count = bfchar_count;
+ bfchar_count -= subrange_count;
+ pdf_printf("%i beginbfchar\n", subrange_count);
+ for (j = 0; j < subrange_count; j++) {
+ while (i < 256) {
+ if (range_size[i] > 1)
+ i += range_size[i];
+ else if (range_size[i] == 0)
+ i++;
+ else /* range_size[i] == 1 */
+ break;
+ }
+ assert(i < 256 && gtab[i].code != UNI_UNDEF);
+ if (gtab[i].code == UNI_STRING || gtab[i].code == UNI_EXTRA_STRING) {
+ assert(gtab[i].unicode_seq != NULL);
+ pdf_printf("<%02X> <%s>\n", i, gtab[i].unicode_seq);
+ } else
+ pdf_printf("<%02X> <%s>\n", i, utf16be_str(gtab[i].code));
+ i++;
+ }
+ pdf_printf("endbfchar\n");
+ if (bfchar_count > 0)
+ goto write_bfchar;
+
+ /* free strings allocated by set_glyph_unicode() */
+ for (i = 0; i < 256; ++i) {
+ if (gtab[i].code == UNI_EXTRA_STRING)
+ xfree(gtab[i].unicode_seq);
+ }
+
+ pdf_printf("endcmap\n"
+ "CMapName currentdict /CMap defineresource pop\n"
+ "end\n" "end\n" "%%%%EndResource\n" "%%%%EOF\n");
+ pdf_end_stream();
+ return objnum;
+}
+
+integer write_cid_tounicode(fo_entry * fo, internalfontnumber f) {
+
+ int range_size[65537];
+ glyph_unicode_entry gtab[65537];
+ integer objnum;
+ int i, j, k;
+ int bfchar_count, bfrange_count, subrange_count;
+ char *buf;
+
+ assert(fo->fd->fontname);
+ buf = xmalloc(strlen(fo->fd->fontname)+8);
+ sprintf(buf,"%s-%s",(fo->fd->subset_tag!=NULL ? fo->fd->subset_tag : "UCS"),
+ fo->fd->fontname);
+
+ objnum = pdf_new_objnum();
+ pdf_begin_dict(objnum, 0);
+ pdf_begin_stream();
+ pdf_printf("%%!PS-Adobe-3.0 Resource-CMap\n"
+ "%%%%DocumentNeededResources: ProcSet (CIDInit)\n"
+ "%%%%IncludeResource: ProcSet (CIDInit)\n"
+ "%%%%BeginResource: CMap (TeX-%s-0)\n"
+ "%%%%Title: (TeX-%s-0 TeX %s 0)\n"
+ "%%%%Version: 1.000\n"
+ "%%%%EndComments\n"
+ "/CIDInit /ProcSet findresource begin\n"
+ "12 dict begin\n"
+ "begincmap\n"
+ "/CIDSystemInfo\n"
+ "<< /Registry (TeX)\n"
+ "/Ordering (%s)\n"
+ "/Supplement 0\n"
+ ">> def\n"
+ "/CMapName /TeX-Identity-%s def\n"
+ "/CMapType 2 def\n"
+ "1 begincodespacerange\n"
+ "<0000> <FFFF>\n"
+ "endcodespacerange\n", buf, buf, buf, buf, buf);
+ xfree(buf);
+ /* set up gtab */
+ for (i = 0; i < 65537; ++i) {
+ gtab[i].code = UNI_UNDEF;
+ }
+ for (k = 1; k <= max_font_id(); k++) {
+ if (k == f || -f == pdf_font_num(k)) {
+ for (i = font_bc(k); i <= font_ec(k); i++) {
+ if (char_exists(k,i) && char_used(k,i)) {
+ j = char_index(k,i);
+ if (gtab[j].code == UNI_UNDEF) {
+ set_cid_glyph_unicode(i, &gtab[j], f);
+ }
+ }
+ }
+ }
+ }
+
+ /* set range_size */
+ for (i = 0; i < 65536;) {
+ if (gtab[i].code == UNI_STRING || gtab[i].code == UNI_EXTRA_STRING) {
+ range_size[i] = 1; /* single entry */
+ i++;
+ } else if (gtab[i].code == UNI_UNDEF) {
+ range_size[i] = 0; /* no entry */
+ i++;
+ } else { /* gtab[i].code >= 0 */
+ j = i;
+ while (i < 65536 && gtab[i + 1].code >= 0 &&
+ gtab[i].code + 1 == gtab[i + 1].code)
+ i++;
+ /* at this point i is the last entry of the subrange */
+ i++; /* move i to the next entry */
+ range_size[j] = i - j;
+ }
+ }
+
+ /* calculate bfrange_count and bfchar_count */
+ bfrange_count = 0;
+ bfchar_count = 0;
+ for (i = 0; i < 65536;) {
+ if (range_size[i] == 1) {
+ bfchar_count++;
+ i++;
+ } else if (range_size[i] > 1) {
+ bfrange_count++;
+ i += range_size[i];
+ } else
+ i++;
+ }
+
+ /* write out bfrange */
+ i = 0;
+ write_bfrange:
+ if (bfrange_count > 100)
+ subrange_count = 100;
+ else
+ subrange_count = bfrange_count;
+ bfrange_count -= subrange_count;
+ pdf_printf("%i beginbfrange\n", subrange_count);
+ for (j = 0; j < subrange_count; j++) {
+ while (range_size[i] <= 1 && i < 65536)
+ i++;
+ assert(i < 65536);
+ pdf_printf("<%04X> <%04X> <%s>\n", i, i + range_size[i] - 1,
+ utf16be_str(gtab[i].code));
+ i += range_size[i];
+ }
+ pdf_printf("endbfrange\n");
+ if (bfrange_count > 0)
+ goto write_bfrange;
+
+ /* write out bfchar */
+ i = 0;
+ write_bfchar:
+ if (bfchar_count > 100)
+ subrange_count = 100;
+ else
+ subrange_count = bfchar_count;
+ bfchar_count -= subrange_count;
+ pdf_printf("%i beginbfchar\n", subrange_count);
+ for (j = 0; j < subrange_count; j++) {
+ while (i < 65536) {
+ if (range_size[i] > 1)
+ i += range_size[i];
+ else if (range_size[i] == 0)
+ i++;
+ else /* range_size[i] == 1 */
+ break;
+ }
+ assert(i < 65536 && gtab[i].code != UNI_UNDEF);
+ if (gtab[i].code == UNI_STRING || gtab[i].code == UNI_EXTRA_STRING) {
+ assert(gtab[i].unicode_seq != NULL);
+ pdf_printf("<%04X> <%s>\n", i, gtab[i].unicode_seq);
+ } else
+ pdf_printf("<%04X> <%s>\n", i, utf16be_str(gtab[i].code));
+ i++;
+ }
+ pdf_printf("endbfchar\n");
+ if (bfchar_count > 0)
+ goto write_bfchar;
+
+ /* free strings allocated by set_glyph_unicode() */
+ for (i = 0; i < 65536; ++i) {
+ if (gtab[i].code == UNI_EXTRA_STRING)
+ xfree(gtab[i].unicode_seq);
+ }
+
+ pdf_printf("endcmap\n"
+ "CMapName currentdict /CMap defineresource pop\n"
+ "end\n" "end\n" "%%%%EndResource\n" "%%%%EOF\n");
+ pdf_end_stream();
+ return objnum;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/tt_glyf.c b/Build/source/texk/web2c/luatexdir/font/tt_glyf.c
new file mode 100644
index 00000000000..bf21e58c49a
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/tt_glyf.c
@@ -0,0 +1,658 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/tt_glyf.c,v 1.2 2005/06/09 14:31:11 hirata Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+/*
+ * Subsetting glyf, updating loca, hmtx, ...
+ *
+ */
+
+#include "ptexlib.h"
+
+#include "sfnt.h"
+#include "tt_table.h"
+#include "tt_glyf.h"
+
+#define NUM_GLYPH_LIMIT 65534
+#define TABLE_DATA_ALLOC_SIZE 40960
+#define GLYPH_ARRAY_ALLOC_SIZE 256
+
+static USHORT
+find_empty_slot (struct tt_glyphs *g)
+{
+ USHORT gid;
+
+ ASSERT(g);
+
+ for (gid = 0; gid < NUM_GLYPH_LIMIT; gid++) {
+ if (!(g->used_slot[gid/8] & (1 << (7 - (gid % 8)))))
+ break;
+ }
+ if (gid == NUM_GLYPH_LIMIT)
+ TT_ERROR("No empty glyph slot available.");
+
+ return gid;
+}
+
+USHORT
+tt_find_glyph (struct tt_glyphs *g, USHORT gid)
+{
+ USHORT idx, new_gid = 0;
+
+ ASSERT(g);
+
+ for (idx = 0; idx < g->num_glyphs; idx++) {
+ if (gid == g->gd[idx].ogid) {
+ new_gid = g->gd[idx].gid;
+ break;
+ }
+ }
+
+ return new_gid;
+}
+
+USHORT
+tt_get_index (struct tt_glyphs *g, USHORT gid)
+{
+ USHORT idx;
+
+ ASSERT(g);
+
+ for (idx = 0; idx < g->num_glyphs; idx++) {
+ if (gid == g->gd[idx].gid)
+ break;
+ }
+ if (idx == g->num_glyphs)
+ idx = 0;
+
+ return idx;
+}
+
+USHORT
+tt_add_glyph (struct tt_glyphs *g, USHORT gid, USHORT new_gid)
+{
+ ASSERT(g);
+
+ if (g->used_slot[new_gid/8] & (1 << (7 - (new_gid % 8)))) {
+ WARN("Slot %u already used.", new_gid);
+ } else {
+ if (g->num_glyphs+1 >= NUM_GLYPH_LIMIT)
+ TT_ERROR("Too many glyphs.");
+
+ if (g->num_glyphs >= g->max_glyphs) {
+ g->max_glyphs += GLYPH_ARRAY_ALLOC_SIZE;
+ g->gd = RENEW(g->gd, g->max_glyphs, struct tt_glyph_desc);
+ }
+ g->gd[g->num_glyphs].gid = new_gid;
+ g->gd[g->num_glyphs].ogid = gid;
+ g->gd[g->num_glyphs].length = 0;
+ g->gd[g->num_glyphs].data = NULL;
+ g->used_slot[new_gid/8] |= (1 << (7 - (new_gid % 8)));
+ g->num_glyphs += 1;
+ }
+
+ if (new_gid > g->last_gid) {
+ g->last_gid = new_gid;
+ }
+
+ return new_gid;
+}
+
+/*
+ * Initialization
+ */
+struct tt_glyphs *
+tt_build_init (void)
+{
+ struct tt_glyphs *g;
+
+ g = NEW(1, struct tt_glyphs);
+
+ g->num_glyphs = 0;
+ g->max_glyphs = 0;
+ g->last_gid = 0;
+ g->emsize = 1;
+ g->default_advh = 0;
+ g->default_tsb = 0;
+ g->gd = NULL;
+ g->used_slot = NEW(8192, unsigned char);
+ memset(g->used_slot, 0, 8192);
+ tt_add_glyph(g, 0, 0);
+
+ return g;
+}
+
+void
+tt_build_finish (struct tt_glyphs *g)
+{
+ if (g) {
+ if (g->gd) {
+ USHORT idx;
+ for (idx = 0; idx < g->num_glyphs; idx++) {
+ if (g->gd[idx].data)
+ RELEASE(g->gd[idx].data);
+ }
+ RELEASE(g->gd);
+ }
+ if (g->used_slot)
+ RELEASE(g->used_slot);
+ RELEASE(g);
+ }
+}
+
+static int
+glyf_cmp (const void *v1, const void *v2)
+{
+ int cmp = 0;
+ struct tt_glyph_desc *sv1, *sv2;
+
+ sv1 = (struct tt_glyph_desc *) v1;
+ sv2 = (struct tt_glyph_desc *) v2;
+
+ if (sv1->gid == sv2->gid)
+ cmp = 0;
+ else if (sv1->gid < sv2->gid)
+ cmp = -1;
+ else
+ cmp = 1;
+
+ return cmp;
+}
+
+/*
+ * TrueType outline data.
+ */
+#define ARG_1_AND_2_ARE_WORDS (1 << 0)
+#define ARGS_ARE_XY_VALUES (1 << 1)
+#define ROUND_XY_TO_GRID (1 << 2)
+#define WE_HAVE_A_SCALE (1 << 3)
+#define RESERVED (1 << 4)
+#define MORE_COMPONENT (1 << 5)
+#define WE_HAVE_AN_X_AND_Y_SCALE (1 << 6)
+#define WE_HAVE_A_TWO_BY_TWO (1 << 7)
+#define WE_HAVE_INSTRUCTIONS (1 << 8)
+#define USE_MY_METRICS (1 << 9)
+
+int
+tt_build_tables (sfnt *sfont, struct tt_glyphs *g)
+{
+ char *hmtx_table_data = NULL, *loca_table_data = NULL;
+ char *glyf_table_data = NULL;
+ ULONG hmtx_table_size, loca_table_size, glyf_table_size;
+ /* some information available from other TrueType table */
+ struct tt_head_table *head = NULL;
+ struct tt_hhea_table *hhea = NULL;
+ struct tt_maxp_table *maxp = NULL;
+ struct tt_longMetrics *hmtx, *vmtx = NULL;
+ struct tt_os2__table *os2;
+ /* temp */
+ ULONG *location, offset;
+ long i;
+ USHORT *w_stat; /* Estimate most frequently appeared width */
+
+ ASSERT(g);
+
+ if (sfont->type != SFNT_TYPE_TRUETYPE &&
+ sfont->type != SFNT_TYPE_TTC)
+ TT_ERROR("Invalid font type");
+
+ if (g->num_glyphs > NUM_GLYPH_LIMIT)
+ TT_ERROR("Too many glyphs.");
+
+ /*
+ * Read head, hhea, maxp, loca:
+ *
+ * unitsPerEm --> head
+ * numHMetrics --> hhea
+ * indexToLocFormat --> head
+ * numGlyphs --> maxp
+ */
+ head = tt_read_head_table(sfont);
+ hhea = tt_read_hhea_table(sfont);
+ maxp = tt_read_maxp_table(sfont);
+
+ if (hhea->metricDataFormat != 0)
+ TT_ERROR("Unknown metricDataFormat.");
+
+ g->emsize = head->unitsPerEm;
+
+ sfnt_locate_table(sfont, "hmtx");
+ hmtx = tt_read_longMetrics(sfont, maxp->numGlyphs, hhea->numberOfHMetrics);
+
+ os2 = tt_read_os2__table(sfont);
+ if (os2) {
+ g->default_advh = os2->sTypoAscender - os2->sTypoDescender;
+ g->default_tsb = g->default_advh - os2->sTypoAscender;
+ }
+
+ if (sfnt_find_table_pos(sfont, "vmtx") > 0) {
+ struct tt_vhea_table *vhea;
+ vhea = tt_read_vhea_table(sfont);
+ sfnt_locate_table(sfont, "vmtx");
+ vmtx = tt_read_longMetrics(sfont, maxp->numGlyphs, vhea->numOfLongVerMetrics);
+ RELEASE(vhea);
+ } else {
+ vmtx = NULL;
+ }
+
+ sfnt_locate_table(sfont, "loca");
+ location = NEW(maxp->numGlyphs + 1, ULONG);
+ if (head->indexToLocFormat == 0) {
+ for (i = 0; i <= maxp->numGlyphs; i++)
+ location[i] = 2*((ULONG) sfnt_get_ushort(sfont));
+ } else if (head->indexToLocFormat == 1) {
+ for (i = 0; i <= maxp->numGlyphs; i++)
+ location[i] = sfnt_get_ulong(sfont);
+ } else {
+ TT_ERROR("Unknown IndexToLocFormat.");
+ }
+
+ w_stat = NEW(g->emsize+2, USHORT);
+ memset(w_stat, 0, sizeof(USHORT)*(g->emsize+2));
+ /*
+ * Read glyf table.
+ */
+ offset = sfnt_locate_table(sfont, "glyf");
+ /*
+ * The num_glyphs may grow when composite glyph is found.
+ * A component of glyph refered by a composite glyph is appended
+ * to used_glyphs if it is not already registered in used_glyphs.
+ * Glyph programs of composite glyphs are modified so that it
+ * correctly refer to new gid of their components.
+ */
+ for (i = 0; i < NUM_GLYPH_LIMIT; i++) {
+ USHORT gid; /* old gid */
+ ULONG loc, len;
+ BYTE *p, *endptr;
+ SHORT number_of_contours;
+
+ if (i >= g->num_glyphs) /* finished */
+ break;
+
+ gid = g->gd[i].ogid;
+ if (gid >= maxp->numGlyphs)
+ TT_ERROR("Invalid glyph index (gid %u)", gid);
+
+ loc = location[gid];
+ len = location[gid+1] - loc;
+ g->gd[i].advw = hmtx[gid].advance;
+ g->gd[i].lsb = hmtx[gid].sideBearing;
+ if (vmtx) {
+ g->gd[i].advh = vmtx[gid].advance;
+ g->gd[i].tsb = vmtx[gid].sideBearing;
+ } else {
+ g->gd[i].advh = g->default_advh;
+ g->gd[i].tsb = g->default_tsb;
+ }
+ g->gd[i].length = len;
+ g->gd[i].data = NULL;
+ if (g->gd[i].advw <= g->emsize) {
+ w_stat[g->gd[i].advw] += 1;
+ } else {
+ w_stat[g->emsize+1] += 1; /* larger than em */
+ }
+
+ if (len == 0) { /* Does not contains any data. */
+ continue;
+ } else if (len < 10) {
+ TT_ERROR("Invalid TrueType glyph data (gid %u).", gid);
+ }
+
+ g->gd[i].data = p = NEW(len, BYTE);
+ endptr = p + len;
+
+ sfnt_seek_set(sfont, offset+loc);
+ number_of_contours = sfnt_get_short(sfont);
+ p += sfnt_put_short(p, number_of_contours);
+
+ /* BoundingBox: FWord x 4 */
+ g->gd[i].llx = sfnt_get_short(sfont);
+ g->gd[i].lly = sfnt_get_short(sfont);
+ g->gd[i].urx = sfnt_get_short(sfont);
+ g->gd[i].ury = sfnt_get_short(sfont);
+ /* _FIXME_ */
+#if 1
+ if (!vmtx) /* vertOriginY == sTypeAscender */
+ g->gd[i].tsb = g->default_advh - g->default_tsb - g->gd[i].ury;
+#endif
+ p += sfnt_put_short(p, g->gd[i].llx);
+ p += sfnt_put_short(p, g->gd[i].lly);
+ p += sfnt_put_short(p, g->gd[i].urx);
+ p += sfnt_put_short(p, g->gd[i].ury);
+
+ /* Read evrything else. */
+ sfnt_read(p, len - 10, sfont);
+ /*
+ * Fix GIDs of composite glyphs.
+ */
+ if (number_of_contours < 0) {
+ USHORT flags, cgid, new_gid; /* flag, gid of a component */
+ do {
+ if (p >= endptr)
+ TT_ERROR("Invalid TrueType glyph data (gid %u): %u bytes", gid, (unsigned int)len);
+ /*
+ * Flags and gid of component glyph are both USHORT.
+ */
+ flags = ((*p) << 8)| *(p+1);
+ p += 2;
+ cgid = ((*p) << 8)| *(p+1);
+ if (cgid >= maxp->numGlyphs) {
+ TT_ERROR("Invalid gid (%u > %u) in composite glyph %u.", cgid, maxp->numGlyphs, gid);
+ }
+ new_gid = tt_find_glyph(g, cgid);
+ if (new_gid == 0) {
+ new_gid = tt_add_glyph(g, cgid, find_empty_slot(g));
+ }
+ p += sfnt_put_ushort(p, new_gid);
+ /*
+ * Just skip remaining part.
+ */
+ p += (flags & ARG_1_AND_2_ARE_WORDS) ? 4 : 2;
+ if (flags & WE_HAVE_A_SCALE) /* F2Dot14 */
+ p += 2;
+ else if (flags & WE_HAVE_AN_X_AND_Y_SCALE) /* F2Dot14 x 2 */
+ p += 4;
+ else if (flags & WE_HAVE_A_TWO_BY_TWO) /* F2Dot14 x 4 */
+ p += 8;
+ } while (flags & MORE_COMPONENT);
+ /*
+ * TrueType instructions comes here:
+ * length_of_instruction (ushort)
+ * instruction (byte * length_of_instruction)
+ */
+ }
+ }
+ RELEASE(location);
+ RELEASE(hmtx);
+ if (vmtx)
+ RELEASE(vmtx);
+
+ {
+ int max_count = -1;
+
+ g->dw = g->gd[0].advw;
+ for (i = 0; i < g->emsize + 1; i++) {
+ if (w_stat[i] > max_count) {
+ max_count = w_stat[i];
+ g->dw = i;
+ }
+ }
+ }
+ RELEASE(w_stat);
+
+ qsort(g->gd, g->num_glyphs, sizeof(struct tt_glyph_desc), glyf_cmp);
+ {
+ USHORT prev, last_advw;
+ char *p, *q;
+ int padlen, num_hm_known;
+
+ glyf_table_size = 0UL;
+ num_hm_known = 0;
+ last_advw = g->gd[g->num_glyphs - 1].advw;
+ for (i = g->num_glyphs - 1; i >= 0; i--) {
+ padlen = (g->gd[i].length % 4) ? (4 - (g->gd[i].length % 4)) : 0;
+ glyf_table_size += g->gd[i].length + padlen;
+ if (!num_hm_known && last_advw != g->gd[i].advw) {
+ hhea->numberOfHMetrics = g->gd[i].gid + 2;
+ num_hm_known = 1;
+ }
+ }
+ /* All advance widths are same. */
+ if (!num_hm_known) {
+ hhea->numberOfHMetrics = 1;
+ }
+ hmtx_table_size = hhea->numberOfHMetrics * 2 + (g->last_gid + 1) * 2;
+
+ /*
+ * Choosing short format does not always give good result
+ * when compressed. Sometimes increases size.
+ */
+ if (glyf_table_size < 0x20000UL) {
+ head->indexToLocFormat = 0;
+ loca_table_size = (g->last_gid + 2)*2;
+ } else {
+ head->indexToLocFormat = 1;
+ loca_table_size = (g->last_gid + 2)*4;
+ }
+
+ hmtx_table_data = p = NEW(hmtx_table_size, char);
+ loca_table_data = q = NEW(loca_table_size, char);
+ glyf_table_data = NEW(glyf_table_size, char);
+
+ offset = 0UL; prev = 0;
+ for (i = 0; i < g->num_glyphs; i++) {
+ long gap, j;
+ gap = (long) g->gd[i].gid - prev - 1;
+ for (j = 1; j <= gap; j++) {
+ if (prev + j == hhea->numberOfHMetrics - 1) {
+ p += sfnt_put_ushort(p, last_advw);
+ } else if (prev + j < hhea->numberOfHMetrics) {
+ p += sfnt_put_ushort(p, 0);
+ }
+ p += sfnt_put_short (p, 0);
+ if (head->indexToLocFormat == 0) {
+ q += sfnt_put_ushort(q, (USHORT) (offset/2));
+ } else {
+ q += sfnt_put_ulong(q, offset);
+ }
+ }
+ padlen = (g->gd[i].length % 4) ? (4 - (g->gd[i].length % 4)) : 0;
+ if (g->gd[i].gid < hhea->numberOfHMetrics) {
+ p += sfnt_put_ushort(p, g->gd[i].advw);
+ }
+ p += sfnt_put_short (p, g->gd[i].lsb);
+ if (head->indexToLocFormat == 0) {
+ q += sfnt_put_ushort(q, (USHORT) (offset/2));
+ } else {
+ q += sfnt_put_ulong(q, offset);
+ }
+ memset(glyf_table_data + offset, 0, g->gd[i].length + padlen);
+ memcpy(glyf_table_data + offset, g->gd[i].data, g->gd[i].length);
+ offset += g->gd[i].length + padlen;
+ prev = g->gd[i].gid;
+ /* free data here since it consume much memory */
+ RELEASE(g->gd[i].data);
+ g->gd[i].length = 0; g->gd[i].data = NULL;
+ }
+ if (head->indexToLocFormat == 0) {
+ q += sfnt_put_ushort(q, (USHORT) (offset/2));
+ } else {
+ q += sfnt_put_ulong(q, offset);
+ }
+
+ sfnt_set_table(sfont, "hmtx", (char *) hmtx_table_data, hmtx_table_size);
+ sfnt_set_table(sfont, "loca", (char *) loca_table_data, loca_table_size);
+ sfnt_set_table(sfont, "glyf", (char *) glyf_table_data, glyf_table_size);
+ }
+
+ head->checkSumAdjustment = 0;
+ maxp->numGlyphs = g->last_gid + 1;
+
+ /* TODO */
+ sfnt_set_table(sfont, "maxp", tt_pack_maxp_table(maxp), TT_MAXP_TABLE_SIZE);
+ sfnt_set_table(sfont, "hhea", tt_pack_hhea_table(hhea), TT_HHEA_TABLE_SIZE);
+ sfnt_set_table(sfont, "head", tt_pack_head_table(head), TT_HEAD_TABLE_SIZE);
+ RELEASE(maxp);
+ RELEASE(hhea);
+ RELEASE(head);
+ if (os2)
+ RELEASE(os2);
+
+ return 0;
+}
+
+int
+tt_get_metrics (sfnt *sfont, struct tt_glyphs *g)
+{
+ struct tt_head_table *head = NULL;
+ struct tt_hhea_table *hhea = NULL;
+ struct tt_maxp_table *maxp = NULL;
+ struct tt_longMetrics *hmtx, *vmtx = NULL;
+ struct tt_os2__table *os2;
+ /* temp */
+ ULONG *location, offset;
+ long i;
+ USHORT *w_stat;
+
+ ASSERT(g);
+
+ if (sfont == NULL ||
+#ifdef XETEX
+ sfont->ft_face == NULL
+#elif defined(pdfTeX)
+ sfont->buffer == NULL
+#else
+ sfont->stream == NULL
+#endif
+ )
+ TT_ERROR("File not opened.");
+
+ if (sfont->type != SFNT_TYPE_TRUETYPE &&
+ sfont->type != SFNT_TYPE_TTC)
+ TT_ERROR("Invalid font type");
+
+ /*
+ * Read head, hhea, maxp, loca:
+ *
+ * unitsPerEm --> head
+ * numHMetrics --> hhea
+ * indexToLocFormat --> head
+ * numGlyphs --> maxp
+ */
+ head = tt_read_head_table(sfont);
+ hhea = tt_read_hhea_table(sfont);
+ maxp = tt_read_maxp_table(sfont);
+
+ if (hhea->metricDataFormat != 0)
+ TT_ERROR("Unknown metricDataFormat.");
+
+ g->emsize = head->unitsPerEm;
+
+ sfnt_locate_table(sfont, "hmtx");
+ hmtx = tt_read_longMetrics(sfont, maxp->numGlyphs, hhea->numberOfHMetrics);
+
+ os2 = tt_read_os2__table(sfont);
+ g->default_advh = os2->sTypoAscender - os2->sTypoDescender;
+ g->default_tsb = g->default_advh - os2->sTypoAscender;
+
+ if (sfnt_find_table_pos(sfont, "vmtx") > 0) {
+ struct tt_vhea_table *vhea;
+ vhea = tt_read_vhea_table(sfont);
+ sfnt_locate_table(sfont, "vmtx");
+ vmtx = tt_read_longMetrics(sfont, maxp->numGlyphs, vhea->numOfLongVerMetrics);
+ RELEASE(vhea);
+ } else {
+ vmtx = NULL;
+ }
+
+ sfnt_locate_table(sfont, "loca");
+ location = NEW(maxp->numGlyphs + 1, ULONG);
+ if (head->indexToLocFormat == 0) {
+ for (i = 0; i <= maxp->numGlyphs; i++)
+ location[i] = 2*((ULONG) sfnt_get_ushort(sfont));
+ } else if (head->indexToLocFormat == 1) {
+ for (i = 0; i <= maxp->numGlyphs; i++)
+ location[i] = sfnt_get_ulong(sfont);
+ } else {
+ TT_ERROR("Unknown IndexToLocFormat.");
+ }
+
+ w_stat = NEW(g->emsize+2, USHORT);
+ memset(w_stat, 0, sizeof(USHORT)*(g->emsize+2));
+ /*
+ * Read glyf table.
+ */
+ offset = sfnt_locate_table(sfont, "glyf");
+ for (i = 0; i < g->num_glyphs; i++) {
+ USHORT gid; /* old gid */
+ ULONG loc, len;
+ SHORT number_of_contours;
+
+ gid = g->gd[i].ogid;
+ if (gid >= maxp->numGlyphs)
+ TT_ERROR("Invalid glyph index (gid %u)", gid);
+
+ loc = location[gid];
+ len = location[gid+1] - loc;
+ g->gd[i].advw = hmtx[gid].advance;
+ g->gd[i].lsb = hmtx[gid].sideBearing;
+ if (vmtx) {
+ g->gd[i].advh = vmtx[gid].advance;
+ g->gd[i].tsb = vmtx[gid].sideBearing;
+ } else {
+ g->gd[i].advh = g->default_advh;
+ g->gd[i].tsb = g->default_tsb;
+ }
+ g->gd[i].length = len;
+ g->gd[i].data = NULL;
+
+ if (g->gd[i].advw <= g->emsize) {
+ w_stat[g->gd[i].advw] += 1;
+ } else {
+ w_stat[g->emsize+1] += 1; /* larger than em */
+ }
+
+ if (len == 0) { /* Does not contains any data. */
+ continue;
+ } else if (len < 10) {
+ TT_ERROR("Invalid TrueType glyph data (gid %u).", gid);
+ }
+
+ sfnt_seek_set(sfont, offset+loc);
+ number_of_contours = sfnt_get_short(sfont);
+
+ /* BoundingBox: FWord x 4 */
+ g->gd[i].llx = sfnt_get_short(sfont);
+ g->gd[i].lly = sfnt_get_short(sfont);
+ g->gd[i].urx = sfnt_get_short(sfont);
+ g->gd[i].ury = sfnt_get_short(sfont);
+ /* _FIXME_ */
+#if 1
+ if (!vmtx) /* vertOriginY == sTypeAscender */
+ g->gd[i].tsb = g->default_advh - g->default_tsb - g->gd[i].ury;
+#endif
+ }
+ RELEASE(location);
+ RELEASE(hmtx);
+ RELEASE(maxp);
+ RELEASE(hhea);
+ RELEASE(head);
+ RELEASE(os2);
+
+ if (vmtx)
+ RELEASE(vmtx);
+
+ {
+ int max_count = -1;
+
+ g->dw = g->gd[0].advw;
+ for (i = 0; i < g->emsize + 1; i++) {
+ if (w_stat[i] > max_count) {
+ max_count = w_stat[i];
+ g->dw = i;
+ }
+ }
+ }
+ RELEASE(w_stat);
+
+
+ return 0;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/tt_glyf.h b/Build/source/texk/web2c/luatexdir/font/tt_glyf.h
new file mode 100644
index 00000000000..cf33af6733f
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/tt_glyf.h
@@ -0,0 +1,60 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/tt_glyf.h,v 1.1 2004/09/11 14:50:29 hirata Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+#ifndef _TT_GLYF_H_
+#define _TT_GLYF_H_
+
+struct tt_glyph_desc
+{
+ USHORT gid;
+ USHORT ogid; /* GID in original font */
+ USHORT advw, advh;
+ SHORT lsb, tsb;
+ SHORT llx, lly, urx, ury;
+ ULONG length;
+ BYTE *data;
+};
+
+struct tt_glyphs
+{
+ USHORT num_glyphs;
+ USHORT max_glyphs;
+ USHORT last_gid;
+ USHORT emsize;
+ USHORT dw; /* optimal value for DW */
+ USHORT default_advh; /* default value */
+ SHORT default_tsb; /* default value */
+ struct tt_glyph_desc *gd;
+ unsigned char *used_slot;
+};
+
+extern struct tt_glyphs *tt_build_init (void);
+extern void tt_build_finish (struct tt_glyphs *g);
+
+extern USHORT tt_add_glyph (struct tt_glyphs *g, USHORT gid, USHORT new_gid);
+extern USHORT tt_get_index (struct tt_glyphs *g, USHORT gid);
+extern USHORT tt_find_glyph (struct tt_glyphs *g, USHORT gid);
+
+extern int tt_build_tables (sfnt *sfont, struct tt_glyphs *g);
+extern int tt_get_metrics (sfnt *sfont, struct tt_glyphs *g);
+
+#endif /* _TT_GLYF_H_ */
diff --git a/Build/source/texk/web2c/luatexdir/font/tt_table.c b/Build/source/texk/web2c/luatexdir/font/tt_table.c
new file mode 100644
index 00000000000..4f82552d9df
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/tt_table.c
@@ -0,0 +1,483 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/tt_table.c,v 1.7 2004/09/11 14:50:29 hirata Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+#include <stdio.h>
+
+#ifndef pdfTeX
+#include "system.h"
+#include "error.h"
+#include "mem.h"
+#include "mfileio.h"
+#else
+extern void pdftex_fail (const char *fmt, ...); /* utils.c */
+#endif
+
+#include "sfnt.h"
+#include "tt_table.h"
+
+/*
+ tables contains information refered by other tables
+ maxp->numGlyphs, etc --> loca, etc
+ hhea->numberOfHMetrics --> hmtx
+ head->indexToLocFormat --> loca
+ head->glyphDataFormat --> glyf
+*/
+
+char *tt_pack_head_table (struct tt_head_table *table)
+{
+ int i;
+ char *p, *data;
+
+ if (table == NULL)
+ TT_ERROR("passed NULL pointer\n");
+
+ p = data = NEW(TT_HEAD_TABLE_SIZE, char);
+ p += sfnt_put_ulong(p, table->version);
+ p += sfnt_put_ulong(p, table->fontRevision);
+ p += sfnt_put_ulong(p, table->checkSumAdjustment);
+ p += sfnt_put_ulong(p, table->magicNumber);
+ p += sfnt_put_ushort(p, table->flags);
+ p += sfnt_put_ushort(p, table->unitsPerEm);
+ for (i=0; i<8; i++) {
+ *(p++) = (table->created)[i];
+ }
+ for (i=0; i<8; i++) {
+ *(p++) = (table->modified)[i];
+ }
+ p += sfnt_put_short(p, table->xMin);
+ p += sfnt_put_short(p, table->yMin);
+ p += sfnt_put_short(p, table->xMax);
+ p += sfnt_put_short(p, table->yMax);
+ p += sfnt_put_ushort(p, table->macStyle);
+ p += sfnt_put_ushort(p, table->lowestRecPPEM);
+ p += sfnt_put_short(p, table->fontDirectionHint);
+ p += sfnt_put_short(p, table->indexToLocFormat);
+ p += sfnt_put_short(p, table->glyphDataFormat);
+
+ return data;
+}
+
+struct tt_head_table *tt_read_head_table (sfnt *sfont)
+{
+ int i;
+ struct tt_head_table *table = NULL;
+
+ table = NEW(1, struct tt_head_table);
+
+ sfnt_locate_table(sfont, "head");
+
+ table->version = sfnt_get_ulong(sfont);
+ table->fontRevision = sfnt_get_ulong(sfont);
+ table->checkSumAdjustment = sfnt_get_ulong(sfont);
+ table->magicNumber = sfnt_get_ulong(sfont);
+ table->flags = sfnt_get_ushort(sfont);
+ table->unitsPerEm = sfnt_get_ushort(sfont);
+ for (i=0; i<8; i++) {
+ (table->created)[i] = sfnt_get_byte (sfont);
+ }
+ for (i=0; i<8; i++) {
+ (table->modified)[i] = sfnt_get_byte (sfont);
+ }
+ table->xMin = sfnt_get_short(sfont);
+ table->yMin = sfnt_get_short(sfont);
+ table->xMax = sfnt_get_short(sfont);
+ table->yMax = sfnt_get_short(sfont);
+ table->macStyle = sfnt_get_short(sfont);
+ table->lowestRecPPEM = sfnt_get_short(sfont);
+ table->fontDirectionHint = sfnt_get_short(sfont);
+ table->indexToLocFormat = sfnt_get_short(sfont);
+ table->glyphDataFormat = sfnt_get_short(sfont);
+
+ return table;
+}
+
+char *tt_pack_maxp_table (struct tt_maxp_table *table)
+{
+ char *p, *data;
+
+ p = data = NEW(TT_MAXP_TABLE_SIZE, char);
+ p += sfnt_put_ulong(p, table->version);
+ p += sfnt_put_ushort(p, table->numGlyphs);
+ p += sfnt_put_ushort(p, table->maxPoints);
+ p += sfnt_put_ushort(p, table->maxContours);
+ p += sfnt_put_ushort(p, table->maxComponentPoints);
+ p += sfnt_put_ushort(p, table->maxComponentContours);
+ p += sfnt_put_ushort(p, table->maxZones);
+ p += sfnt_put_ushort(p, table->maxTwilightPoints);
+ p += sfnt_put_ushort(p, table->maxStorage);
+ p += sfnt_put_ushort(p, table->maxFunctionDefs);
+ p += sfnt_put_ushort(p, table->maxInstructionDefs);
+ p += sfnt_put_ushort(p, table->maxStackElements);
+ p += sfnt_put_ushort(p, table->maxSizeOfInstructions);
+ p += sfnt_put_ushort(p, table->maxComponentElements);
+ p += sfnt_put_ushort(p, table->maxComponentDepth);
+
+ return data;
+}
+
+struct tt_maxp_table *tt_read_maxp_table (sfnt *sfont)
+{
+ struct tt_maxp_table *table = NULL;
+
+ table = NEW(1, struct tt_maxp_table);
+
+ sfnt_locate_table(sfont, "maxp");
+ table->version = sfnt_get_ulong(sfont);
+ table->numGlyphs = sfnt_get_ushort(sfont);
+ table->maxPoints = sfnt_get_ushort(sfont);
+ table->maxContours = sfnt_get_ushort(sfont);
+ table->maxComponentPoints = sfnt_get_ushort(sfont);
+ table->maxComponentContours = sfnt_get_ushort(sfont);
+ table->maxZones = sfnt_get_ushort(sfont);
+ table->maxTwilightPoints = sfnt_get_ushort(sfont);
+ table->maxStorage = sfnt_get_ushort(sfont);
+ table->maxFunctionDefs = sfnt_get_ushort(sfont);
+ table->maxInstructionDefs = sfnt_get_ushort(sfont);
+ table->maxStackElements = sfnt_get_ushort(sfont);
+ table->maxSizeOfInstructions = sfnt_get_ushort(sfont);
+ table->maxComponentElements = sfnt_get_ushort(sfont);
+ table->maxComponentDepth = sfnt_get_ushort(sfont);
+
+ return table;
+}
+
+char *tt_pack_hhea_table (struct tt_hhea_table *table)
+{
+ int i;
+ char *p, *data;
+
+ p = data = NEW(TT_HHEA_TABLE_SIZE, char);
+ p += sfnt_put_ulong(p, table->version);
+ p += sfnt_put_short(p, table->Ascender);
+ p += sfnt_put_short(p, table->Descender);
+ p += sfnt_put_short(p, table->LineGap);
+ p += sfnt_put_ushort(p, table->advanceWidthMax);
+ p += sfnt_put_short(p, table->minLeftSideBearing);
+ p += sfnt_put_short(p, table->minRightSideBearing);
+ p += sfnt_put_short(p, table->xMaxExtent);
+ p += sfnt_put_short(p, table->caretSlopeRise);
+ p += sfnt_put_short(p, table->caretSlopeRun);
+ for (i = 0; i < 5; i++) {
+ p += sfnt_put_short(p, table->reserved[i]);
+ }
+ p += sfnt_put_short(p, table->metricDataFormat);
+ p += sfnt_put_ushort(p, table->numberOfHMetrics);
+
+ return data;
+}
+
+struct tt_hhea_table *
+tt_read_hhea_table (sfnt *sfont)
+{
+ int i;
+ struct tt_hhea_table *table = NULL;
+
+ table = NEW(1, struct tt_hhea_table);
+
+ sfnt_locate_table(sfont, "hhea");
+ table->version = sfnt_get_ulong(sfont);
+ table->Ascender = sfnt_get_short (sfont);
+ table->Descender = sfnt_get_short(sfont);
+ table->LineGap = sfnt_get_short(sfont);
+ table->advanceWidthMax = sfnt_get_ushort(sfont);
+ table->minLeftSideBearing = sfnt_get_short(sfont);
+ table->minRightSideBearing = sfnt_get_short(sfont);
+ table->xMaxExtent = sfnt_get_short(sfont);
+ table->caretSlopeRise = sfnt_get_short(sfont);
+ table->caretSlopeRun = sfnt_get_short(sfont);
+ for(i = 0; i < 5; i++) {
+ table->reserved[i] = sfnt_get_short(sfont);
+ }
+ table->metricDataFormat = sfnt_get_short(sfont);
+ if (table->metricDataFormat != 0)
+ TT_ERROR("unknown metricDaraFormat");
+ table->numberOfHMetrics = sfnt_get_ushort(sfont);
+
+ return table;
+}
+
+/* vhea */
+char *
+tt_pack_vhea_table (struct tt_vhea_table *table)
+{
+ int i;
+ char *p, *data;
+
+ p = data = NEW(TT_VHEA_TABLE_SIZE, char);
+ p += sfnt_put_ulong(p, table->version);
+ p += sfnt_put_short(p, table->vertTypoAscender);
+ p += sfnt_put_short(p, table->vertTypoDescender);
+ p += sfnt_put_short(p, table->vertTypoLineGap);
+ p += sfnt_put_short(p, table->advanceHeightMax); /* ushort ? */
+ p += sfnt_put_short(p, table->minTopSideBearing);
+ p += sfnt_put_short(p, table->minBottomSideBearing);
+ p += sfnt_put_short(p, table->yMaxExtent);
+ p += sfnt_put_short(p, table->caretSlopeRise);
+ p += sfnt_put_short(p, table->caretSlopeRun);
+ p += sfnt_put_short(p, table->caretOffset);
+ for(i = 0; i < 5; i++) {
+ p += sfnt_put_short(p, table->reserved[i]);
+ }
+ p += sfnt_put_ushort(p, table->numOfLongVerMetrics);
+
+ return data;
+}
+
+struct tt_vhea_table *tt_read_vhea_table (sfnt *sfont)
+{
+ int i;
+ struct tt_vhea_table *table = NULL;
+
+ table = NEW(1, struct tt_vhea_table);
+
+ sfnt_locate_table(sfont, "vhea");
+ table->version = sfnt_get_ulong(sfont);
+ table->vertTypoAscender = sfnt_get_short (sfont);
+ table->vertTypoDescender = sfnt_get_short(sfont);
+ table->vertTypoLineGap = sfnt_get_short(sfont);
+ table->advanceHeightMax = sfnt_get_short(sfont); /* ushort ? */
+ table->minTopSideBearing = sfnt_get_short(sfont);
+ table->minBottomSideBearing = sfnt_get_short(sfont);
+ table->yMaxExtent = sfnt_get_short(sfont);
+ table->caretSlopeRise = sfnt_get_short(sfont);
+ table->caretSlopeRun = sfnt_get_short(sfont);
+ table->caretOffset = sfnt_get_short(sfont);
+ for(i=0;i<5;i++) {
+ (table->reserved)[i] = sfnt_get_short(sfont);
+ }
+ table->numOfLongVerMetrics = sfnt_get_ushort(sfont);
+
+ return table;
+}
+
+
+struct tt_VORG_table *
+tt_read_VORG_table (sfnt *sfont)
+{
+ struct tt_VORG_table *vorg;
+ ULONG offset;
+ USHORT i;
+
+ offset = sfnt_find_table_pos(sfont, "VORG");
+
+ if (offset > 0) {
+ vorg = NEW(1, struct tt_VORG_table);
+
+ sfnt_locate_table(sfont, "VORG");
+ if (sfnt_get_ushort(sfont) != 1 ||
+ sfnt_get_ushort(sfont) != 0)
+ TT_ERROR("Unsupported VORG version.");
+
+ vorg->defaultVertOriginY = sfnt_get_short(sfont);
+ vorg->numVertOriginYMetrics = sfnt_get_ushort(sfont);
+ vorg->vertOriginYMetrics = NEW(vorg->numVertOriginYMetrics,
+ struct tt_vertOriginYMetrics);
+ /*
+ * The vertOriginYMetrics array must be sorted in increasing
+ * glyphIndex order.
+ */
+ for (i = 0;
+ i < vorg->numVertOriginYMetrics; i++) {
+ vorg->vertOriginYMetrics[i].glyphIndex = sfnt_get_ushort(sfont);
+ vorg->vertOriginYMetrics[i].vertOriginY = sfnt_get_short(sfont);
+ }
+ } else {
+ vorg = NULL;
+ }
+
+ return vorg;
+}
+
+/*
+ * hmtx and vmtx
+ *
+ * Reading/writing hmtx and vmtx depend on other tables, maxp and hhea/vhea.
+ */
+
+struct tt_longMetrics *
+tt_read_longMetrics (sfnt *sfont, USHORT numGlyphs, USHORT numLongMetrics)
+{
+ struct tt_longMetrics *m;
+ USHORT gid, last_adv = 0;
+
+ m = NEW(numGlyphs, struct tt_longMetrics);
+ for (gid = 0; gid < numGlyphs; gid++) {
+ if (gid < numLongMetrics)
+ last_adv = sfnt_get_ushort(sfont);
+ m[gid].sideBearing = sfnt_get_short(sfont);
+ m[gid].advance = last_adv;
+ }
+
+ return m;
+}
+
+/* OS/2 table */
+/* this table may not exist */
+struct tt_os2__table *
+tt_read_os2__table (sfnt *sfont)
+{
+ struct tt_os2__table *table = NULL;
+ int i;
+
+ if (sfnt_find_table_pos(sfont, "OS/2") == 0)
+ return NULL;
+
+ sfnt_locate_table(sfont, "OS/2");
+
+ table = NEW(1, struct tt_os2__table);
+
+ table->version = sfnt_get_ushort(sfont);
+ table->xAvgCharWidth = sfnt_get_short(sfont);
+ table->usWeightClass = sfnt_get_ushort(sfont);
+ table->usWidthClass = sfnt_get_ushort(sfont);
+ table->fsType = sfnt_get_short(sfont);
+ table->ySubscriptXSize = sfnt_get_short(sfont);
+ table->ySubscriptYSize = sfnt_get_short(sfont);
+ table->ySubscriptXOffset = sfnt_get_short(sfont);
+ table->ySubscriptYOffset = sfnt_get_short(sfont);
+ table->ySuperscriptXSize = sfnt_get_short(sfont);
+ table->ySuperscriptYSize = sfnt_get_short(sfont);
+ table->ySuperscriptXOffset = sfnt_get_short(sfont);
+ table->ySuperscriptYOffset = sfnt_get_short(sfont);
+ table->yStrikeoutSize = sfnt_get_short(sfont);
+ table->yStrikeoutPosition = sfnt_get_short(sfont);
+ table->sFamilyClass = sfnt_get_short(sfont);
+ for (i = 0; i < 10; i++) {
+ table->panose[i] = sfnt_get_byte(sfont);
+ }
+ table->ulUnicodeRange1 = sfnt_get_ulong(sfont);
+ table->ulUnicodeRange2 = sfnt_get_ulong(sfont);
+ table->ulUnicodeRange3 = sfnt_get_ulong(sfont);
+ table->ulUnicodeRange4 = sfnt_get_ulong(sfont);
+ for (i = 0; i < 4; i++) {
+ table->achVendID[i] = sfnt_get_char(sfont);
+ }
+ table->fsSelection = sfnt_get_ushort(sfont);
+ table->usFirstCharIndex = sfnt_get_ushort(sfont);
+ table->usLastCharIndex = sfnt_get_ushort(sfont);
+ table->sTypoAscender = sfnt_get_short(sfont);
+ table->sTypoDescender = sfnt_get_short(sfont);
+ table->sTypoLineGap = sfnt_get_short(sfont);
+ table->usWinAscent = sfnt_get_ushort(sfont);
+ table->usWinDescent = sfnt_get_ushort(sfont);
+ table->ulCodePageRange1 = sfnt_get_ulong(sfont);
+ table->ulCodePageRange2 = sfnt_get_ulong(sfont);
+ if (table->version == 0x0002) {
+ table->sxHeight = sfnt_get_short(sfont);
+ table->sCapHeight = sfnt_get_short(sfont);
+ table->usDefaultChar = sfnt_get_ushort(sfont);
+ table->usBreakChar = sfnt_get_ushort(sfont);
+ table->usMaxContext = sfnt_get_ushort(sfont);
+ }
+
+ return table;
+}
+
+USHORT
+tt_get_name (sfnt *sfont, char *dest, USHORT destlen,
+ USHORT plat_id, USHORT enco_id,
+ USHORT lang_id, USHORT name_id)
+{
+ USHORT length = 0;
+ USHORT num_names, string_offset;
+ ULONG name_offset;
+ int i;
+
+ name_offset = sfnt_locate_table (sfont, "name");
+
+ if (sfnt_get_ushort(sfont))
+ TT_ERROR ("Expecting zero");
+
+ num_names = sfnt_get_ushort(sfont);
+ string_offset = sfnt_get_ushort(sfont);
+ for (i=0;i<num_names;i++) {
+ USHORT p_id, e_id, n_id, l_id;
+ USHORT offset;
+
+ p_id = sfnt_get_ushort(sfont);
+ e_id = sfnt_get_ushort(sfont);
+ l_id = sfnt_get_ushort(sfont);
+ n_id = sfnt_get_ushort(sfont);
+ length = sfnt_get_ushort(sfont);
+ offset = sfnt_get_ushort(sfont);
+ /* language ID value 0xffffu for `accept any language ID' */
+ if ((p_id == plat_id) && (e_id == enco_id) &&
+ (lang_id == 0xffffu || l_id == lang_id) && (n_id == name_id)) {
+ if (length > destlen - 1) {
+ fprintf(stderr, "\n** Notice: Name string too long. Truncating **\n");
+ length = destlen - 1;
+ }
+ sfnt_seek_set (sfont, name_offset+string_offset+offset);
+ sfnt_read((unsigned char*)dest, length, sfont);
+ dest[length] = '\0';
+ break;
+ }
+ }
+ if (i == num_names) {
+ length = 0;
+ }
+
+ return length;
+}
+
+USHORT
+tt_get_ps_fontname (sfnt *sfont, char *dest, USHORT destlen)
+{
+ USHORT namelen = 0;
+
+#ifdef XETEX
+
+ const char* name = FT_Get_Postscript_Name(sfont->ft_face);
+ namelen = strlen(name);
+ if (namelen > destlen - 1) {
+ strncpy(dest, name, destlen - 1);
+ dest[destlen] = 0;
+ }
+ else
+ strcpy(dest, name);
+
+#else
+
+ /* First try Mac-Roman PS name and then Win-Unicode PS name */
+ if ((namelen = tt_get_name(sfont, dest, destlen, 1, 0, 0, 6)) != 0 ||
+ (namelen = tt_get_name(sfont, dest, destlen, 3, 1, 0x409u, 6)) != 0 ||
+ (namelen = tt_get_name(sfont, dest, destlen, 3, 5, 0x412u, 6)) != 0)
+ return namelen;
+
+ fprintf(stderr, "\n** Warning: No valid PostScript name available **\n");
+ /*
+ Wrokaround for some bad TTfonts:
+ Language ID value 0xffffu for `accept any language ID'
+ */
+ if ((namelen = tt_get_name(sfont, dest, destlen, 1, 0, 0xffffu, 6)) == 0) {
+ /*
+ Finally falling back to Mac Roman name field.
+ Warning: Some bad Japanese TTfonts using SJIS encoded string in the
+ Mac Roman name field.
+ */
+ namelen = tt_get_name(sfont, dest, destlen, 1, 0, 0, 1);
+ }
+
+#endif
+
+ return namelen;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/tt_table.h b/Build/source/texk/web2c/luatexdir/font/tt_table.h
new file mode 100644
index 00000000000..ffb2c5b8f45
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/tt_table.h
@@ -0,0 +1,193 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/tt_table.h,v 1.6 2004/09/11 14:50:29 hirata Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+#ifndef _TT_TABLE_H_
+#define _TT_TABLE_H_
+
+#include "sfnt.h"
+
+#define TT_HEAD_TABLE_SIZE 54UL
+#define TT_MAXP_TABLE_SIZE 32UL
+#define TT_HHEA_TABLE_SIZE 36UL
+#define TT_VHEA_TABLE_SIZE 36UL
+
+struct tt_head_table
+{
+ Fixed version;
+ Fixed fontRevision;
+ ULONG checkSumAdjustment;
+ ULONG magicNumber;
+ USHORT flags;
+ USHORT unitsPerEm;
+ BYTE created[8];
+ BYTE modified[8];
+ FWord xMin, yMin, xMax, yMax;
+ USHORT macStyle;
+ USHORT lowestRecPPEM;
+ SHORT fontDirectionHint;
+ SHORT indexToLocFormat;
+ SHORT glyphDataFormat;
+};
+
+struct tt_hhea_table
+{
+ Fixed version;
+ FWord Ascender;
+ FWord Descender;
+ FWord LineGap;
+ uFWord advanceWidthMax;
+ FWord minLeftSideBearing;
+ FWord minRightSideBearing;
+ FWord xMaxExtent;
+ SHORT caretSlopeRise;
+ SHORT caretSlopeRun;
+ SHORT reserved[5]; /* set to 0 */
+ SHORT metricDataFormat;
+ USHORT numberOfHMetrics;
+};
+
+struct tt_vhea_table
+{
+ Fixed version;
+ SHORT vertTypoAscender; /* v.1.1 name */
+ SHORT vertTypoDescender; /* v.1.1 name */
+ SHORT vertTypoLineGap; /* v.1.1 name */
+ SHORT advanceHeightMax;
+ SHORT minTopSideBearing;
+ SHORT minBottomSideBearing;
+ SHORT yMaxExtent;
+ SHORT caretSlopeRise;
+ SHORT caretSlopeRun;
+ SHORT caretOffset;
+ SHORT reserved[5]; /* set to 0 */
+ USHORT numOfLongVerMetrics;
+};
+
+struct tt_maxp_table
+{
+ Fixed version;
+ USHORT numGlyphs;
+ USHORT maxPoints;
+ USHORT maxContours;
+ USHORT maxComponentPoints;
+ USHORT maxComponentContours;
+ USHORT maxZones;
+ USHORT maxTwilightPoints;
+ USHORT maxStorage;
+ USHORT maxFunctionDefs;
+ USHORT maxInstructionDefs;
+ USHORT maxStackElements;
+ USHORT maxSizeOfInstructions;
+ USHORT maxComponentElements;
+ USHORT maxComponentDepth;
+};
+
+struct tt_os2__table
+{
+ USHORT version; /* 0x0001 or 0x0002 */
+ SHORT xAvgCharWidth;
+ USHORT usWeightClass;
+ USHORT usWidthClass;
+ SHORT fsType; /* if (faType & 0x08) editable_embedding */
+ SHORT ySubscriptXSize;
+ SHORT ySubscriptYSize;
+ SHORT ySubscriptXOffset;
+ SHORT ySubscriptYOffset;
+ SHORT ySuperscriptXSize;
+ SHORT ySuperscriptYSize;
+ SHORT ySuperscriptXOffset;
+ SHORT ySuperscriptYOffset;
+ SHORT yStrikeoutSize;
+ SHORT yStrikeoutPosition;
+ SHORT sFamilyClass;
+ BYTE panose[10];
+ ULONG ulUnicodeRange1;
+ ULONG ulUnicodeRange2;
+ ULONG ulUnicodeRange3;
+ ULONG ulUnicodeRange4;
+ ICHAR achVendID[4];
+ USHORT fsSelection;
+ USHORT usFirstCharIndex;
+ USHORT usLastCharIndex;
+ SHORT sTypoAscender; /* TTF spec. from MS is wrong */
+ SHORT sTypoDescender; /* TTF spec. from MS is wrong */
+ SHORT sTypoLineGap; /* TTF spec. from MS is wrong */
+ USHORT usWinAscent;
+ USHORT usWinDescent;
+ ULONG ulCodePageRange1;
+ ULONG ulCodePageRange2;
+ /* version 0x0002 */
+ SHORT sxHeight;
+ SHORT sCapHeight;
+ USHORT usDefaultChar;
+ USHORT usBreakChar;
+ USHORT usMaxContext;
+};
+
+struct tt_vertOriginYMetrics {
+ USHORT glyphIndex;
+ SHORT vertOriginY;
+};
+
+struct tt_VORG_table {
+ SHORT defaultVertOriginY;
+ USHORT numVertOriginYMetrics;
+ struct tt_vertOriginYMetrics *vertOriginYMetrics;
+};
+
+/* hmtx and vmtx */
+struct tt_longMetrics
+{
+ USHORT advance;
+ SHORT sideBearing;
+};
+
+
+/* head, hhea, maxp */
+extern char *tt_pack_head_table (struct tt_head_table *table);
+extern struct tt_head_table *tt_read_head_table (sfnt *sfont);
+extern char *tt_pack_hhea_table (struct tt_hhea_table *table);
+extern struct tt_hhea_table *tt_read_hhea_table (sfnt *sfont);
+extern char *tt_pack_maxp_table (struct tt_maxp_table *table);
+extern struct tt_maxp_table *tt_read_maxp_table (sfnt *sfont);
+
+/* vhea */
+extern char *tt_pack_vhea_table (struct tt_vhea_table *table);
+extern struct tt_vhea_table *tt_read_vhea_table (sfnt *sfont);
+
+/* VORG */
+extern struct tt_VORG_table *tt_read_VORG_table (sfnt *sfont);
+
+/* hmtx and vmtx */
+extern struct tt_longMetrics *tt_read_longMetrics (sfnt *sfont,
+ USHORT numGlyphs, USHORT numLongMetrics);
+
+/* OS/2 table */
+extern struct tt_os2__table *tt_read_os2__table (sfnt *sfont);
+
+/* name table */
+extern USHORT tt_get_name (sfnt *sfont, char *dest, USHORT destlen,
+ USHORT plat_id, USHORT enco_id,
+ USHORT lang_id, USHORT name_id);
+extern USHORT tt_get_ps_fontname (sfnt *sfont, char *dest, USHORT destlen);
+
+#endif /* _TT_TABLE_H_ */
diff --git a/Build/source/texk/web2c/luatexdir/font/vfovf.c b/Build/source/texk/web2c/luatexdir/font/vfovf.c
new file mode 100644
index 00000000000..0f23cb07b94
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/vfovf.c
@@ -0,0 +1,1349 @@
+/*
+Copyright (c) 1996-2006 Taco Hoekwater <taco@luatex.org>
+
+This file is part of LuaTeX.
+
+LuaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+LuaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with LuaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: vfovf.c 1022 2008-02-14 11:49:30Z taco $
+*/
+
+#include "ptexlib.h"
+
+#include "luatex-api.h"
+
+/* this is a hack! */
+#define font_max 5000
+
+#define set_char_0 0 /* typeset character 0 and move right */
+#define set1 128 /* typeset a character and move right */
+#define set2 129 /* typeset a character and move right */
+#define set3 130 /* typeset a character and move right */
+#define set4 131 /* typeset a character and move right */
+#define set_rule 132 /* typeset a rule and move right */
+#define put1 133 /* typeset a character without moving */
+#define put2 134 /* typeset a character without moving */
+#define put3 135 /* typeset a character without moving */
+#define put4 136 /* typeset a character without moving */
+#define put_rule 137 /* typeset a rule */
+#define nop 138 /* no operation */
+#define bop 139 /* beginning of page */
+#define eop 140 /* ending of page */
+#define push 141 /* save the current positions */
+#define pop 142 /* restore previous positions */
+#define right1 143 /* move right */
+#define right2 144 /* move right */
+#define right3 145 /* move right */
+#define right4 146 /* move right, 4 bytes */
+#define w0 147 /* move right by |w| */
+#define w1 148 /* move right and set |w| */
+#define w2 149 /* move right and set |w| */
+#define w3 150 /* move right and set |w| */
+#define w4 151 /* move right and set |w| */
+#define x0 152 /* move right by |x| */
+#define x1 153 /* move right and set |x| */
+#define x2 154 /* move right and set |x| */
+#define x3 155 /* move right and set |x| */
+#define x4 156 /* move right and set |x| */
+#define down1 157 /* move down */
+#define down2 158 /* move down */
+#define down3 159 /* move down */
+#define down4 160 /* move down, 4 bytes */
+#define y0 161 /* move down by |y| */
+#define y1 162 /* move down and set |y| */
+#define y2 163 /* move down and set |y| */
+#define y3 164 /* move down and set |y| */
+#define y4 165 /* move down and set |y| */
+#define z0 166 /* move down by |z| */
+#define z1 167 /* move down and set |z| */
+#define z2 168 /* move down and set |z| */
+#define z3 169 /* move down and set |z| */
+#define z4 170 /* move down and set |z| */
+#define fnt_num_0 171 /* set current font to 0 */
+#define fnt1 235 /* set current font */
+#define fnt2 236 /* set current font */
+#define fnt3 237 /* set current font */
+#define fnt4 238 /* set current font */
+#define xxx1 239 /* extension to DVI primitives */
+#define xxx2 240 /* extension to DVI primitives */
+#define xxx3 241 /* extension to DVI primitives */
+#define xxx4 242 /* potentially long extension to DVI primitives */
+#define fnt_def1 243 /* define the meaning of a font number */
+#define pre 247 /* preamble */
+#define post 248 /* postamble beginning */
+#define post_post 249 /* postamble ending */
+#define yyy1 250 /* PDF literal text */
+#define yyy2 251 /* PDF literal text */
+#define yyy3 252 /* PDF literal text */
+#define yyy4 253 /* PDF literal text */
+
+#define null_font 0
+
+#define long_char 242 /* \.{VF} command for general character packet */
+#define vf_id 202 /* identifies \.{VF} files */
+
+/* go out \.{VF} processing with an error message */
+#define bad_vf(a) { xfree(vf_buffer); print_nlp(); \
+ print_string("Error in processing VF font ("); \
+ print_string(font_name(f)); \
+ print_string(".vf): "); \
+ print_string(a); \
+ print_string(", virtual font will be ignored"); \
+ print_ln(); return; }
+
+#define lua_bad_vf(a) { xfree(vf_buffer); \
+ lua_settop(L,s_top); \
+ lua_pushnil(L); \
+ lua_pushstring(L,a); \
+ return 2; }
+
+#define tmp_b0 tmp_w.qqqq.b0
+#define tmp_b1 tmp_w.qqqq.b1
+#define tmp_b2 tmp_w.qqqq.b2
+#define tmp_b3 tmp_w.qqqq.b3
+#define tmp_int tmp_w.cint
+
+#define vf_stack_size 100 /* \.{DVI} files shouldn't |push| beyond this depth */
+
+typedef unsigned char vf_stack_index ; /* an index into the stack */
+
+typedef struct vf_stack_record {
+ scaled stack_w, stack_x, stack_y, stack_z;
+} vf_stack_record;
+
+boolean auto_expand_vf(internal_font_number f); /* forward */
+
+/* get a byte from\.{VF} file */
+
+#define vf_byte(a) { real_eight_bits vf_tmp_b; \
+ if (vf_cur>=vf_size) { \
+ pdftex_fail("unexpected eof on virtual font"); \
+ } \
+ vf_tmp_b = vf_buffer[vf_cur++] ; a = vf_tmp_b; }
+
+
+#define vf_replace_z() { \
+ vf_alpha=16; \
+ while (vf_z>=040000000) { \
+ vf_z= vf_z / 2; \
+ vf_alpha += vf_alpha; \
+ } \
+ vf_beta=256 / vf_alpha; \
+ vf_alpha=vf_alpha*vf_z; }
+
+/* read |k| bytes as an integer from \.{VF} file */
+
+#define vf_read(k,l) { integer itmp = 0, dtmp = k, jtmp = 0; \
+ while (dtmp > 0) { \
+ vf_byte(jtmp); \
+ if ((dtmp==k) && jtmp>127) \
+ jtmp = jtmp - 256; \
+ itmp = itmp*256 + jtmp; \
+ decr(dtmp); \
+ } \
+ l = itmp; }
+
+#define vf_read_u(k,l) { unsigned int dtmp=k, itmp = 0, jtmp = 0; \
+ while (dtmp-- > 0) { \
+ vf_byte(jtmp); \
+ itmp = itmp*256 + jtmp; \
+ } \
+ l = itmp; }
+
+void
+pdf_check_vf_cur_val (void) {
+ internal_font_number f;
+ f = cur_val;
+ if (font_type(f) == virtual_font_type)
+ pdf_error("font", "command cannot be used with virtual font");
+}
+
+static void
+vf_local_font_warning(internal_font_number f, internal_font_number k, char *s, integer a, integer b) {
+ print_nlp();
+ print_string(s);
+ print_string(" in local font ");
+ print_string(font_name(k));
+ print_string(" (");
+ print_int(b);
+ print_string(" != ");
+ print_int(a);
+ print_string(") in virtual font ");
+ print_string(font_name(f));
+ print_string(".vf ignored.");
+}
+
+
+/* process a local font in \.{VF} file */
+
+internal_font_number
+vf_def_font(internal_font_number f,unsigned char *vf_buffer, integer *vf_cr) {
+ internal_font_number k;
+ str_number s;
+ scaled ds,fs;
+ four_quarters cs;
+ memory_word tmp_w; /* accumulator */
+ integer junk;
+ unsigned long checksum;
+ cs.b0 = vf_buffer[(*vf_cr)];
+ cs.b1 = vf_buffer[(*vf_cr)+1];
+ cs.b2 = vf_buffer[(*vf_cr)+2];
+ cs.b3 = vf_buffer[(*vf_cr)+3]; (*vf_cr)+=4;
+ checksum = cs.b0*256*256*256 + cs.b1*256*256 + cs.b2*256 + cs.b3;
+ k = vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ if (k>127) k-=256;
+ k = k*256+ vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ k = k*256+ vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ k = k*256+ vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+
+ fs = sqxfw(k, font_size(f));
+
+ k = vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ if (k>127) k-=256;
+ k = k*256+ vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ k = k*256+ vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ k = k*256+ vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+
+ ds = k / 16;
+
+
+ tmp_b0 = vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ tmp_b1 = vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ while (tmp_b0 > 0) {
+ tmp_b0--;
+ (*vf_cr)++; /* skip the font path */
+ }
+ string_room(tmp_b1);
+ while (tmp_b1 > 0) {
+ tmp_b1--;
+ junk = vf_buffer[(*vf_cr)] ; (*vf_cr)++;
+ append_pool_char(junk);
+ }
+ s = make_string();
+ k = tfm_lookup(s, fs);
+ if (k == null_font)
+ k = read_font_info(get_nullcs(), s, get_nullstr(), fs, -1);
+ if (k != null_font) {
+ if (checksum!=0 && font_checksum(k)!=0 && checksum!= font_checksum(k))
+ vf_local_font_warning(f, k, "checksum mismatch",checksum,font_checksum(k));
+ if (ds != font_dsize(k))
+ vf_local_font_warning(f, k, "design size mismatch",ds,font_dsize(k));
+ }
+ if (pdf_font_expand_ratio(f) != 0)
+ set_expand_params(k, pdf_font_auto_expand(f),
+ pdf_font_expand_ratio(pdf_font_stretch(f)),
+ -pdf_font_expand_ratio(pdf_font_shrink(f)),
+ pdf_font_step(f), pdf_font_expand_ratio(f));
+ return k;
+}
+
+
+int
+open_vf_file (char *fn, unsigned char **vbuffer, integer *vsize) {
+ boolean res; /* was the callback successful? */
+ integer callback_id;
+ boolean file_read; /* was |vf_file| successfully read? */
+ FILE *vf_file;
+ char *fnam = NULL;
+
+
+
+
+ namelength = strlen(fn);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),fn);
+
+ callback_id=callback_defined(find_vf_file_callback);
+ if (callback_id>0) {
+ res = run_callback(callback_id,"S->S",fn, &fnam);
+ if (res && (fnam!=NULL) && (strlen(fnam)>0)) {
+ /* @<Fixup |nameoffile| after callback@>; */
+ free(nameoffile);
+ namelength = strlen(fnam);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),fnam);
+ } else {
+ return 0;
+ }
+ }
+ callback_id=callback_defined(read_vf_file_callback);
+ if (callback_id>0) {
+ file_read = false;
+ res = run_callback(callback_id,"S->bSd",stringcast(nameoffile+1),
+ &file_read, vbuffer,vsize);
+ if (res && file_read && (*vsize>0)) {
+ return 1;
+ }
+ if (!file_read)
+ return 0; /* -1 */
+ } else {
+ if (ovf_b_open_in(vf_file) || vf_b_open_in(vf_file)) {
+ res = read_vf_file(vf_file,vbuffer,vsize);
+ b_close(vf_file);
+ if (res) {
+ return 1;
+ }
+ } else {
+ return 0; /* -1 */
+ }
+ }
+ return 0;
+}
+
+
+/*
+ @ The |do_vf| procedure attempts to read the \.{VF} file for a font, and sets
+ |font_type()| to |real_font_type| if the \.{VF} file could not be found
+ or loaded, otherwise sets |font_type()| to |virtual_font_type|. At this
+ time, |tmp_f| is the internal font number of the current \.{TFM} font. To
+ process font definitions in virtual font we call |vf_def_font|.
+*/
+
+#define append_packet(k) vpackets[vf_np++] = k
+
+/* life is easier if all internal font commands are fnt4 and
+ all character commands are set4 or put4 */
+
+#define append_fnt_set(k) { \
+ assert(k>0) ; \
+ append_packet(packet_font_code); \
+ append_four(k); }
+
+#define append_four(k) { \
+ append_packet((k&0xFF000000)>>24); \
+ append_packet((k&0x00FF0000)>>16); \
+ append_packet((k&0x0000FF00)>>8); \
+ append_packet((k&0x000000FF)); }
+
+/* some of these things happen twice, adding a define is simplest */
+
+#define test_checksum() { vf_byte(tmp_b0); vf_byte(tmp_b1); \
+ vf_byte(tmp_b2); vf_byte(tmp_b3); \
+ if (((tmp_b0 != 0) || (tmp_b1 != 0) || (tmp_b2 != 0) || (tmp_b3 != 0)) && \
+ ((font_check_0(f) != 0) || (font_check_1(f) != 0) || \
+ (font_check_2(f) != 0) || (font_check_3(f) != 0)) && \
+ ((tmp_b0 != font_check_0(f)) || (tmp_b1 != font_check_1(f)) || \
+ (tmp_b2 != font_check_2(f)) || (tmp_b3 != font_check_3(f)))) { \
+ print_nlp(); \
+ print_string("checksum mismatch in font "); \
+ print_string(font_name(f)); \
+ print_string(".vf ignored "); } }
+
+#define test_dsize() { int read_tmp; vf_read(4,read_tmp); \
+ if ((read_tmp / 16) != font_dsize(f)) { \
+ print_nlp(); \
+ print_string("design size mismatch in font "); \
+ print_string(font_name(f)); \
+ print_string(".vf ignored"); \
+ } }
+
+
+int count_packet_bytes (real_eight_bits *vf_buf, int cur_bute, int count) {
+ int k = 0;
+ int ff = 0;
+ int acc = 0;
+ unsigned int cmd = 0;
+ unsigned int d = 0;
+ while (k<count) {
+ cmd = vf_buf[cur_bute+k]; k++;
+ if ((cmd >= set_char_0) && (cmd < set1)) {
+ if (ff==0) { ff = 1; acc+=5; }
+ acc+=5;
+ } else if ((fnt_num_0 <= cmd) && (cmd <= fnt_num_0 + 63)) {
+ ff = 1;
+ acc+=5;
+ } else {
+ switch (cmd) {
+ case fnt1: acc+=5; k+=1; ff=1 ; break;
+ case fnt2: acc+=5; k+=2; ff=1 ; break;
+ case fnt3: acc+=5; k+=3; ff=1 ; break;
+ case fnt4: acc+=5; k+=4; ff=1 ; break;
+ case set_rule: acc+=9; k+=8; break;
+ case put_rule: acc+=11; k+=8; break;
+ case set1: acc+=5; k+=1; if (ff==0) { ff = 1; acc+=5; } break;
+ case set2: acc+=5; k+=2; if (ff==0) { ff = 1; acc+=5; } break;
+ case set3: acc+=5; k+=3; if (ff==0) { ff = 1; acc+=5; } break;
+ case set4: acc+=5; k+=4; if (ff==0) { ff = 1; acc+=5; } break;
+ case put1: acc+=7; k+=1; if (ff==0) { ff = 1; acc+=5; } break;
+ case put2: acc+=7; k+=2; if (ff==0) { ff = 1; acc+=5; } break;
+ case put3: acc+=7; k+=3; if (ff==0) { ff = 1; acc+=5; } break;
+ case put4: acc+=7; k+=4; if (ff==0) { ff = 1; acc+=5; } break;
+ case right1: acc+=5; k+=1; break;
+ case right2: acc+=5; k+=2; break;
+ case right3: acc+=5; k+=3; break;
+ case right4: acc+=5; k+=4; break;
+ case w1: acc+=5; k+=1; break;
+ case w2: acc+=5; k+=2; break;
+ case w3: acc+=5; k+=3; break;
+ case w4: acc+=5; k+=4; break;
+ case x1: acc+=5; k+=1; break;
+ case x2: acc+=5; k+=2; break;
+ case x3: acc+=5; k+=3; break;
+ case x4: acc+=5; k+=4; break;
+ case down1: acc+=5; k+=1; break;
+ case down2: acc+=5; k+=2; break;
+ case down3: acc+=5; k+=3; break;
+ case down4: acc+=5; k+=4; break;
+ case y1: acc+=5; k+=1; break;
+ case y2: acc+=5; k+=2; break;
+ case y3: acc+=5; k+=3; break;
+ case y4: acc+=5; k+=4; break;
+ case z1: acc+=5; k+=1; break;
+ case z2: acc+=5; k+=2; break;
+ case z3: acc+=5; k+=3; break;
+ case z4: acc+=5; k+=4; break;
+ case xxx1:
+ d = vf_buf[cur_bute+k]; k++;
+ k += d; acc += 5 + d;
+ break;
+ case xxx2:
+ d = vf_buf[cur_bute+k]; k++;
+ d = d*256 + vf_buf[cur_bute+k]; k++;
+ k += d; acc += 5 + d;
+ break;
+ case xxx3:
+ d = vf_buf[cur_bute+k]; k++;
+ d = d*256 + vf_buf[cur_bute+k]; k++;
+ d = d*256 + vf_buf[cur_bute+k]; k++;
+ k += d; acc += 5 + d;
+ break;
+ case xxx4:
+ d = vf_buf[cur_bute+k]; k++;
+ d = d*256 + vf_buf[cur_bute+k]; k++;
+ d = d*256 + vf_buf[cur_bute+k]; k++;
+ d = d*256 + vf_buf[cur_bute+k]; k++;
+ k += d; acc += 5 + d;
+ break;
+ case w0: acc+=5; break;
+ case x0: acc+=5; break;
+ case y0: acc+=5; break;
+ case z0: acc+=5; break;
+ case nop: break;
+ case push: acc+=1; break;
+ case pop: acc+=1; break;
+ }
+ }
+ }
+ return (acc+1);
+}
+
+void
+do_vf(internal_font_number f) {
+ integer k, n, i;
+ unsigned cmd;
+ scaled x,y,w,z,h,v;
+ integer cc, cmd_length, packet_length;
+ charinfo *co;
+ scaled tfm_width;
+ integer save_cur_byte;
+ vf_stack_index stack_level;
+ integer vf_z; /* multiplier */
+ integer vf_alpha; /* correction for negative values */
+ char vf_beta; /* divisor */
+ integer vf_np;
+ real_eight_bits *vpackets;
+ memory_word tmp_w; /* accumulator */
+ vf_stack_record vf_stack[256];
+ integer junk;
+ unsigned char *vf_buffer;
+ integer vf_size;
+ integer vf_cur;
+ integer *vf_local_fnts = NULL; /* external font ids */
+ integer *vf_real_fnts = NULL; /* internal font ids */
+ unsigned vf_nf = 0; /* local font counter */
+
+ if (font_type(f)!= unknown_font_type)
+ return;
+ set_font_type(f,real_font_type);
+ if (auto_expand_vf(f))
+ return; /* auto-expanded virtual font */
+ stack_level = 0;
+ /* @<Open |vf_file|, return if not found@>; */
+ vf_cur=0; vf_buffer=NULL; vf_size=0;
+ if (!open_vf_file(font_name(f), &vf_buffer, &vf_size))
+ return;
+ /* @<Process the preamble@>;@/ */
+ set_font_type(f,virtual_font_type);
+ vf_byte(k);
+ if (k != pre)
+ bad_vf("PRE command expected");
+ vf_byte(k);
+ if (k != vf_id)
+ bad_vf("wrong id byte");
+ vf_byte(cmd_length);
+ for (k = 1;k<= cmd_length;k++)
+ vf_byte(junk);
+ test_checksum();
+ test_dsize();
+ /* update_terminal;*/
+ vf_z = font_size(f);
+ vf_replace_z();
+ /* @<Process the font definitions@>;@/ */
+ /* scan forward to find the number of internal fonts */
+ vf_nf = 0;
+ save_cur_byte = vf_cur;
+ vf_byte(cmd);
+ while ((cmd >= fnt_def1) && (cmd <= (fnt_def1 + 3))) {
+ vf_read((cmd - fnt_def1 + 1),junk);
+ vf_read(4,junk);
+ vf_read(4,junk);
+ vf_read(4,junk);
+ vf_byte(k);
+ vf_byte(junk);
+ k += junk;
+ while (k-- > 0) { vf_byte(junk); }
+ incr(vf_nf);
+ vf_byte(cmd);
+ }
+ vf_cur = save_cur_byte;
+ vf_byte(cmd);
+ /* malloc and fill the local font arrays */
+ if (vf_nf>0) {
+ i = vf_nf*sizeof(integer);
+ vf_local_fnts= xmalloc(i);
+ memset(vf_local_fnts,0,i);
+ vf_real_fnts= xmalloc(i);
+ memset(vf_real_fnts,0,i);
+ vf_nf = 0;
+ while ((cmd >= fnt_def1) && (cmd <= (fnt_def1 + 3))) {
+ vf_read_u((cmd - fnt_def1 + 1),vf_local_fnts[vf_nf]);
+ vf_real_fnts[vf_nf] = vf_def_font(f, vf_buffer, &vf_cur);
+ incr(vf_nf);
+ vf_byte(cmd);
+ }
+ }
+
+
+ while (cmd <= long_char) {
+ /* @<Build a character packet@>;@/ */
+ vf_np = 0;
+ if (cmd == long_char) {
+ vf_read_u(4,packet_length);
+ vf_read_u(4,cc);
+ if (!char_exists(f,cc)) {
+ bad_vf("invalid character code");
+ }
+ vf_read(4,k);
+ tfm_width = sqxfw(k, font_size(f));
+ } else {
+ packet_length = cmd;
+ vf_byte(cc);
+ if (!char_exists(f,cc)) {
+ bad_vf("invalid character code");
+ }
+ vf_read(3,k);
+ tfm_width = sqxfw(k, font_size(f));
+ }
+ if (packet_length < 0)
+ bad_vf("negative packet length");
+ if (tfm_width != char_width(f,cc)) {
+ /* precisely 'one off' errors are rampant */
+ if (abs(tfm_width - char_width(f,cc))>1) {
+ print_nlp();
+ print_string("character width mismatch in font ");
+ print_string(font_name(f));
+ print_string(".vf ignored");
+ }
+ }
+ k = count_packet_bytes(vf_buffer,vf_cur,packet_length);
+ vpackets = xmalloc(k+1);
+ co = get_charinfo(f,cc);
+ k = 0;
+ w = 0; x = 0; y = 0; z = 0;
+ while (packet_length > 0) {
+ vf_byte(cmd);
+ decr(packet_length);
+
+ if ((cmd >= set_char_0) && (cmd < set1)) {
+ if (k == 0) {
+ k = vf_real_fnts[0];
+ append_fnt_set(k);
+ }
+ append_packet(packet_char_code);
+ append_four(cmd);
+ cmd_length = 0;
+ cmd = nop;
+
+ } else if (((fnt_num_0 <= cmd) && (cmd <= fnt_num_0 + 63)) ||
+ ((fnt1 <= cmd) && (cmd <= fnt1 + 3))) {
+ if (cmd >= fnt1) {
+ vf_read_u((cmd - fnt1 + 1),k);
+ packet_length -= (cmd - fnt1 + 1);
+ } else {
+ k = cmd - fnt_num_0;
+ }
+
+ /* change from local to external font id */
+ n = 0;
+ while ((n < vf_nf) && (vf_local_fnts[n] != k))
+ n++;
+ if (n==vf_nf)
+ bad_vf("undefined local font");
+
+ k = vf_real_fnts[n];
+ append_fnt_set(k);
+ cmd_length = 0;
+ cmd = nop;
+ } else {
+ switch (cmd) {
+ case set_rule:
+ vf_read(4,h); vf_read(4,v);
+ append_packet(packet_rule_code);
+ append_four(h);
+ append_four(v);
+ packet_length -= 8;
+ break;
+ case put_rule:
+ vf_read(4,h); vf_read(4,v);
+ append_packet(packet_push_code);
+ append_packet(packet_rule_code);
+ append_four(h);
+ append_four(v);
+ append_packet(packet_pop_code);
+ packet_length -= 8;
+ break;
+ case set1:
+ case set2:
+ case set3:
+ case set4:
+ if (k == 0) {
+ k = vf_real_fnts[0];
+ append_fnt_set(k);
+ }
+ vf_read_u((cmd - set1 + 1),i);
+ append_packet(packet_char_code);
+ append_four(i);
+ packet_length -= (cmd - set1 + 1);
+ break;
+ case put1:
+ case put2:
+ case put3:
+ case put4:
+ if (k == 0) {
+ k = vf_real_fnts[0];
+ append_fnt_set(k);
+ }
+ vf_read_u((cmd - put1 + 1),i);
+ append_packet(packet_push_code);
+ append_packet(packet_char_code);
+ append_four(i);
+ append_packet(packet_pop_code);
+ packet_length -= (cmd - put1 + 1);
+ break;
+ case right1:
+ case right2:
+ case right3:
+ case right4:
+ vf_read((cmd - right1 + 1),i);
+ append_packet(packet_right_code);
+ append_four(i);
+ packet_length -= (cmd - right1 + 1);
+ break;
+ case w1:
+ case w2:
+ case w3:
+ case w4:
+ vf_read((cmd - w1 + 1),w);
+ append_packet(packet_right_code);
+ append_four(w);
+ packet_length -= (cmd - w1 + 1);
+ break;
+ case x1:
+ case x2:
+ case x3:
+ case x4:
+ vf_read((cmd - x1 + 1),x);
+ append_packet(packet_right_code);
+ append_four(x);
+ packet_length -= (cmd - x1 + 1);
+ break;
+ case down1:
+ case down2:
+ case down3:
+ case down4:
+ vf_read((cmd - down1 + 1),i);
+ append_packet(packet_down_code);
+ append_four(i);
+ packet_length -= (cmd - down1 + 1);
+ break;
+ case y1:
+ case y2:
+ case y3:
+ case y4:
+ vf_read((cmd - y1 + 1),y);
+ append_packet(packet_down_code);
+ append_four(y);
+ packet_length -= (cmd - y1 + 1);
+ break;
+ case z1:
+ case z2:
+ case z3:
+ case z4:
+ vf_read((cmd - z1 + 1),z);
+ append_packet(packet_down_code);
+ append_four(z);
+ packet_length -= (cmd - z1 + 1);
+ break;
+ case xxx1:
+ case xxx2:
+ case xxx3:
+ case xxx4:
+ vf_read_u((cmd - xxx1 + 1),cmd_length);
+ packet_length -= (cmd - xxx1 + 1);
+ if (cmd_length <= 0)
+ bad_vf("special of negative length");
+ packet_length -= cmd_length;
+
+ append_packet(packet_special_code);
+ append_four(cmd_length);
+ while (cmd_length > 0) {
+ cmd_length--;
+ vf_byte(i);
+ append_packet(i);
+ }
+ append_packet(0);
+ break;
+ case w0:
+ append_packet(packet_right_code);
+ append_four(w);
+ break;
+ case x0:
+ append_packet(packet_right_code);
+ append_four(x);
+ break;
+ case y0:
+ append_packet(packet_down_code);
+ append_four(y);
+ break;
+ case z0:
+ append_packet(packet_down_code);
+ append_four(z);
+ break;
+ case nop:
+ break;
+ case push:
+ if (stack_level == vf_stack_size) {
+ overflow_string("virtual font stack size", vf_stack_size);
+ } else {
+ vf_stack[stack_level].stack_w = w;
+ vf_stack[stack_level].stack_x = x;
+ vf_stack[stack_level].stack_y = y;
+ vf_stack[stack_level].stack_z = z;
+ incr(stack_level);
+ append_packet(packet_push_code);
+ }
+ break;
+ case pop:
+ if (stack_level == 0) {
+ bad_vf("more POPs than PUSHs in character");
+ } else {
+ decr(stack_level);
+ w = vf_stack[stack_level].stack_w;
+ x = vf_stack[stack_level].stack_x;
+ y = vf_stack[stack_level].stack_y;
+ z = vf_stack[stack_level].stack_z;
+ append_packet(packet_pop_code);
+ }
+ break;
+ default:
+ bad_vf("improver DVI command");
+ }
+ }
+ }
+ /* signal end of packet */
+ append_packet(packet_end_code);
+
+ if (stack_level != 0)
+ bad_vf("more PUSHs than POPs in character packet");
+ if (packet_length != 0)
+ bad_vf("invalid packet length or DVI command in packet");
+ /* @<Store the packet being built@>; */
+ set_charinfo_packets(co,vpackets);
+ vf_byte(cmd);
+ }
+ if (cmd != post)
+ bad_vf("POST command expected");
+
+ xfree(vf_buffer);
+}
+
+#define make_command0(N,K) { \
+ lua_newtable(L); \
+ lua_pushstring(L, N); \
+ lua_rawseti(L,-2, 1); \
+ lua_rawseti(L,-2, K); \
+ K++; }
+
+#define make_command1(N,V,K) { \
+ lua_newtable(L); \
+ lua_pushstring(L, N); \
+ lua_rawseti(L,-2, 1); \
+ lua_pushnumber(L, V); \
+ lua_rawseti(L,-2, 2); \
+ lua_rawseti(L,-2, K); \
+ K++; }
+
+#define make_command2(N,V,W,K) { \
+ lua_newtable(L); \
+ lua_pushstring(L, N); \
+ lua_rawseti(L,-2, 1); \
+ lua_pushnumber(L, V); \
+ lua_rawseti(L,-2, 2); \
+ lua_pushnumber(L, W); \
+ lua_rawseti(L,-2, 3); \
+ lua_rawseti(L,-2, K); \
+ K++; }
+
+#define make_commands(N,S,V,K) { \
+ lua_newtable(L); \
+ lua_pushstring(L, N); \
+ lua_rawseti(L,-2, 1); \
+ lua_pushlstring(L, S, V); \
+ lua_rawseti(L,-2, 2); \
+ lua_rawseti(L,-2, K); \
+ K++; }
+
+
+int
+make_vf_table(lua_State *L, char *cnom, scaled atsize) {
+ integer cmd, k, i;
+ integer cc, cmd_length, packet_length;
+ scaled tfm_width;
+ vf_stack_index stack_level;
+ integer vf_z; /* multiplier */
+ integer vf_alpha; /* correction for negative values */
+ char vf_beta; /* divisor */
+ char *s;
+ scaled h,v;
+ scaled w, x, y, z;
+ integer s_top; /* lua stack */
+ integer vf_nf ; /* local font counter */
+ scaled ds,fs;
+ four_quarters cs;
+ memory_word tmp_w; /* accumulator */
+ vf_stack_record vf_stack[256];
+ unsigned char *vf_buffer;
+ integer vf_size;
+ integer vf_cur;
+
+
+ stack_level = 0;
+ /* @<Open |vf_file|, return if not found@>; */
+ vf_cur=0; vf_buffer=NULL; vf_size=0;
+ if (!open_vf_file(cnom, &vf_buffer, &vf_size)) {
+ lua_pushnil(L);
+ return 1;
+ }
+
+ /* start by creating a table */
+ s_top = lua_gettop(L);
+ lua_newtable(L);
+
+ /* @<Process the preamble@>;@/ */
+ vf_byte(k);
+ if (k != pre)
+ lua_bad_vf("PRE command expected");
+ vf_byte(k);
+ if (k != vf_id)
+ lua_bad_vf("wrong id byte");
+ vf_byte(cmd_length);
+
+ s = xmalloc(cmd_length);
+ for (k = 1;k<= cmd_length;k++)
+ vf_byte(s[(k-1)]);
+
+ lua_pushlstring(L,s,cmd_length);
+ free(s);
+ lua_setfield(L,-2,"header");
+
+ vf_byte(cs.b0); vf_byte(cs.b1); vf_byte(cs.b2); vf_byte(cs.b3);
+ lua_pushnumber(L, (unsigned long)(cs.b0<<24)+(cs.b1<<16)+(cs.b2<<8)+cs.b3 );
+ lua_setfield(L,-2,"checksum");
+
+ vf_read(4,k);
+ ds = k /16;
+ lua_pushinteger(L,ds);
+ lua_setfield(L,-2,"designsize");
+
+
+ lua_pushstring(L,cnom);
+ lua_setfield(L,-2,"name");
+
+ lua_pushinteger(L,atsize);
+ lua_setfield(L,-2,"size");
+
+
+ /* update_terminal;*/
+ vf_z = atsize;
+ vf_replace_z();
+ /* @<Process the font definitions@>;@/ */
+ vf_byte(cmd);
+ lua_newtable(L);
+
+ i = 1;
+ while ((cmd >= fnt_def1) && (cmd <= fnt_def1 + 3)) {
+
+ lua_newtable(L);
+ vf_read_u((cmd - fnt_def1 + 1),vf_nf);
+ vf_nf++;
+ /* checksum */
+ vf_byte(cs.b0); vf_byte(cs.b1); vf_byte(cs.b2); vf_byte(cs.b3);
+
+ vf_read(4,k);
+ fs = sqxfw(k, atsize);
+ lua_pushstring(L,"size");
+ lua_pushnumber(L,fs);
+ lua_rawset(L,-3);
+
+ vf_read(4,k);
+ ds = k / 16; /* dsize, not used */
+
+ vf_byte(tmp_b0);
+ vf_byte(tmp_b1);
+ while (tmp_b0 > 0) { tmp_b0--; vf_byte(k); } /* skip the font path */
+
+ s = xmalloc(tmp_b1+1); k = 0;
+ while (tmp_b1-- > 0)
+ vf_byte(s[k++]);
+ s[k]=0;
+ lua_pushstring(L,"name");
+ lua_pushstring(L,xstrdup(s));
+ free(s);
+ lua_rawset(L,-3);
+
+ lua_rawseti(L,-2,vf_nf);
+ i++;
+ vf_byte(cmd);
+ }
+
+ if (i>1) {
+ lua_setfield(L,-2,"fonts");
+ } else {
+ lua_pop(L,1);
+ }
+
+ lua_newtable(L); /* 'characters' */
+ while (cmd <= long_char) {
+ /* @<Build a character packet@>;@/ */
+ if (cmd == long_char) {
+ vf_read_u(4,packet_length);
+ vf_read_u(4,cc);
+ vf_read(4,tfm_width);
+ } else {
+ packet_length = cmd;
+ vf_byte(cc);
+ vf_read(3,tfm_width);
+ }
+ if (packet_length < 0)
+ lua_bad_vf("negative packet length");
+
+ lua_newtable(L); /* for this character */
+
+ lua_pushnumber(L,tfm_width);
+ lua_setfield(L,-2,"width");
+
+ lua_newtable(L); /* for 'commands' */
+
+ k = 1; vf_nf = 0;
+ w = 0; x = 0; y = 0; z = 0;
+ while (packet_length > 0) {
+ vf_byte(cmd);
+ decr(packet_length);
+
+ if ((cmd >= set_char_0) && (cmd < set1)) {
+ if (vf_nf == 0) {
+ vf_nf = 1;
+ make_command1("font",vf_nf,k);
+ }
+ make_command1("char",cmd,k);
+
+ } else if (((fnt_num_0 <= cmd) && (cmd <= fnt_num_0 + 63)) ||
+ ((fnt1 <= cmd) && (cmd <= fnt1 + 3))) {
+ if (cmd >= fnt1) {
+ vf_read_u((cmd - fnt1 + 1),vf_nf); vf_nf++;
+ packet_length -= (cmd - fnt1 + 1);
+ } else {
+ vf_nf = cmd - fnt_num_0 + 1;
+ }
+ make_command1("font",vf_nf,k);
+ } else {
+ switch (cmd) {
+ case set_rule:
+ vf_read(4,h); vf_read(4,v);
+ make_command2("rule",sqxfw(h,atsize),sqxfw(v,atsize),k);
+ packet_length -= 8;
+ break;
+ case put_rule:
+ vf_read(4,h); vf_read(4,v);
+ make_command0("push",k);
+ make_command2("rule",sqxfw(h,atsize),sqxfw(v,atsize),k);
+ make_command0("pop",k);
+ packet_length -= 8;
+ break;
+ case set1:
+ case set2:
+ case set3:
+ case set4:
+ if (vf_nf == 0) {
+ vf_nf = 1;
+ make_command1("font",vf_nf,k);
+ }
+ vf_read_u((cmd - set1 + 1),i);
+ make_command1("char",i,k);
+ packet_length -= (cmd - set1 + 1);
+ break;
+ case put1:
+ case put2:
+ case put3:
+ case put4:
+ if (vf_nf == 0) {
+ vf_nf = 1;
+ make_command1("font",vf_nf,k);
+ }
+ vf_read_u((cmd - put1 + 1),i);
+ make_command0("push",k);
+ make_command1("char",i,k);
+ make_command0("pop",k);
+ packet_length -= (cmd - put1 + 1);
+ break;
+ case right1:
+ case right2:
+ case right3:
+ case right4:
+ vf_read((cmd - right1 + 1),i);
+ make_command1("right",sqxfw(i,atsize),k);
+ packet_length -= (cmd - right1 + 1);
+ break;
+ case w1:
+ case w2:
+ case w3:
+ case w4:
+ vf_read((cmd - w1 + 1),w);
+ make_command1("right",sqxfw(w,atsize),k);
+ packet_length -= (cmd - w1 + 1);
+ break;
+ case x1:
+ case x2:
+ case x3:
+ case x4:
+ vf_read((cmd - x1 + 1),x);
+ make_command1("right",sqxfw(x,atsize),k);
+ packet_length -= (cmd - x1 + 1);
+ break;
+ case down1:
+ case down2:
+ case down3:
+ case down4:
+ vf_read((cmd - down1 + 1),i);
+ make_command1("down",sqxfw(i,atsize),k);
+ packet_length -= (cmd - down1 + 1);
+ break;
+ case y1:
+ case y2:
+ case y3:
+ case y4:
+ vf_read((cmd - y1 + 1),y);
+ make_command1("down",sqxfw(y,atsize),k);
+ packet_length -= (cmd - y1 + 1);
+ break;
+ case z1:
+ case z2:
+ case z3:
+ case z4:
+ vf_read((cmd - z1 + 1),z);
+ make_command1("down",sqxfw(z,atsize),k);
+ packet_length -= (cmd - z1 + 1);
+ break;
+ case xxx1:
+ case xxx2:
+ case xxx3:
+ case xxx4:
+ vf_read_u((cmd - xxx1 + 1),cmd_length);
+ packet_length -= (cmd - xxx1 + 1);
+ if (cmd_length <= 0)
+ lua_bad_vf("special of negative length");
+ packet_length -= cmd_length;
+
+ s = xmalloc(cmd_length+1); i = 0;
+ while (cmd_length > 0) {
+ cmd_length--;
+ vf_byte(s[i]);
+ i++;
+ }
+ s[i]=0;
+ make_commands("special",strdup(s),i,k);
+ free(s);
+ break;
+ case w0:
+ make_command1("right",sqxfw(w,atsize),k);
+ break;
+ case x0:
+ make_command1("right",sqxfw(x,atsize),k);
+ break;
+ case y0:
+ make_command1("down",sqxfw(y,atsize),k);
+ break;
+ case z0:
+ make_command1("down",sqxfw(z,atsize),k);
+ break;
+ case nop:
+ break;
+ case push:
+ if (stack_level == vf_stack_size) {
+ overflow_string("virtual font stack size", vf_stack_size);
+ } else {
+ vf_stack[stack_level].stack_w = w;
+ vf_stack[stack_level].stack_x = x;
+ vf_stack[stack_level].stack_y = y;
+ vf_stack[stack_level].stack_z = z;
+ incr(stack_level);
+ make_command0("push",k);
+ }
+ break;
+ case pop:
+ if (stack_level == 0) {
+ lua_bad_vf("more POPs than PUSHs in character");
+ } else {
+ decr(stack_level);
+ w = vf_stack[stack_level].stack_w;
+ x = vf_stack[stack_level].stack_x;
+ y = vf_stack[stack_level].stack_y;
+ z = vf_stack[stack_level].stack_z;
+ make_command0("pop",k);
+ }
+ break;
+ default:
+ lua_bad_vf("improver DVI command");
+ }
+ }
+ }
+ /* signal end of packet */
+ lua_setfield(L,-2,"commands");
+
+ if (stack_level != 0)
+ lua_bad_vf("more PUSHs than POPs in character packet");
+ if (packet_length != 0)
+ lua_bad_vf("invalid packet length or DVI command in packet");
+
+ lua_rawseti(L,-2,cc);
+
+ vf_byte(cmd);
+ }
+ lua_setfield(L,-2,"characters");
+
+ if (cmd != post)
+ lua_bad_vf("POST command expected");
+ xfree(vf_buffer);
+ return 1;
+}
+
+
+extern void replace_packet_fonts(internal_font_number f, integer *old_fontid, integer *new_fontid, int count) ;
+extern integer *packet_local_fonts(internal_font_number f, integer *num);
+extern internal_font_number auto_expand_font (internal_font_number f, integer e) ;
+
+
+/* This function is called from |do_vf|, and fixes up the virtual data
+ inside an auto-expanded virtual font */
+
+boolean
+auto_expand_vf(internal_font_number f) {
+
+ internal_font_number bf;
+ integer e, k;
+ integer *vf_old_fonts, *vf_new_fonts;
+ integer num = 0;
+
+ if ((! pdf_font_auto_expand(f)) || (pdf_font_blink(f) == null_font))
+ return false ; /* not an auto-expanded font */
+ bf = pdf_font_blink(f);
+
+ if (font_type(bf) != virtual_font_type)
+ return false; /* not a virtual font */
+
+ e = pdf_font_expand_ratio(f);
+
+ vf_old_fonts = packet_local_fonts(bf,&num);
+ if (num>0) {
+ vf_new_fonts = xmalloc(num*sizeof(integer));
+ for (k=0;k<num;k++) {
+ vf_new_fonts[k] = auto_expand_font(vf_old_fonts[k], e);
+ copy_expand_params(vf_new_fonts[k], vf_old_fonts[k], e);
+ }
+ replace_packet_fonts(f,vf_old_fonts,vf_new_fonts,num);
+ xfree(vf_new_fonts);
+ xfree(vf_old_fonts);
+ }
+ set_font_type(f,virtual_font_type);
+ return true;
+}
+
+/* this function is not always safe, because it needs makecstring() */
+str_number
+expand_font_name (internal_font_number f, integer e) {
+ int old_setting;
+ old_setting=selector;
+ selector=new_string;
+ print_string(font_name(f));
+ if (e > 0) {
+ print_char('+');
+ }
+ print_int(e);
+ selector=old_setting;
+ return make_string();
+}
+
+
+internal_font_number
+auto_expand_font (internal_font_number f, integer e) {
+ internal_font_number k;
+ kerninfo *krn;
+ charinfo *co, *ci;
+ char *fn;
+ integer i;
+ scaled w;
+ k = copy_font(f);
+ i = strlen(font_name(f))+12;
+ fn = xmalloc(i);
+ snprintf(fn,i,"%s%s%d",font_name(f),(e>0 ? "+" : ""), (int)e);
+ set_font_name(k,fn);
+ for (i = font_bc(k);i<=font_ec(k);i++) {
+ if (char_exists(k,i)) {
+ co = get_charinfo(k,i);
+ w = round_xn_over_d(char_width(f,i), 1000 + e, 1000);
+ set_charinfo_width (co, w);
+ w = round_xn_over_d(char_italic(f,i), 1000 + e, 1000);
+ set_charinfo_italic(co, w);
+ krn = get_charinfo_kerns(co);
+ if (krn != NULL) {
+ while (!kern_end((*krn))) {
+ kern_kern(*krn) = round_xn_over_d(kern_kern(*krn), 1000 + e, 1000);
+ krn++;
+ }
+ }
+ }
+ }
+ return k;
+}
+
+void
+vf_expand_local_fonts(internal_font_number f) {
+ internal_font_number lf;
+ integer k, num;
+ integer *vf_old_fonts;
+ pdfassert(font_type(f) == virtual_font_type);
+ num = 0;
+ vf_old_fonts = packet_local_fonts(f,&num);
+ if (num>0) {
+ for (k = 0;k<num;k++) {
+ lf = vf_old_fonts[k];
+ set_expand_params(lf, pdf_font_auto_expand(f),
+ pdf_font_expand_ratio(pdf_font_stretch(f)),
+ -pdf_font_expand_ratio(pdf_font_shrink(f)),
+ pdf_font_step(f), pdf_font_expand_ratio(f));
+ if (font_type(lf) == virtual_font_type)
+ vf_expand_local_fonts(lf);
+ }
+ xfree(vf_old_fonts);
+ }
+}
+
+internal_font_number
+letter_space_font (halfword u, internal_font_number f, integer e) {
+ internal_font_number k;
+ scaled w, r;
+
+ char *new_font_name;
+ integer vf_z;
+ integer vf_alpha;
+ integer vf_beta;
+ memory_word tmp_w; /* accumulator */
+
+
+ /* read a new font and expand the character widths */
+ k = read_font_info(u, tex_font_name(f), get_nullstr(), font_size(f), font_natural_dir(f));
+ set_no_ligatures(k); /* disable ligatures for letter-spaced fonts */
+/*
+ for (i = 0;i <= font_widths(k);i++) {
+ set_font_width(k,i,font_width(f,i)+round_xn_over_d(quad(k), e, 1000));
+ }
+*/
+ /* append eg '+100ls' to font name */
+ new_font_name = xmalloc(strlen(font_name(k)) + 8); /* |abs(e) <= 1000| */
+ if (e > 0) {
+ sprintf(new_font_name,"%s+%ils",font_name(k),(int)e);
+ } else {
+ /* minus from %i */
+ sprintf(new_font_name,"%s%ils",font_name(k),(int)e);
+ }
+ set_font_name(k, new_font_name);
+
+ /* create the corresponding virtual font */
+ set_font_type(k,virtual_font_type);
+
+ vf_z = font_size(f);
+ vf_replace_z();
+ w = round_xn_over_d(quad(f), e, 2000);
+ if (w > 0) {
+ tmp_b0 = 0;
+ } else {
+ tmp_b0 = 255;
+ w = vf_alpha + w;
+ }
+ r = w*vf_beta;
+ tmp_b1 = r / vf_z;
+ r = r % vf_z;
+ if (r == 0) {
+ tmp_b2 = 0;
+ } else {
+ r = r * 256;
+ tmp_b2 = r / vf_z;
+ r = r % vf_z;
+ }
+ if (r == 0) {
+ tmp_b3 = 0;
+ } else {
+ r = r * 256;
+ tmp_b3 = r / vf_z;
+ }
+ /*
+ vf_packet_base[k] = new_vf_packet(k);
+
+ for (c=font_bc(k);c<=font_ec(k);c++) {
+ string_room(17);
+ append_fnt_set(f);
+ append_packet(right1 + 3);
+ append_packet(tmp_b0);
+ append_packet(tmp_b1);
+ append_packet(tmp_b2);
+ append_packet(tmp_b3);
+
+ append_packet(set1);
+ append_packet(c);
+
+ append_packet(right1 + 3);
+ append_packet(tmp_b0);
+ append_packet(tmp_b1);
+ append_packet(tmp_b2);
+ append_packet(tmp_b3);
+ s = make_string();
+ store_packet(k, c, s);
+ flush_str(s);
+ }
+*/
+ return k;
+}
+
+
diff --git a/Build/source/texk/web2c/luatexdir/font/vfpacket.c b/Build/source/texk/web2c/luatexdir/font/vfpacket.c
new file mode 100644
index 00000000000..4d8445f2227
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/vfpacket.c
@@ -0,0 +1,377 @@
+/*
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: vfpacket.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+
+/*
+ The |do_vf_packet| procedure is called in order to interpret the
+ character packet for a virtual character. Such a packet may contain
+ the instruction to typeset a character from the same or an other
+ virtual font; in such cases |do_vf_packet| calls itself
+ recursively. The recursion level, i.e., the number of times this has
+ happened, is kept in the global variable |packet_cur_s| and should
+ not exceed |packet_max_recursion|.
+*/
+
+#define packet_max_recursion 100
+
+typedef unsigned char packet_stack_index ; /* an index into the stack */
+
+typedef struct packet_stack_record {
+ scaled stack_h;
+ scaled stack_v;
+} packet_stack_record;
+
+
+static packet_stack_index packet_cur_s = 0; /* current recursion level */
+static packet_stack_record packet_stack [packet_max_recursion];
+static packet_stack_index packet_stack_ptr = 0; /* pointer into |packet_stack| */
+
+
+/* Some macros for processing character packets. */
+
+#define do_packet_byte() vf_packets[cur_packet_byte++]
+
+#define packet_number(fw) { \
+ fw = do_packet_byte(); \
+ fw = fw*256 + do_packet_byte(); \
+ fw = fw*256 + do_packet_byte(); \
+ fw = fw*256 + do_packet_byte(); }
+
+#define packet_scaled(a,fs) { integer fw; \
+ fw = do_packet_byte(); \
+ if (fw>127) fw = fw - 256; \
+ fw = fw*256 + do_packet_byte(); \
+ fw = fw*256 + do_packet_byte(); \
+ fw = fw*256 + do_packet_byte(); \
+ a = sqxfw(fw, fs); }
+
+
+/* count the number of bytes in a command packet */
+int
+vf_packet_bytes (charinfo *co) {
+ real_eight_bits *vf_packets;
+ integer cur_packet_byte;
+ unsigned k;
+ int cmd;
+
+ vf_packets = get_charinfo_packets(co);
+ if (vf_packets == NULL) {
+ return 0;
+ }
+ cur_packet_byte = 0;
+ while ((cmd = vf_packets[cur_packet_byte]) != packet_end_code) {
+ cur_packet_byte++;
+ switch (cmd) {
+ case packet_char_code:
+ case packet_font_code:
+ case packet_right_code:
+ case packet_down_code:
+ case packet_node_code:
+ cur_packet_byte += 4;
+ break;
+ case packet_push_code:
+ case packet_pop_code:
+ break;
+ case packet_rule_code:
+ cur_packet_byte += 8;
+ break;
+ case packet_special_code:
+ packet_number(k); /* +4 */
+ cur_packet_byte += k;
+ break;
+ case packet_nop_code:
+ break;
+ default:
+ pdf_error("vf", "invalid DVI command");
+ }
+ };
+ return (cur_packet_byte +1);
+}
+
+
+/* typeset the \.{DVI} commands in the
+ character packet for character |c| in current font |f| */
+
+char *packet_command_names[] = {
+ "char", "font","pop", "push", "special",
+ "right","down","rule","node", "nop","end", NULL};
+
+
+void
+do_vf_packet (internal_font_number vf_f, integer c) {
+ internal_font_number lf;
+ charinfo *co;
+ scaled save_cur_h, save_cur_v;
+ real_eight_bits *vf_packets;
+ integer cur_packet_byte;
+ integer cmd, fs_f;
+ scaled i;
+ unsigned k;
+ str_number s;
+
+ packet_cur_s++;
+ if (packet_cur_s >= packet_max_recursion)
+ overflow_string("max level recursion of virtual fonts", packet_max_recursion);
+ save_cur_v = cur_v;
+ save_cur_h = cur_h;
+
+ lf = 0; /* for -Wall */
+ co = get_charinfo(vf_f,c);
+ vf_packets = get_charinfo_packets(co);
+ if (vf_packets == NULL) {
+ packet_cur_s--;
+ return ;
+ }
+ cur_packet_byte = 0;
+ fs_f = font_size(vf_f);
+ while ((cmd = vf_packets[cur_packet_byte]) != packet_end_code) {
+ cur_packet_byte++;
+ /*
+ if (cmd>packet_end_code) {
+ fprintf(stdout, "do_vf_packet(%i,%i) command code = illegal \n", vf_f,c);
+ } else {
+ fprintf(stdout, "do_vf_packet(%i,%i) command code = %s\n",vf_f, c, packet_command_names[cmd]);
+ }
+ */
+ switch (cmd) {
+ case packet_font_code:
+ packet_number(lf);
+ break;
+ case packet_push_code:
+ packet_stack[packet_stack_ptr].stack_h = cur_h;
+ packet_stack[packet_stack_ptr].stack_v = cur_v;
+ packet_stack_ptr++;
+ break;
+ case packet_pop_code:
+ packet_stack_ptr--;
+ cur_h = packet_stack[packet_stack_ptr].stack_h;
+ cur_v = packet_stack[packet_stack_ptr].stack_v;
+ break;
+ case packet_char_code:
+ packet_number(k);
+ if (!char_exists(lf,k)) {
+ char_warning(lf, k);
+ } else {
+ output_one_char(lf, k);
+ }
+ cur_h = cur_h + char_width(lf,k);
+ break;
+ case packet_rule_code:
+ packet_scaled(rule_ht,fs_f);
+ packet_scaled(rule_wd,fs_f);
+ if ((rule_wd > 0) && (rule_ht > 0)) {
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ cur_h = cur_h + rule_wd;
+ }
+ break;
+ case packet_right_code:
+ packet_scaled(i,fs_f);
+ cur_h = cur_h + i;
+ break;
+ case packet_down_code:
+ packet_scaled(i,fs_f);
+ cur_v = cur_v + i;
+ break;
+ case packet_special_code:
+ packet_number(k);
+ string_room(k);
+ while (k > 0) {
+ k--;
+ append_pool_char(do_packet_byte());
+ }
+ s = make_string();
+ literal(s, scan_special, false);
+ flush_str(s);
+ break;
+ case packet_node_code:
+ packet_number(k);
+ temp_ptr = k;
+ pdf_hlist_out();
+ break;
+ case packet_nop_code:
+ break;
+ default:
+ pdf_error("vf", "invalid DVI command");
+ }
+ };
+ cur_h = save_cur_h;
+ cur_v = save_cur_v;
+ packet_cur_s--;
+}
+
+
+integer *packet_local_fonts(internal_font_number f, integer *num) {
+ int c, cmd, cur_packet_byte, lf, k,l, i;
+ integer localfonts[256] = {0};
+ integer *lfs;
+ charinfo *co;
+
+ real_eight_bits *vf_packets;
+ k = 0;
+ for (c = font_bc(f);c <= font_ec(f);c++) {
+ if (char_exists(f,c)) {
+ co = get_charinfo(f,c);
+ vf_packets = get_charinfo_packets(co);
+ if (vf_packets == NULL)
+ continue;
+ cur_packet_byte = 0;
+ while ((cmd = vf_packets[cur_packet_byte]) != packet_end_code) {
+ cur_packet_byte++;
+ switch (cmd) {
+ case packet_font_code:
+ packet_number(lf);
+ for (l=0;l<k;l++) {
+ if (localfonts[l]==lf) {
+ break;
+ }
+ }
+ if (l==k) {
+ localfonts[k++]=lf;
+ }
+ break;
+ case packet_push_code:
+ case packet_pop_code:
+ case packet_nop_code:
+ break;
+ case packet_char_code:
+ case packet_right_code:
+ case packet_down_code:
+ case packet_node_code:
+ cur_packet_byte+=4;
+ break;
+ case packet_rule_code:
+ cur_packet_byte+=8;
+ break;
+ case packet_special_code:
+ packet_number(i);
+ while (i-- > 0)
+ (void)do_packet_byte();
+ break;
+ default:
+ pdf_error("vf", "invalid DVI command");
+ }
+ }
+ }
+ }
+ *num = k;
+ if (k>0) {
+ lfs = xmalloc (k*sizeof(integer));
+ memcpy(lfs,localfonts,k*sizeof(integer));
+ return lfs;
+ }
+ return NULL;
+}
+
+
+void
+replace_packet_fonts(internal_font_number f, integer *old_fontid, integer *new_fontid, int count) {
+ int c, cmd, cur_packet_byte, lf, k,l;
+ charinfo *co;
+ real_eight_bits *vf_packets;
+
+ k = 0;
+ for (c = font_bc(f);c <= font_ec(f);c++) {
+ if (char_exists(f,c)) {
+ co = get_charinfo(f,c);
+ vf_packets = get_charinfo_packets(co);
+ if (vf_packets == NULL)
+ continue;
+ cur_packet_byte = 0;
+ while ((cmd = vf_packets[cur_packet_byte]) != packet_end_code) {
+ cur_packet_byte++;
+ switch (cmd) {
+ case packet_font_code:
+ packet_number(lf);
+ for (l=0;l<count;l++) {
+ if (old_fontid[l]==lf) {
+ break;
+ }
+ }
+ if(l<count) {
+ k = new_fontid[l];
+ vf_packets[(cur_packet_byte-4)] = (k&0xFF000000)>>24;
+ vf_packets[(cur_packet_byte-3)] = (k&0x00FF0000)>>16;
+ vf_packets[(cur_packet_byte-2)] = (k&0x0000FF00)>>8;
+ vf_packets[(cur_packet_byte-1)] = (k&0x000000FF);
+ }
+ break;
+ case packet_push_code:
+ case packet_pop_code:
+ case packet_nop_code:
+ break;
+ case packet_char_code:
+ case packet_right_code:
+ case packet_down_code:
+ case packet_node_code:
+ cur_packet_byte+=4;
+ break;
+ case packet_rule_code:
+ cur_packet_byte+=8;
+ break;
+ case packet_special_code:
+ packet_number(k);
+ while (k-- > 0)
+ (void)do_packet_byte();
+ break;
+ default:
+ pdf_error("vf", "invalid DVI command");
+ }
+ }
+ }
+ }
+}
+
+/* this function was copied/borrowed/stolen from dvipdfm code */
+
+scaled sqxfw (scaled sq, integer fw)
+{
+ int sign = 1;
+ unsigned long a, b, c, d, ad, bd, bc, ac;
+ unsigned long e, f, g, h, i, j, k;
+ unsigned long result;
+ /* Make positive. */
+ if (sq < 0) {
+ sign = -sign;
+ sq = -sq;
+ }
+ if (fw < 0) {
+ sign = -sign;
+ fw = -fw;
+ }
+ a = ((unsigned long) sq) >> 16u;
+ b = ((unsigned long) sq) & 0xffffu;
+ c = ((unsigned long) fw) >> 16u;
+ d = ((unsigned long) fw) & 0xffffu;
+ ad = a*d; bd = b*d; bc = b*c; ac = a*c;
+ e = bd >> 16u;
+ f = ad >> 16u;
+ g = ad & 0xffffu;
+ h = bc >> 16u;
+ i = bc & 0xffffu;
+ j = ac >> 16u;
+ k = ac & 0xffffu;
+ result = (e+g+i + (1<<3)) >> 4u; /* 1<<3 is for rounding */
+ result += (f+h+k) << 12u;
+ result += j << 28u;
+ return (sign>0)?result:-result;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/writecff.c b/Build/source/texk/web2c/luatexdir/font/writecff.c
new file mode 100644
index 00000000000..69c35c6950e
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writecff.c
@@ -0,0 +1,3381 @@
+/*
+Copyright (c) 2007 Taco Hoekwater, taco@luatex.org
+
+This file is part of luaTeX.
+
+luaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+luaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with luaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writecff.c 1021 2008-02-14 10:24:34Z taco $
+*/
+
+#include "ptexlib.h"
+
+#include "writecff.h"
+
+#define get_offset(s,n) get_unsigned(s, (n))
+#define get_card8(a) a->stream[a->offset++]
+#define get_card16(a) get_unsigned(a,2)
+
+#undef b0
+#undef b1
+#undef b2
+#undef b3
+
+#define WORK_BUFFER_SIZE 1024
+
+static char work_buffer[WORK_BUFFER_SIZE];
+
+static unsigned long get_unsigned (cff_font *cff, int n)
+{
+ unsigned long v = 0;
+ while (n-- > 0)
+ v = v*256 + get_card8(cff);
+ return v;
+}
+
+#define CFF_ERROR pdftex_fail
+#define WARN pdftex_warn
+
+
+const char *const cff_stdstr[CFF_STDSTR_MAX] = {
+ ".notdef", "space", "exclam", "quotedbl", "numbersign",
+ "dollar", "percent", "ampersand", "quoteright", "parenleft",
+ "parenright", "asterisk", "plus", "comma", "hyphen",
+ "period", "slash", "zero", "one", "two",
+ "three", "four", "five", "six", "seven",
+ "eight", "nine", "colon", "semicolon", "less",
+ "equal", "greater", "question", "at", "A",
+ "B", "C", "D", "E", "F",
+ "G", "H", "I", "J", "K",
+ "L", "M", "N", "O", "P",
+ "Q", "R", "S", "T", "U",
+ "V", "W", "X", "Y", "Z",
+ "bracketleft", "backslash", "bracketright", "asciicircum", "underscore",
+ "quoteleft", "a", "b", "c", "d",
+ "e", "f", "g", "h", "i",
+ "j", "k", "l", "m", "n",
+ "o", "p", "q", "r", "s",
+ "t", "u", "v", "w", "x",
+ "y", "z", "braceleft", "bar", "braceright",
+ "asciitilde", "exclamdown", "cent", "sterling", "fraction",
+ "yen", "florin", "section", "currency", "quotesingle",
+ "quotedblleft", "guillemotleft", "guilsinglleft", "guilsinglright", "fi",
+ "fl", "endash", "dagger", "daggerdbl", "periodcentered",
+ "paragraph", "bullet", "quotesinglbase", "quotedblbase", "quotedblright",
+ "guillemotright", "ellipsis", "perthousand", "questiondown", "grave",
+ "acute", "circumflex", "tilde", "macron", "breve",
+ "dotaccent", "dieresis", "ring", "cedilla", "hungarumlaut",
+ "ogonek", "caron", "emdash", "AE", "ordfeminine",
+ "Lslash", "Oslash", "OE", "ordmasculine", "ae",
+ "dotlessi", "lslash", "oslash", "oe", "germandbls",
+ "onesuperior", "logicalnot", "mu", "trademark", "Eth",
+ "onehalf", "plusminus", "Thorn", "onequarter", "divide",
+ "brokenbar", "degree", "thorn", "threequarters", "twosuperior",
+ "registered", "minus", "eth", "multiply", "threesuperior",
+ "copyright", "Aacute", "Acircumflex", "Adieresis", "Agrave",
+ "Aring", "Atilde", "Ccedilla", "Eacute", "Ecircumflex",
+ "Edieresis", "Egrave", "Iacute", "Icircumflex", "Idieresis",
+ "Igrave", "Ntilde", "Oacute", "Ocircumflex", "Odieresis",
+ "Ograve", "Otilde", "Scaron", "Uacute", "Ucircumflex",
+ "Udieresis", "Ugrave", "Yacute", "Ydieresis", "Zcaron",
+ "aacute", "acircumflex", "adieresis", "agrave", "aring",
+ "atilde", "ccedilla", "eacute", "ecircumflex", "edieresis",
+ "egrave", "iacute", "icircumflex", "idieresis", "igrave",
+ "ntilde", "oacute", "ocircumflex", "odieresis", "ograve",
+ "otilde", "scaron", "uacute", "ucircumflex", "udieresis",
+ "ugrave", "yacute", "ydieresis", "zcaron", "exclamsmall",
+ "Hungarumlautsmall", "dollaroldstyle", "dollarsuperior", "ampersandsmall", "Acutesmall",
+ "parenleftsuperior", "parenrightsuperior", "twodotenleader", "onedotenleader", "zerooldstyle",
+ "oneoldstyle", "twooldstyle", "threeoldstyle", "fouroldstyle", "fiveoldstyle",
+ "sixoldstyle", "sevenoldstyle", "eightoldstyle", "nineoldstyle", "commasuperior",
+ "threequartersemdash", "periodsuperior", "questionsmall", "asuperior", "bsuperior",
+ "centsuperior", "dsuperior", "esuperior", "isuperior", "lsuperior",
+ "msuperior", "nsuperior", "osuperior", "rsuperior", "ssuperior",
+ "tsuperior", "ff", "ffi", "ffl", "parenleftinferior",
+ "parenrightinferior", "Circumflexsmall", "hyphensuperior", "Gravesmall", "Asmall",
+ "Bsmall", "Csmall", "Dsmall", "Esmall", "Fsmall",
+ "Gsmall", "Hsmall", "Ismall", "Jsmall", "Ksmall",
+ "Lsmall", "Msmall", "Nsmall", "Osmall", "Psmall",
+ "Qsmall", "Rsmall", "Ssmall", "Tsmall", "Usmall",
+ "Vsmall", "Wsmall", "Xsmall", "Ysmall", "Zsmall",
+ "colonmonetary", "onefitted", "rupiah", "Tildesmall", "exclamdownsmall",
+ "centoldstyle", "Lslashsmall", "Scaronsmall", "Zcaronsmall", "Dieresissmall",
+ "Brevesmall", "Caronsmall", "Dotaccentsmall", "Macronsmall", "figuredash",
+ "hypheninferior", "Ogoneksmall", "Ringsmall", "Cedillasmall", "questiondownsmall",
+ "oneeighth", "threeeighths", "fiveeighths", "seveneighths", "onethird",
+ "twothirds", "zerosuperior", "foursuperior", "fivesuperior", "sixsuperior",
+ "sevensuperior", "eightsuperior", "ninesuperior", "zeroinferior", "oneinferior",
+ "twoinferior", "threeinferior", "fourinferior", "fiveinferior", "sixinferior",
+ "seveninferior", "eightinferior", "nineinferior", "centinferior", "dollarinferior",
+ "periodinferior", "commainferior", "Agravesmall", "Aacutesmall", "Acircumflexsmall",
+ "Atildesmall", "Adieresissmall", "Aringsmall", "AEsmall", "Ccedillasmall",
+ "Egravesmall", "Eacutesmall", "Ecircumflexsmall", "Edieresissmall", "Igravesmall",
+ "Iacutesmall", "Icircumflexsmall", "Idieresissmall", "Ethsmall", "Ntildesmall",
+ "Ogravesmall", "Oacutesmall", "Ocircumflexsmall", "Otildesmall", "Odieresissmall",
+ "OEsmall", "Oslashsmall", "Ugravesmall", "Uacutesmall", "Ucircumflexsmall",
+ "Udieresissmall", "Yacutesmall", "Thornsmall", "Ydieresissmall",
+ "001.000", "001.001", "001.002", "001.003",
+ "Black", "Bold", "Book", "Light", "Medium", "Regular", "Roman", "Semibold"
+};
+
+
+/* Only read header part but not body */
+cff_index *
+cff_get_index_header (cff_font *cff)
+{
+ cff_index *idx;
+ card16 i, count;
+
+ idx = xcalloc(1, sizeof(cff_index));
+
+ idx->count = count = get_card16(cff);
+ if (count > 0) {
+ idx->offsize = get_card8(cff);
+ if (idx->offsize < 1 || idx->offsize > 4)
+ CFF_ERROR("invalid offsize data");
+
+ idx->offset = xcalloc(count+1, sizeof(l_offset));
+ for (i=0;i<count+1;i++) {
+ (idx->offset)[i] = get_offset(cff, idx->offsize);
+ }
+
+ if (idx->offset[0] != 1)
+ CFF_ERROR("cff_get_index(): invalid index data");
+
+ idx->data = NULL;
+ } else {
+ idx->offsize = 0;
+ idx->offset = NULL;
+ idx->data = NULL;
+ }
+
+ return idx;
+}
+
+
+
+cff_index *
+cff_get_index (cff_font *cff)
+{
+ cff_index *idx;
+ card16 i, count;
+ long length;
+
+ idx = xcalloc(1,sizeof(cff_index));
+
+ idx->count = count = get_card16(cff);
+ if (count > 0) {
+ idx->offsize = get_card8(cff);
+ if (idx->offsize < 1 || idx->offsize > 4)
+ CFF_ERROR("invalid offsize data");
+
+ idx->offset = xcalloc((count + 1),sizeof(l_offset));
+ for (i = 0 ; i < count + 1; i++) {
+ idx->offset[i] = get_offset(cff, idx->offsize);
+ }
+
+ if (idx->offset[0] != 1)
+ CFF_ERROR("Invalid CFF Index offset data");
+
+ length = idx->offset[count] - idx->offset[0];
+
+ idx->data = xcalloc(length,sizeof(card8));
+ memcpy(idx->data,&cff->stream[cff->offset],length);
+ cff->offset += length;
+
+ } else {
+ idx->offsize = 0;
+ idx->offset = NULL;
+ idx->data = NULL;
+ }
+ return idx;
+}
+
+
+long
+cff_pack_index (cff_index *idx, card8 *dest, long destlen)
+{
+ long len = 0;
+ unsigned long datalen;
+ card16 i;
+
+ if (idx->count < 1) {
+ if (destlen < 2)
+ CFF_ERROR("Not enough space available...");
+ memset(dest, 0, 2);
+ return 2;
+ }
+
+ len = cff_index_size(idx);
+ datalen = idx->offset[idx->count] - 1;
+
+ if (destlen < len)
+ CFF_ERROR("Not enough space available...");
+
+ *(dest++) = (idx->count >> 8) & 0xff;
+ *(dest++) = idx->count & 0xff;
+
+ if (datalen < 0xffUL) {
+ idx->offsize = 1;
+ *(dest++) = 1;
+ for (i = 0; i <= idx->count; i++) {
+ *(dest++) = (card8) (idx->offset[i] & 0xff);
+ }
+ } else if (datalen < 0xffffUL) {
+ idx->offsize = 2;
+ *(dest++) = 2;
+ for (i = 0; i <= idx->count; i++) {
+ *(dest++) = (card8) ((idx->offset[i] >> 8) & 0xff);
+ *(dest++) = (card8) ( idx->offset[i] & 0xff);
+ }
+ } else if (datalen < 0xffffffUL) {
+ idx->offsize = 3;
+ *(dest++) = 3;
+ for (i = 0; i <= idx->count; i++) {
+ *(dest++) = (card8)((idx->offset[i] >> 16) & 0xff);
+ *(dest++) = (card8)((idx->offset[i] >> 8) & 0xff);
+ *(dest++) = (card8)(idx->offset[i] & 0xff);
+ }
+ } else {
+ idx->offsize = 4;
+ *(dest++) = 4;
+ for (i = 0; i <= idx->count; i++) {
+ *(dest++) = (card8)((idx->offset[i] >> 24) & 0xff);
+ *(dest++) = (card8)((idx->offset[i] >> 16) & 0xff);
+ *(dest++) = (card8)((idx->offset[i] >> 8) & 0xff);
+ *(dest++) = (card8)(idx->offset[i] & 0xff);
+ }
+ }
+
+ memmove(dest, idx->data, idx->offset[idx->count] - 1);
+
+ return len;
+}
+
+long
+cff_index_size (cff_index *idx)
+{
+ if (idx->count > 0) {
+ l_offset datalen;
+
+ datalen = idx->offset[idx->count] - 1;
+ if (datalen < 0xffUL) {
+ idx->offsize = 1;
+ } else if (datalen < 0xffffUL) {
+ idx->offsize = 2;
+ } else if (datalen < 0xffffffUL) {
+ idx->offsize = 3;
+ } else {
+ idx->offsize = 4;
+ }
+ return (3 + (idx->offsize)*(idx->count + 1) + datalen);
+ } else {
+ return 2;
+ }
+}
+
+cff_index *cff_new_index (card16 count)
+{
+ cff_index *idx;
+
+ idx = xcalloc(1, sizeof(cff_index));
+ idx->count = count;
+ idx->offsize = 0;
+
+ if (count > 0) {
+ idx->offset = xcalloc(count + 1, sizeof(l_offset));
+ (idx->offset)[0] = 1;
+ } else {
+ idx->offset = NULL;
+ }
+ idx->data = NULL;
+
+ return idx;
+}
+
+
+void cff_release_index (cff_index *idx)
+{
+ if (idx) {
+ xfree(idx->data);
+ xfree(idx->offset);
+ xfree(idx);
+ }
+}
+
+void cff_release_dict (cff_dict *dict)
+{
+ if (dict) {
+ if (dict->entries) {
+ int i;
+ for (i=0;i<dict->count;i++) {
+ xfree((dict->entries)[i].values);
+ }
+ xfree(dict->entries);
+ }
+ xfree(dict);
+ }
+}
+
+
+void cff_release_encoding (cff_encoding *encoding)
+{
+ if (encoding) {
+ switch (encoding->format & (~0x80)) {
+ case 0: xfree(encoding->data.codes); break;
+ case 1: xfree(encoding->data.range1); break;
+ default: CFF_ERROR("Unknown Encoding format.");
+ }
+ if (encoding->format & 0x80)
+ xfree(encoding->supp);
+ xfree(encoding);
+ }
+}
+
+void
+cff_release_charsets (cff_charsets *charset)
+{
+ if (charset) {
+ switch (charset->format) {
+ case 0: xfree(charset->data.glyphs); break;
+ case 1: xfree(charset->data.range1); break;
+ case 2: xfree(charset->data.range2); break;
+ default: break;
+ }
+ xfree(charset);
+ }
+}
+
+void cff_release_fdselect (cff_fdselect *fdselect)
+{
+ if (fdselect) {
+ if (fdselect->format == 0) { xfree(fdselect->data.fds); }
+ else if (fdselect->format == 3) { xfree(fdselect->data.ranges); }
+ xfree(fdselect);
+ }
+}
+
+
+void
+cff_close (cff_font *cff)
+{
+ card16 i;
+
+ if (cff) {
+ if (cff->fontname) xfree(cff->fontname);
+ if (cff->name) cff_release_index(cff->name);
+ if (cff->topdict) cff_release_dict(cff->topdict);
+ if (cff->string) cff_release_index(cff->string);
+ if (cff->gsubr) cff_release_index(cff->gsubr);
+ if (cff->encoding) cff_release_encoding(cff->encoding);
+ if (cff->charsets) cff_release_charsets(cff->charsets);
+ if (cff->fdselect) cff_release_fdselect(cff->fdselect);
+ if (cff->cstrings) cff_release_index(cff->cstrings);
+ if (cff->fdarray) {
+ for (i=0;i<cff->num_fds;i++) {
+ if (cff->fdarray[i]) cff_release_dict(cff->fdarray[i]);
+ }
+ xfree(cff->fdarray);
+ }
+ if (cff->private) {
+ for (i=0;i<cff->num_fds;i++) {
+ if (cff->private[i]) cff_release_dict(cff->private[i]);
+ }
+ xfree(cff->private);
+ }
+ if (cff->subrs) {
+ for (i=0;i<cff->num_fds;i++) {
+ if (cff->subrs[i]) cff_release_index(cff->subrs[i]);
+ }
+ xfree(cff->subrs);
+ }
+ if (cff->_string)
+ cff_release_index(cff->_string);
+ xfree(cff);
+ }
+
+ return;
+}
+
+char *
+cff_get_name (cff_font *cff)
+{
+ char *fontname;
+ l_offset len;
+ cff_index *idx;
+
+ idx = cff->name;
+ len = idx->offset[cff->index + 1] - idx->offset[cff->index];
+ fontname = xmalloc((len + 1)*sizeof(char));
+ memcpy(fontname, idx->data + idx->offset[cff->index] - 1, len);
+ fontname[len] = '\0';
+
+ return fontname;
+}
+
+
+long
+cff_set_name (cff_font *cff, char *name)
+{
+ cff_index *idx;
+
+ if (strlen(name) > 127)
+ CFF_ERROR("FontName string length too large...");
+
+ if (cff->name)
+ cff_release_index(cff->name);
+
+ cff->name = idx = xcalloc(1, sizeof(cff_index));
+ idx->count = 1;
+ idx->offsize = 1;
+ idx->offset = xmalloc(2*sizeof(l_offset));
+ (idx->offset)[0] = 1;
+ (idx->offset)[1] = strlen(name) + 1;
+ idx->data = xcalloc(strlen(name), sizeof(card8));
+ memmove(idx->data, name, strlen(name)); /* no trailing '\0' */
+
+ return 5 + strlen(name);
+}
+
+long
+cff_put_header (cff_font *cff, card8 *dest, long destlen)
+{
+ if (destlen < 4)
+ CFF_ERROR("Not enough space available...");
+
+ *(dest++) = cff->header_major;
+ *(dest++) = cff->header_minor;
+ *(dest++) = 4; /* Additional data in between header and
+ * Name INDEX ignored.
+ */
+ /* We will set all offset (0) to four-byte integer. */
+ *(dest++) = 4;
+ cff->header_offsize = 4;
+
+ return 4;
+}
+
+#define CFF_PARSE_OK 0
+#define CFF_CFF_ERROR_PARSE_CFF_ERROR -1
+#define CFF_CFF_ERROR_STACK_OVERFLOW -2
+#define CFF_CFF_ERROR_STACK_UNDERFLOW -3
+#define CFF_CFF_ERROR_STACK_RANGECHECK -4
+
+#define DICT_ENTRY_MAX 16
+
+cff_dict *cff_new_dict (void)
+{
+ cff_dict *dict;
+
+ dict = xcalloc(1, sizeof(cff_dict));
+ dict->max = DICT_ENTRY_MAX;
+ dict->count = 0;
+ dict->entries = xcalloc(dict->max, sizeof(cff_dict_entry));
+ return dict;
+}
+
+/*
+ * Operand stack:
+ * only numbers are stored (as double)
+ *
+ * Operand types:
+ *
+ * number : double (integer or real)
+ * boolean: stored as a number
+ * SID : stored as a number
+ * array : array of numbers
+ * delta : array of numbers
+ */
+
+#define CFF_DICT_STACK_LIMIT 64
+static int stack_top = 0;
+static double arg_stack[CFF_DICT_STACK_LIMIT];
+
+/*
+ * CFF DICT encoding:
+ * TODO: default values
+ */
+
+#define CFF_LAST_DICT_OP1 22
+#define CFF_LAST_DICT_OP2 39
+#define CFF_LAST_DICT_OP (CFF_LAST_DICT_OP1 + CFF_LAST_DICT_OP2)
+
+static struct {
+ const char *opname;
+ int argtype;
+} dict_operator[CFF_LAST_DICT_OP] = {
+ {"version", CFF_TYPE_SID},
+ {"Notice", CFF_TYPE_SID},
+ {"FullName", CFF_TYPE_SID},
+ {"FamilyName", CFF_TYPE_SID},
+ {"Weight", CFF_TYPE_SID},
+ {"FontBBox", CFF_TYPE_ARRAY},
+ {"BlueValues", CFF_TYPE_DELTA},
+ {"OtherBlues", CFF_TYPE_DELTA},
+ {"FamilyBlues", CFF_TYPE_DELTA},
+ {"FamilyOtherBlues", CFF_TYPE_DELTA},
+ {"StdHW", CFF_TYPE_NUMBER},
+ {"StdVW", CFF_TYPE_NUMBER},
+ {NULL, -1}, /* first byte of two-byte operator */
+ /* Top */
+ {"UniqueID", CFF_TYPE_NUMBER},
+ {"XUID", CFF_TYPE_ARRAY},
+ {"charset", CFF_TYPE_OFFSET},
+ {"Encoding", CFF_TYPE_OFFSET},
+ {"CharStrings", CFF_TYPE_OFFSET},
+ {"Private", CFF_TYPE_SZOFF}, /* two numbers (size and offset) */
+ /* Private */
+ {"Subrs", CFF_TYPE_OFFSET},
+ {"defaultWidthX", CFF_TYPE_NUMBER},
+ {"nominalWidthX", CFF_TYPE_NUMBER},
+ /* Operator 2 */
+ {"Copyright", CFF_TYPE_SID},
+ {"IsFixedPitch", CFF_TYPE_BOOLEAN},
+ {"ItalicAngle", CFF_TYPE_NUMBER},
+ {"UnderlinePosition", CFF_TYPE_NUMBER},
+ {"UnderlineThickness", CFF_TYPE_NUMBER},
+ {"PaintType", CFF_TYPE_NUMBER},
+ {"CharstringType", CFF_TYPE_NUMBER},
+ {"FontMatrix", CFF_TYPE_ARRAY},
+ {"StrokeWidth", CFF_TYPE_NUMBER},
+ {"BlueScale", CFF_TYPE_NUMBER},
+ {"BlueShift", CFF_TYPE_NUMBER},
+ {"BlueFuzz", CFF_TYPE_NUMBER},
+ {"StemSnapH", CFF_TYPE_DELTA},
+ {"StemSnapV", CFF_TYPE_DELTA},
+ {"ForceBold", CFF_TYPE_BOOLEAN},
+ {NULL, -1},
+ {NULL, -1},
+ {"LanguageGroup", CFF_TYPE_NUMBER},
+ {"ExpansionFactor", CFF_TYPE_NUMBER},
+ {"InitialRandomSeed", CFF_TYPE_NUMBER},
+ {"SyntheticBase", CFF_TYPE_NUMBER},
+ {"PostScript", CFF_TYPE_SID},
+ {"BaseFontName", CFF_TYPE_SID},
+ {"BaseFontBlend", CFF_TYPE_DELTA}, /* MMaster ? */
+ {NULL, -1},
+ {NULL, -1},
+ {NULL, -1},
+ {NULL, -1},
+ {NULL, -1},
+ {NULL, -1},
+ /* CID-Keyed font */
+ {"ROS", CFF_TYPE_ROS}, /* SID SID number */
+ {"CIDFontVersion", CFF_TYPE_NUMBER},
+ {"CIDFontRevision", CFF_TYPE_NUMBER},
+ {"CIDFontType", CFF_TYPE_NUMBER},
+ {"CIDCount", CFF_TYPE_NUMBER},
+ {"UIDBase", CFF_TYPE_NUMBER},
+ {"FDArray", CFF_TYPE_OFFSET},
+ {"FDSelect", CFF_TYPE_OFFSET},
+ {"FontName", CFF_TYPE_SID},
+};
+
+/* Parse DICT data */
+static double get_integer (card8 **data, card8 *endptr, int *status)
+{
+ long result = 0;
+ card8 b0, b1, b2;
+
+ b0 = *(*data)++;
+ if (b0 == 28 && *data < endptr - 2) { /* shortint */
+ b1 = *(*data)++;
+ b2 = *(*data)++;
+ result = b1*256+b2;
+ if (result > 0x7fffL)
+ result -= 0x10000L;
+ } else if (b0 == 29 && *data < endptr - 4) { /* longint */
+ int i;
+ result = *(*data)++;
+ if (result > 0x7f)
+ result -= 0x100;
+ for (i=0;i<3;i++) {
+ result = result*256+(**data);
+ *data += 1;
+ }
+ } else if (b0 >= 32 && b0 <= 246) { /* int (1) */
+ result = b0 - 139;
+ } else if (b0 >= 247 && b0 <= 250) { /* int (2) */
+ b1 = *(*data)++;
+ result = (b0-247)*256+b1+108;
+ } else if (b0 >= 251 && b0 <= 254) {
+ b1 = *(*data)++;
+ result = -(b0-251)*256-b1-108;
+ } else {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ }
+
+ return (double) result;
+}
+
+/* Simply uses strtod */
+static double get_real(card8 **data, card8 *endptr, int *status)
+{
+ double result = 0.0;
+ int nibble = 0, pos = 0;
+ int len = 0, fail = 0;
+
+ if (**data != 30 || *data >= endptr -1) {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ return 0.0;
+ }
+
+ *data += 1; /* skip first byte (30) */
+
+ pos = 0;
+ while ((! fail) && len < WORK_BUFFER_SIZE - 2 && *data < endptr) {
+ /* get nibble */
+ if (pos % 2) {
+ nibble = **data & 0x0f;
+ *data += 1;
+ } else {
+ nibble = (**data >> 4) & 0x0f;
+ }
+ if (nibble >= 0x00 && nibble <= 0x09) {
+ work_buffer[len++] = nibble + '0';
+ } else if (nibble == 0x0a) { /* . */
+ work_buffer[len++] = '.';
+ } else if (nibble == 0x0b || nibble == 0x0c) { /* E, E- */
+ work_buffer[len++] = 'e';
+ if (nibble == 0x0c)
+ work_buffer[len++] = '-';
+ } else if (nibble == 0x0e) { /* `-' */
+ work_buffer[len++] = '-';
+ } else if (nibble == 0x0d) { /* skip */
+ /* do nothing */
+ } else if (nibble == 0x0f) { /* end */
+ work_buffer[len++] = '\0';
+ if (((pos % 2) == 0) && (**data != 0xff)) {
+ fail = 1;
+ }
+ break;
+ } else { /* invalid */
+ fail = 1;
+ }
+ pos++;
+ }
+
+ /* returned values */
+ if (fail || nibble != 0x0f) {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ } else {
+ char *s;
+ result = strtod(work_buffer, &s);
+ if (*s != 0 || errno == ERANGE) {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ }
+ }
+
+ return result;
+}
+
+/* operators */
+static void add_dict (cff_dict *dict,
+ card8 **data, card8 *endptr, int *status)
+{
+ int id, argtype;
+
+ id = **data;
+ if (id == 0x0c) {
+ *data += 1;
+ if (*data >= endptr ||
+ (id = **data + CFF_LAST_DICT_OP1) >= CFF_LAST_DICT_OP) {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ return;
+ }
+ } else if (id >= CFF_LAST_DICT_OP1) {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ return;
+ }
+
+ argtype = dict_operator[id].argtype;
+ if (dict_operator[id].opname == NULL || argtype < 0) {
+ *status = CFF_CFF_ERROR_PARSE_CFF_ERROR;
+ return;
+ } else if (stack_top < 1) {
+ *status = CFF_CFF_ERROR_STACK_UNDERFLOW;
+ return;
+ }
+
+ if (dict->count >= dict->max) {
+ dict->max += DICT_ENTRY_MAX;
+ /* not zeroed! */
+ dict->entries = xrealloc(dict->entries, dict->max*sizeof(cff_dict_entry));
+ }
+
+ (dict->entries)[dict->count].id = id;
+ (dict->entries)[dict->count].key = (char *) dict_operator[id].opname;
+ if (argtype == CFF_TYPE_NUMBER ||
+ argtype == CFF_TYPE_BOOLEAN ||
+ argtype == CFF_TYPE_SID ||
+ argtype == CFF_TYPE_OFFSET) {
+ stack_top--;
+ (dict->entries)[dict->count].count = 1;
+ (dict->entries)[dict->count].values = xcalloc(1, sizeof(double));
+ (dict->entries)[dict->count].values[0] = arg_stack[stack_top];
+ } else {
+ (dict->entries)[dict->count].count = stack_top;
+ (dict->entries)[dict->count].values = xcalloc(stack_top, sizeof(double));
+ while (stack_top > 0) {
+ stack_top--;
+ (dict->entries)[dict->count].values[stack_top] = arg_stack[stack_top];
+ }
+ }
+
+ dict->count += 1;
+ *data += 1;
+
+ return;
+}
+
+/*
+ * All operands are treated as number or array of numbers.
+ * Private: two numbers, size and offset
+ * ROS : three numbers, SID, SID, and a number
+ */
+cff_dict *cff_dict_unpack (card8 *data, card8 *endptr)
+{
+ cff_dict *dict;
+ int status = CFF_PARSE_OK;
+
+ stack_top = 0;
+
+ dict = cff_new_dict();
+ while (data < endptr && status == CFF_PARSE_OK) {
+ if (*data < 22) { /* operator */
+ add_dict(dict, &data, endptr, &status);
+ } else if (*data == 30) { /* real - First byte of a sequence (variable) */
+ if (stack_top < CFF_DICT_STACK_LIMIT) {
+ arg_stack[stack_top] = get_real(&data, endptr, &status);
+ stack_top++;
+ } else {
+ status = CFF_CFF_ERROR_STACK_OVERFLOW;
+ }
+ } else if (*data == 255 || (*data >= 22 && *data <= 27)) { /* reserved */
+ data++;
+ } else { /* everything else are integer */
+ if (stack_top < CFF_DICT_STACK_LIMIT) {
+ arg_stack[stack_top] = get_integer(&data, endptr, &status);
+ stack_top++;
+ } else {
+ status = CFF_CFF_ERROR_STACK_OVERFLOW;
+ }
+ }
+ }
+
+ if (status != CFF_PARSE_OK) {
+ pdftex_fail("Parsing CFF DICT failed. (error=%d)", status);
+ } else if (stack_top != 0) {
+ WARN("Garbage in CFF DICT data.");
+ stack_top = 0;
+ }
+
+ return dict;
+}
+
+
+int cff_dict_known (cff_dict *dict, const char *key)
+{
+ int i;
+
+ for (i = 0; i < dict->count; i++) {
+ if (key && strcmp(key, (dict->entries)[i].key) == 0
+ && (dict->entries)[i].count > 0)
+ return 1;
+ }
+
+ return 0;
+}
+
+double cff_dict_get (cff_dict *dict, const char *key, int idx)
+{
+ double value = 0.0;
+ int i;
+
+ assert(key && dict);
+
+ for (i = 0; i < dict->count; i++) {
+ if (strcmp(key, (dict->entries)[i].key) == 0) {
+ if ((dict->entries)[i].count > idx)
+ value = (dict->entries)[i].values[idx];
+ else
+ pdftex_fail("Invalid index number.");
+ break;
+ }
+ }
+
+ if (i == dict->count)
+ pdftex_fail("DICT entry \"%s\" not found.", key);
+
+ return value;
+}
+
+card8 cff_fdselect_lookup (cff_font *cff, card16 gid)
+{
+ card8 fd = 0xff;
+ cff_fdselect *fdsel;
+
+ if (cff->fdselect == NULL)
+ CFF_ERROR("in cff_fdselect_lookup(): FDSelect not available");
+
+ fdsel = cff->fdselect;
+
+ if (gid >= cff->num_glyphs)
+ CFF_ERROR("in cff_fdselect_lookup(): Invalid glyph index");
+
+ switch (fdsel->format) {
+ case 0:
+ fd = fdsel->data.fds[gid];
+ break;
+ case 3:
+ {
+ if (gid == 0) {
+ fd = (fdsel->data).ranges[0].fd;
+ } else {
+ card16 i;
+ for (i=1;i<(fdsel->num_entries);i++) {
+ if (gid < (fdsel->data).ranges[i].first)
+ break;
+ }
+ fd = (fdsel->data).ranges[i-1].fd;
+ }
+ }
+ break;
+ default:
+ CFF_ERROR("in cff_fdselect_lookup(): Invalid FDSelect format");
+ break;
+ }
+
+ if (fd >= cff->num_fds)
+ CFF_ERROR("in cff_fdselect_lookup(): Invalid Font DICT index");
+
+ return fd;
+}
+
+long cff_read_subrs (cff_font *cff)
+{
+ long len = 0;
+ long offset;
+ int i;
+
+
+ if ((cff->flag & FONTTYPE_CIDFONT) && cff->fdselect == NULL) {
+ cff_read_fdselect(cff);
+ }
+
+ if ((cff->flag & FONTTYPE_CIDFONT) && cff->fdarray == NULL) {
+ cff_read_fdarray(cff);
+ }
+
+ if (cff->private == NULL)
+ cff_read_private(cff);
+
+ if (cff->gsubr == NULL) {
+ cff->offset = cff->gsubr_offset;
+ cff->gsubr = cff_get_index(cff);
+ }
+
+ cff->subrs = xcalloc(cff->num_fds, sizeof(cff_index *));
+ if (cff->flag & FONTTYPE_CIDFONT) {
+ for (i=0;i<cff->num_fds;i++) {
+ if (cff->private[i] == NULL ||
+ !cff_dict_known(cff->private[i], "Subrs")) {
+ (cff->subrs)[i] = NULL;
+ } else {
+ offset = (long) cff_dict_get(cff->fdarray[i], "Private", 1);
+ offset += (long) cff_dict_get(cff->private[i], "Subrs", 0);
+ cff->offset = offset;
+ (cff->subrs)[i] = cff_get_index(cff);
+ len += cff_index_size((cff->subrs)[i]);
+ }
+ }
+ } else {
+ if (cff->private[0] == NULL ||
+ !cff_dict_known(cff->private[0], "Subrs")) {
+ (cff->subrs)[0] = NULL;
+ } else {
+ offset = (long) cff_dict_get(cff->topdict, "Private", 1);
+ offset += (long) cff_dict_get(cff->private[0], "Subrs", 0);
+ cff->offset = offset;
+ (cff->subrs)[0] = cff_get_index(cff);
+ len += cff_index_size((cff->subrs)[0]);
+ }
+ }
+
+ return len;
+}
+
+
+long cff_read_fdarray (cff_font *cff)
+{
+ long len = 0;
+ cff_index *idx;
+ long offset, size;
+ card16 i;
+
+ if (cff->topdict == NULL)
+ CFF_ERROR("in cff_read_fdarray(): Top DICT not found");
+
+ if (!(cff->flag & FONTTYPE_CIDFONT))
+ return 0;
+
+ /* must exist */
+ offset = (long) cff_dict_get(cff->topdict, "FDArray", 0);
+ cff->offset = offset;
+ idx = cff_get_index(cff);
+ cff->num_fds = (card8)idx->count;
+ cff->fdarray = xcalloc(idx->count, sizeof(cff_dict *));
+ for (i=0;i<idx->count;i++) {
+ card8 *data = idx->data + (idx->offset)[i] - 1;
+ size = (idx->offset)[i+1] - (idx->offset)[i];
+ if (size > 0) {
+ (cff->fdarray)[i] = cff_dict_unpack(data, data+size);
+ } else {
+ (cff->fdarray)[i] = NULL;
+ }
+ }
+ len = cff_index_size(idx);
+ cff_release_index(idx);
+
+ return len;
+}
+
+
+long cff_read_private (cff_font *cff)
+{
+ long len = 0;
+ card8 *data;
+ long offset, size;
+
+ if (cff->flag & FONTTYPE_CIDFONT) {
+ int i;
+
+ if (cff->fdarray == NULL)
+ cff_read_fdarray(cff);
+
+ cff->private = xcalloc(cff->num_fds, sizeof(cff_dict *));
+ for (i=0;i<cff->num_fds;i++) {
+ if (cff->fdarray[i] != NULL &&
+ cff_dict_known(cff->fdarray[i], "Private") &&
+ (size = (long) cff_dict_get(cff->fdarray[i], "Private", 0))
+ > 0) {
+ offset = (long) cff_dict_get(cff->fdarray[i], "Private", 1);
+ cff->offset = offset;
+ data = xcalloc(size, sizeof(card8));
+ memcpy(data,&cff->stream[cff->offset],size);
+ cff->offset = size;
+ (cff->private)[i] = cff_dict_unpack(data, data+size);
+ xfree(data);
+ len += size;
+ } else {
+ (cff->private)[i] = NULL;
+ }
+ }
+ } else {
+ cff->num_fds = 1;
+ cff->private = xcalloc(1, sizeof(cff_dict *));
+ if (cff_dict_known(cff->topdict, "Private") &&
+ (size = (long) cff_dict_get(cff->topdict, "Private", 0)) > 0) {
+ offset = (long) cff_dict_get(cff->topdict, "Private", 1);
+ cff->offset = offset;
+ data = xcalloc(size, sizeof(card8));
+ memcpy(data,&cff->stream[cff->offset],size);
+ cff->offset = size;
+ cff->private[0] = cff_dict_unpack(data, data+size);
+ xfree(data);
+ len += size;
+ } else {
+ (cff->private)[0] = NULL;
+ len = 0;
+ }
+ }
+
+ return len;
+}
+
+
+cff_font *read_cff (unsigned char *buf,long buflength, int n)
+{
+ cff_font *cff;
+ cff_index *idx;
+ long offset ;
+
+
+ cff = xcalloc(1,sizeof(cff_font));
+
+ cff->stream = buf;
+ cff->stream_size = buflength;
+ cff->index = n;
+
+ cff->header_major = get_card8(cff);
+ cff->header_minor = get_card8(cff);
+ cff->header_hdr_size = get_card8(cff);
+ cff->header_offsize = get_card8(cff);
+ if (cff->header_offsize < 1 || cff->header_offsize > 4) {
+ WARN("invalid offsize data");
+ cff_close(cff);
+ return NULL;
+ }
+ if (cff->header_major > 1) {
+ pdftex_warn("CFF major version %u not supported.",cff->header_major);
+ cff_close(cff);
+ return NULL;
+ }
+ cff->offset = cff->header_hdr_size;
+
+ /* Name INDEX */
+ idx = cff_get_index(cff);
+ if (n > idx->count - 1) {
+ pdftex_warn("Invalid CFF fontset index number.");
+ cff_close(cff);
+ return NULL;
+ }
+
+ cff->name = idx;
+
+ cff->fontname = cff_get_name(cff);
+
+ /* Top DICT INDEX */
+ idx = cff_get_index(cff);
+ if (n > idx->count - 1) {
+ WARN("CFF Top DICT not exist...");
+ cff_close(cff);
+ return NULL;
+ }
+ cff->topdict = cff_dict_unpack(idx->data + idx->offset[n] - 1,
+ idx->data + idx->offset[n + 1] - 1);
+ if (!cff->topdict) {
+ WARN("Parsing CFF Top DICT data failed...");
+ cff_close(cff);
+ return NULL;
+ }
+ cff_release_index(idx);
+
+ if (cff_dict_known(cff->topdict, "CharstringType") &&
+ cff_dict_get(cff->topdict, "CharstringType", 0) != 2) {
+ WARN("Only Type 2 Charstrings supported...");
+ cff_close(cff);
+ return NULL;
+ }
+
+ if (cff_dict_known(cff->topdict, "SyntheticBase")) {
+ WARN("CFF Synthetic font not supported.");
+ cff_close(cff);
+ return NULL;
+ }
+
+ /* String INDEX */
+ cff->string = cff_get_index(cff);
+
+ /* offset to GSubr */
+ cff->gsubr_offset = cff->offset;
+
+ /* Number of glyphs */
+ offset = (long) cff_dict_get(cff->topdict, "CharStrings", 0);
+ cff->offset = offset;
+ cff->num_glyphs = get_card16(cff);
+
+ /* Check for font type */
+ if (cff_dict_known(cff->topdict, "ROS")) {
+ cff->flag |= FONTTYPE_CIDFONT;
+ } else {
+ cff->flag |= FONTTYPE_FONT;
+ }
+
+ /* Check for encoding */
+ if (cff_dict_known(cff->topdict, "Encoding")) {
+ offset = (long) cff_dict_get(cff->topdict, "Encoding", 0);
+ if (offset == 0) { /* predefined */
+ cff->flag |= ENCODING_STANDARD;
+ } else if (offset == 1) {
+ cff->flag |= ENCODING_EXPERT;
+ }
+ } else {
+ cff->flag |= ENCODING_STANDARD;
+ }
+
+ cff->offset = cff->gsubr_offset; /* seek back to GSubr */
+
+ return cff;
+}
+
+/* write a cff for opentype */
+
+
+
+/* Pack DICT data */
+static long pack_integer (card8 *dest, long destlen, long value)
+{
+ long len = 0;
+
+ if (value >= -107 && value <= 107) {
+ if (destlen < 1)
+ CFF_ERROR("Buffer overflow.");
+ dest[0] = (value + 139) & 0xff;
+ len = 1;
+ } else if (value >= 108 && value <= 1131) {
+ if (destlen < 2)
+ CFF_ERROR("Buffer overflow.");
+ value = 0xf700u + value - 108;
+ dest[0] = (value >> 8) & 0xff;
+ dest[1] = value & 0xff;
+ len = 2;
+ } else if (value >= -1131 && value <= -108) {
+ if (destlen < 2)
+ CFF_ERROR("Buffer overflow.");
+ value = 0xfb00u - value - 108;
+ dest[0] = (value >> 8) & 0xff;
+ dest[1] = value & 0xff;
+ len = 2;
+ } else if (value >= -32768 && value <= 32767) { /* shortint */
+ if (destlen < 3)
+ CFF_ERROR("Buffer overflow.");
+ dest[0] = 28;
+ dest[1] = (value >> 8) & 0xff;
+ dest[2] = value & 0xff;
+ len = 3;
+ } else { /* longint */
+ if (destlen < 5)
+ CFF_ERROR("Buffer overflow.");
+ dest[0] = 29;
+ dest[1] = (value >> 24) & 0xff;
+ dest[2] = (value >> 16) & 0xff;
+ dest[3] = (value >> 8) & 0xff;
+ dest[4] = value & 0xff;
+ len = 5;
+ }
+ return len;
+}
+
+static long pack_real (card8 *dest, long destlen, double value)
+{
+ long e;
+ int i = 0, pos = 2;
+#define CFF_REAL_MAX_LEN 17
+
+ if (destlen < 2)
+ CFF_ERROR("Buffer overflow.");
+
+ dest[0] = 30;
+
+ if (value == 0.0) {
+ dest[1] = 0x0f;
+ return 2;
+ }
+
+ if (value < 0.0) {
+ dest[1] = 0xe0;
+ value *= -1.0;
+ pos++;
+ }
+
+ e = 0;
+ if (value >= 10.0) {
+ while (value >= 10.0) {
+ value /= 10.0;
+ e++;
+ }
+ } else if (value < 1.0) {
+ while (value < 1.0) {
+ value *= 10.0;
+ e--;
+ }
+ }
+
+ sprintf(work_buffer, "%1.14g", value);
+ for (i=0;i<CFF_REAL_MAX_LEN;i++) {
+ unsigned char ch = 0;
+ if (work_buffer[i] == '\0') {
+ break;
+ } else if (work_buffer[i] == '.') {
+ ch = 0x0a;
+ } else if (work_buffer[i] >= '0' && work_buffer[i] <= '9') {
+ ch = work_buffer[i] - '0';
+ } else {
+ CFF_ERROR("Invalid character.");
+ }
+
+ if (destlen < pos/2 + 1)
+ CFF_ERROR("Buffer overflow.");
+
+ if (pos % 2) {
+ dest[pos/2] += ch;
+ } else {
+ dest[pos/2] = (ch << 4);
+ }
+ pos++;
+ }
+
+ if (e > 0) {
+ if (pos % 2) {
+ dest[pos/2] += 0x0b;
+ } else {
+ if (destlen < pos/2 + 1)
+ CFF_ERROR("Buffer overflow.");
+ dest[pos/2] = 0xb0;
+ }
+ pos++;
+ } else if (e < 0) {
+ if (pos % 2) {
+ dest[pos/2] += 0x0c;
+ } else {
+ if (destlen < pos/2 + 1)
+ CFF_ERROR("Buffer overflow.");
+ dest[pos/2] = 0xc0;
+ }
+ e *= -1;
+ pos++;
+ }
+
+ if (e != 0) {
+ sprintf(work_buffer, "%ld", e);
+ for (i=0;i<CFF_REAL_MAX_LEN;i++) {
+ unsigned char ch = 0;
+ if (work_buffer[i] == '\0') {
+ break;
+ } else if (work_buffer[i] == '.') {
+ ch = 0x0a;
+ } else if (work_buffer[i] >= '0' && work_buffer[i] <= '9') {
+ ch = work_buffer[i] - '0';
+ } else {
+ CFF_ERROR("Invalid character.");
+ }
+
+ if (destlen < pos/2 + 1)
+ CFF_ERROR("Buffer overflow.");
+
+ if (pos % 2) {
+ dest[pos/2] += ch;
+ } else {
+ dest[pos/2] = (ch << 4);
+ }
+ pos++;
+ }
+ }
+
+ if (pos % 2) {
+ dest[pos/2] += 0x0f;
+ pos++;
+ } else {
+ if (destlen < pos/2 + 1)
+ CFF_ERROR("Buffer overflow.");
+ dest[pos/2] = 0xff;
+ pos += 2;
+ }
+
+ return pos/2;
+}
+
+static long cff_dict_put_number (double value,
+ card8 *dest, long destlen,
+ int type)
+{
+ long len = 0;
+ double nearint;
+
+ nearint = floor(value+0.5);
+ /* set offset to longint */
+ if (type == CFF_TYPE_OFFSET) {
+ long lvalue;
+
+ lvalue = (long) value;
+ if (destlen < 5)
+ CFF_ERROR("Buffer overflow.");
+ dest[0] = 29;
+ dest[1] = (lvalue >> 24) & 0xff;
+ dest[2] = (lvalue >> 16) & 0xff;
+ dest[3] = (lvalue >> 8) & 0xff;
+ dest[4] = lvalue & 0xff;
+ len = 5;
+ } else if (value > CFF_INT_MAX || value < CFF_INT_MIN ||
+ (fabs(value - nearint) > 1.0e-5)) { /* real */
+ len = pack_real(dest, destlen, value);
+ } else { /* integer */
+ len = pack_integer(dest, destlen, (long) nearint);
+ }
+
+ return len;
+}
+
+static long
+put_dict_entry (cff_dict_entry *de,
+ card8 *dest, long destlen)
+{
+ long len = 0;
+ int i, type, id;
+
+ if (de->count > 0) {
+ id = de->id;
+ if (dict_operator[id].argtype == CFF_TYPE_OFFSET ||
+ dict_operator[id].argtype == CFF_TYPE_SZOFF) {
+ type = CFF_TYPE_OFFSET;
+ } else {
+ type = CFF_TYPE_NUMBER;
+ }
+ for (i = 0; i < de->count; i++) {
+ len += cff_dict_put_number(de->values[i],
+ dest+len,
+ destlen-len, type);
+ }
+ if (id >= 0 && id < CFF_LAST_DICT_OP1) {
+ if (len + 1 > destlen)
+ CFF_ERROR("Buffer overflow.");
+ dest[len++] = id;
+ } else if (id >= 0 && id < CFF_LAST_DICT_OP) {
+ if (len + 2 > destlen)
+ CFF_ERROR("in cff_dict_pack(): Buffer overflow");
+ dest[len++] = 12;
+ dest[len++] = id - CFF_LAST_DICT_OP1;
+ } else {
+ CFF_ERROR("Invalid CFF DICT operator ID.");
+ }
+ }
+
+ return len;
+}
+
+long cff_dict_pack (cff_dict *dict, card8 *dest, long destlen)
+{
+ long len = 0;
+ int i;
+
+ for (i = 0; i < dict->count; i++) {
+ if (!strcmp(dict->entries[i].key, "ROS")) {
+ len += put_dict_entry(&dict->entries[i], dest, destlen);
+ break;
+ }
+ }
+ for (i = 0; i < dict->count; i++) {
+ if (strcmp(dict->entries[i].key, "ROS")) {
+ len += put_dict_entry(&dict->entries[i], dest+len, destlen-len);
+ }
+ }
+
+ return len;
+}
+
+
+void cff_dict_add (cff_dict *dict, const char *key, int count)
+{
+ int id, i;
+
+ for (id=0;id<CFF_LAST_DICT_OP;id++) {
+ if (key && dict_operator[id].opname &&
+ strcmp(dict_operator[id].opname, key) == 0)
+ break;
+ }
+
+ if (id == CFF_LAST_DICT_OP)
+ CFF_ERROR("Unknown CFF DICT operator.");
+
+ for (i=0;i<dict->count;i++) {
+ if ((dict->entries)[i].id == id) {
+ if ((dict->entries)[i].count != count)
+ CFF_ERROR("Inconsistent DICT argument number.");
+ return;
+ }
+ }
+
+ if (dict->count + 1 >= dict->max) {
+ dict->max += 8;
+ dict->entries = xrealloc(dict->entries, (dict->max)*sizeof(cff_dict_entry));
+ }
+
+ (dict->entries)[dict->count].id = id;
+ (dict->entries)[dict->count].key = (char *) dict_operator[id].opname;
+ (dict->entries)[dict->count].count = count;
+ if (count > 0) {
+ (dict->entries)[dict->count].values = xcalloc(count, sizeof(double));
+ memset((dict->entries)[dict->count].values,
+ 0, sizeof(double)*count);
+ } else {
+ (dict->entries)[dict->count].values = NULL;
+ }
+ dict->count += 1;
+
+ return;
+}
+
+
+void cff_dict_remove (cff_dict *dict, const char *key)
+{
+ int i;
+ for (i = 0; i < dict->count; i++) {
+ if (key && strcmp(key, (dict->entries)[i].key) == 0) {
+ (dict->entries)[i].count = 0;
+ if ((dict->entries)[i].values)
+ xfree((dict->entries)[i].values);
+ (dict->entries)[i].values = NULL;
+ }
+ }
+}
+
+void cff_dict_set (cff_dict *dict, const char *key, int idx, double value)
+{
+ int i;
+
+ assert(dict && key);
+
+ for (i = 0 ; i < dict->count; i++) {
+ if (strcmp(key, (dict->entries)[i].key) == 0) {
+ if ((dict->entries)[i].count > idx)
+ (dict->entries)[i].values[idx] = value;
+ else
+ CFF_ERROR("Invalid index number.");
+ break;
+ }
+ }
+
+ if (i == dict->count)
+ pdftex_fail("DICT entry \"%s\" not found.", key);
+}
+
+
+/* Strings */
+char *cff_get_string (cff_font *cff, s_SID id)
+{
+ char *result = NULL;
+ long len;
+
+ if (id < CFF_STDSTR_MAX) {
+ len = strlen(cff_stdstr[id]);
+ result = xcalloc(len+1, sizeof(char));
+ memcpy(result, cff_stdstr[id], len);
+ result[len] = '\0';
+ } else if (cff && cff->string) {
+ cff_index *strings = cff->string;
+ id -= CFF_STDSTR_MAX;
+ if (id < strings->count) {
+ len = (strings->offset)[id+1] - (strings->offset)[id];
+ result = xcalloc(len + 1, sizeof(char));
+ memmove(result, strings->data + (strings->offset)[id] - 1, len);
+ result[len] = '\0';
+ }
+ }
+
+ return result;
+}
+
+long cff_get_sid (cff_font *cff, char *str)
+{
+ card16 i;
+
+ if (!cff || !str)
+ return -1;
+
+ /* I search String INDEX first. */
+ if (cff && cff->string) {
+ cff_index *idx = cff->string;
+ for (i = 0; i < idx->count; i++) {
+ if (strlen(str) == (idx->offset)[i+1] - (idx->offset)[i] &&
+ !memcmp(str, (idx->data)+(idx->offset)[i]-1, strlen(str)))
+ return (i + CFF_STDSTR_MAX);
+ }
+ }
+
+ for (i = 0; i < CFF_STDSTR_MAX; i++) {
+ if (!strcmp(str, cff_stdstr[i]))
+ return i;
+ }
+
+ return -1;
+}
+
+
+void cff_update_string (cff_font *cff)
+{
+ if (cff == NULL)
+ CFF_ERROR("CFF font not opened.");
+
+ if (cff->string)
+ cff_release_index(cff->string);
+ cff->string = cff->_string;
+ cff->_string = NULL;
+}
+
+
+s_SID cff_add_string (cff_font *cff, char *str)
+{
+ card16 idx;
+ cff_index *strings;
+ l_offset offset, size;
+
+ if (cff == NULL)
+ CFF_ERROR("CFF font not opened.");
+
+ if (cff->_string == NULL)
+ cff->_string = cff_new_index(0);
+ strings = cff->_string;
+
+ for (idx = 0; idx < strings->count; idx++) {
+ size = strings->offset[idx+1] - strings->offset[idx];
+ offset = strings->offset[idx];
+ if (size == strlen(str) &&
+ !memcmp(strings->data+offset-1, str, strlen(str)))
+ return (idx + CFF_STDSTR_MAX);
+ }
+
+ for (idx = 0; idx < CFF_STDSTR_MAX; idx++) {
+ if (cff_stdstr[idx] &&
+ !strcmp(cff_stdstr[idx], str))
+ return idx;
+ }
+ offset = (strings->count > 0) ? strings->offset[strings->count] : 1;
+ strings->offset = xrealloc(strings->offset, (strings->count+2)*sizeof(l_offset));
+ if (strings->count == 0)
+ strings->offset[0] = 1;
+ idx = strings->count;
+ strings->count += 1;
+ strings->offset[strings->count] = offset + strlen(str);
+ strings->data = xrealloc(strings->data, (offset+strlen(str)-1)*sizeof(card8));
+ memcpy(strings->data+offset-1, str, strlen(str));
+
+ return (idx + CFF_STDSTR_MAX);
+}
+
+
+void cff_dict_update (cff_dict *dict, cff_font *cff)
+{
+ int i;
+
+ for (i = 0;i < dict->count; i++) {
+ if ((dict->entries)[i].count > 0) {
+ char *str;
+ int id;
+
+ id = (dict->entries)[i].id;
+
+ if (dict_operator[id].argtype == CFF_TYPE_SID) {
+ str = cff_get_string(cff, (dict->entries)[i].values[0]);
+ (dict->entries)[i].values[0] = cff_add_string(cff, str);
+ xfree(str);
+ } else if (dict_operator[id].argtype == CFF_TYPE_ROS) {
+ str = cff_get_string(cff, (dict->entries)[i].values[0]);
+ (dict->entries)[i].values[0] = cff_add_string(cff, str);
+ xfree(str);
+ str = cff_get_string(cff, (dict->entries)[i].values[1]);
+ (dict->entries)[i].values[1] = cff_add_string(cff, str);
+ xfree(str);
+ }
+
+ }
+ }
+}
+
+/* charsets */
+
+long cff_read_charsets (cff_font *cff)
+{
+ cff_charsets *charset;
+ long offset, length;
+ card16 count, i;
+
+ if (cff->topdict == NULL)
+ CFF_ERROR("Top DICT not available");
+
+ if (!cff_dict_known(cff->topdict, "charset")) {
+ cff->flag |= CHARSETS_ISOADOBE;
+ cff->charsets = NULL;
+ return 0;
+ }
+
+ offset = (long) cff_dict_get(cff->topdict, "charset", 0);
+
+ if (offset == 0) { /* predefined */
+ cff->flag |= CHARSETS_ISOADOBE;
+ cff->charsets = NULL;
+ return 0;
+ } else if (offset == 1) {
+ cff->flag |= CHARSETS_EXPERT;
+ cff->charsets = NULL;
+ return 0;
+ } else if (offset == 2) {
+ cff->flag |= CHARSETS_EXPSUB;
+ cff->charsets = NULL;
+ return 0;
+ }
+
+ cff->offset = offset;
+ cff->charsets = charset = xcalloc(1, sizeof(cff_charsets));
+ charset->format = get_card8(cff);
+ charset->num_entries = 0;
+
+ count = cff->num_glyphs - 1;
+ length = 1;
+
+ /* Not sure. Not well documented. */
+ switch (charset->format) {
+ case 0:
+ charset->num_entries = cff->num_glyphs - 1; /* no .notdef */
+ charset->data.glyphs = xcalloc(charset->num_entries, sizeof(s_SID));
+ length += (charset->num_entries) * 2;
+ for (i=0;i<(charset->num_entries);i++) {
+ charset->data.glyphs[i] = get_card16(cff);
+ }
+ count = 0;
+ break;
+ case 1:
+ {
+ cff_range1 *ranges = NULL;
+ while (count > 0 && charset->num_entries < cff->num_glyphs) {
+ ranges = xrealloc(ranges, (charset->num_entries + 1)*sizeof(cff_range1));
+ ranges[charset->num_entries].first = get_card16(cff);
+ ranges[charset->num_entries].n_left = get_card8(cff);
+ count -= ranges[charset->num_entries].n_left + 1; /* no-overrap */
+ charset->num_entries += 1;
+ charset->data.range1 = ranges;
+ }
+ length += (charset->num_entries) * 3;
+ }
+ break;
+ case 2:
+ {
+ cff_range2 *ranges = NULL;
+ while (count > 0 && charset->num_entries < cff->num_glyphs) {
+ ranges = xrealloc(ranges, (charset->num_entries + 1)*sizeof(cff_range2));
+ ranges[charset->num_entries].first = get_card16(cff);
+ ranges[charset->num_entries].n_left = get_card16(cff);
+ count -= ranges[charset->num_entries].n_left + 1; /* non-overrapping */
+ charset->num_entries += 1;
+ }
+ charset->data.range2 = ranges;
+ length += (charset->num_entries) * 4;
+ }
+ break;
+ default:
+ xfree(charset);
+ CFF_ERROR("Unknown Charset format");
+ break;
+ }
+
+ if (count > 0)
+ CFF_ERROR("Charset data possibly broken");
+
+ return length;
+}
+
+long cff_pack_charsets (cff_font *cff, card8 *dest, long destlen)
+{
+ long len = 0;
+ card16 i;
+ cff_charsets *charset;
+
+ if (cff->flag & HAVE_STANDARD_CHARSETS || cff->charsets == NULL)
+ return 0;
+
+ if (destlen < 1)
+ CFF_ERROR("in cff_pack_charsets(): Buffer overflow");
+
+ charset = cff->charsets;
+
+ dest[len++] = charset->format;
+ switch (charset->format) {
+ case 0:
+ if (destlen < len + (charset->num_entries)*2)
+ CFF_ERROR("in cff_pack_charsets(): Buffer overflow");
+ for (i=0;i<(charset->num_entries);i++) {
+ s_SID sid = (charset->data).glyphs[i]; /* or CID */
+ dest[len++] = (sid >> 8) & 0xff;
+ dest[len++] = sid & 0xff;
+ }
+ break;
+ case 1:
+ {
+ if (destlen < len + (charset->num_entries)*3)
+ CFF_ERROR("in cff_pack_charsets(): Buffer overflow");
+ for (i=0;i<(charset->num_entries);i++) {
+ dest[len++] = ((charset->data).range1[i].first >> 8) & 0xff;
+ dest[len++] = (charset->data).range1[i].first & 0xff;
+ dest[len++] = (charset->data).range1[i].n_left;
+ }
+ }
+ break;
+ case 2:
+ {
+ if (destlen < len + (charset->num_entries)*4)
+ CFF_ERROR("in cff_pack_charsets(): Buffer overflow");
+ for (i=0;i<(charset->num_entries);i++) {
+ dest[len++] = ((charset->data).range2[i].first >> 8) & 0xff;
+ dest[len++] = (charset->data).range2[i].first & 0xff;
+ dest[len++] = ((charset->data).range2[i].n_left >> 8) & 0xff;
+ dest[len++] = (charset->data).range2[i].n_left & 0xff;
+ }
+ }
+ break;
+ default:
+ CFF_ERROR("Unknown Charset format");
+ break;
+ }
+
+ return len;
+}
+
+
+
+/*
+ * Type 2 Charstring support:
+ * Decode and encode Type 2 charstring
+ *
+ * All local/global subroutine calls in a given charstring is replace by the
+ * content of subroutine charstrings. We do this because some PostScript RIP
+ * may have problems with sparse subroutine array. Workaround for this is to
+ * re-order subroutine array so that no gap appears in the subroutine array,
+ * or put dummy charstrings that contains only `return' in the gap. However,
+ * re-ordering of subroutine is rather difficult for Type 2 charstrings due
+ * to the bias which depends on the total number of subroutines. Replacing
+ * callgsubr/callsubr calls with the content of the corresponding subroutine
+ * charstring may be more efficient than putting dummy subroutines in the
+ * case of subsetted font. Adobe distiller seems doing same thing.
+ *
+ * And also note that subroutine numbers within subroutines can depend on the
+ * content of operand stack as follows:
+ *
+ * ... l m callsubr << subr #(m+bias): n add callsubr >> ...
+ *
+ * I've not implemented the `random' operator which generates a pseudo-random
+ * number in the range (0, 1] and push them into argument stack.
+ * How pseudo-random sequences are generated is not documented in the Type 2
+ * charstring spec..
+ */
+
+
+#define CS_TYPE2_DEBUG_STR "Type2 Charstring Parser"
+#define CS_TYPE2_DEBUG 5
+
+/* decoder/encoder status codes */
+#define CS_BUFFER_CFF_ERROR -3
+#define CS_STACK_CFF_ERROR -2
+#define CS_PARSE_CFF_ERROR -1
+#define CS_PARSE_OK 0
+#define CS_PARSE_END 1
+#define CS_SUBR_RETURN 2
+#define CS_CHAR_END 3
+
+static int status = CS_PARSE_CFF_ERROR;
+
+#define DST_NEED(a,b) {if ((a) < (b)) { status = CS_BUFFER_CFF_ERROR ; return ; }}
+#define SRC_NEED(a,b) {if ((a) < (b)) { status = CS_PARSE_CFF_ERROR ; return ; }}
+#define NEED(a,b) {if ((a) < (b)) { status = CS_STACK_CFF_ERROR ; return ; }}
+
+/* hintmask and cntrmask need number of stem zones */
+static int num_stems = 0;
+static int phase = 0;
+
+/* subroutine nesting */
+static int cs2_nest = 0;
+
+/* advance width */
+static int have_width = 0;
+static double width = 0.0;
+
+/*
+ * Standard Encoding Accented Characters:
+ * Optional four arguments for endchar. See, CFF spec., p.35.
+ * This is obsolete feature and is no longer supported.
+ */
+#if 0
+/* adx ady bchar achar endchar */
+static double seac[4] = {0.0, 0.0, 0.0, 0.0};
+#endif
+
+/* Operand stack and Transient array */
+static int cs2_stack_top = 0;
+static double cs2_arg_stack[CS_ARG_STACK_MAX];
+static double trn_array[CS_TRANS_ARRAY_MAX];
+
+/*
+ * Type 2 CharString encoding
+ */
+
+/*
+ * 1-byte CharString operaotrs:
+ * cs_escape is first byte of two-byte operator
+ */
+
+/* RESERVED 0 */
+#define cs_hstem 1
+/* RESERVED 2 */
+#define cs_vstem 3
+#define cs_vmoveto 4
+#define cs_rlineto 5
+#define cs_hlineto 6
+#define cs_vlineto 7
+#define cs_rrcurveto 8
+/* cs_closepath 9 : TYPE1 */
+#define cs_callsubr 10
+#define cs_return 11
+#define cs_escape 12
+/* cs_hsbw 13 : TYPE1 */
+#define cs_endchar 14
+/* RESERVED 15 */
+/* RESERVED 16 */
+/* RESERVED 17 */
+#define cs_hstemhm 18
+#define cs_hintmask 19
+#define cs_cntrmask 20
+#define cs_rmoveto 21
+#define cs_hmoveto 22
+#define cs_vstemhm 23
+#define cs_rcurveline 24
+#define cs_rlinecurve 25
+#define cs_vvcurveto 26
+#define cs_hhcurveto 27
+/* SHORTINT 28 : first byte of shortint*/
+#define cs_callgsubr 29
+#define cs_vhcurveto 30
+#define cs_hvcurveto 31
+
+/*
+ * 2-byte CharString operaotrs:
+ * "dotsection" is obsoleted in Type 2 charstring.
+ */
+
+#define cs_dotsection 0
+/* cs_vstem3 1 : TYPE1 */
+/* cs_hstem3 2 : TYPE1 */
+#define cs_and 3
+#define cs_or 4
+#define cs_not 5
+/* cs_seac 6 : TYPE1 */
+/* cs_sbw 7 : TYPE1 */
+/* RESERVED 8 */
+#define cs_abs 9
+#define cs_add 10
+#define cs_sub 11
+#define cs_div 12
+/* RESERVED 13 */
+#define cs_neg 14
+#define cs_eq 15
+/* cs_callothersubr 16 : TYPE1 */
+/* cs_pop 17 : TYPE1 */
+#define cs_drop 18
+/* RESERVED 19 */
+#define cs_put 20
+#define cs_get 21
+#define cs_ifelse 22
+#define cs_random 23
+#define cs_mul 24
+/* RESERVED 25 */
+#define cs_sqrt 26
+#define cs_dup 27
+#define cs_exch 28
+#define cs_index 29
+#define cs_roll 30
+/* cs_setcurrentpoint 31 : TYPE1 */
+/* RESERVED 32 */
+/* RESERVED 33 */
+#define cs_hflex 34
+#define cs_flex 35
+#define cs_hflex1 36
+#define cs_flex1 37
+
+/*
+ * clear_stack() put all operands sotred in operand stack to dest.
+ */
+static void
+clear_stack (card8 **dest, card8 *limit)
+{
+ int i;
+
+ for (i = 0; i < cs2_stack_top; i++) {
+ double value;
+ long ivalue;
+ value = cs2_arg_stack[i];
+ /* Nearest integer value */
+ ivalue = (long) floor(value+0.5);
+ if (value >= 0x8000L || value <= (-0x8000L - 1)) {
+ /*
+ * This number cannot be represented as a single operand.
+ * We must use `a b mul ...' or `a c div' to represent large values.
+ */
+ CFF_ERROR("Argument value too large. (This is bug)");
+ } else if (fabs(value - ivalue) > 3.0e-5) {
+ /* 16.16-bit signed fixed value */
+ DST_NEED(limit, *dest + 5);
+ *(*dest)++ = 255;
+ ivalue = (long) floor(value); /* mantissa */
+ *(*dest)++ = (ivalue >> 8) & 0xff;
+ *(*dest)++ = ivalue & 0xff;
+ ivalue = (long)((value - ivalue) * 0x10000l); /* fraction */
+ *(*dest)++ = (ivalue >> 8) & 0xff;
+ *(*dest)++ = ivalue & 0xff;
+ /* Everything else are integers. */
+ } else if (ivalue >= -107 && ivalue <= 107) {
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = ivalue + 139;
+ } else if (ivalue >= 108 && ivalue <= 1131) {
+ DST_NEED(limit, *dest + 2);
+ ivalue = 0xf700u + ivalue - 108;
+ *(*dest)++ = (ivalue >> 8) & 0xff;
+ *(*dest)++ = ivalue & 0xff;
+ } else if (ivalue >= -1131 && ivalue <= -108) {
+ DST_NEED(limit, *dest + 2);
+ ivalue = 0xfb00u - ivalue - 108;
+ *(*dest)++ = (ivalue >> 8) & 0xff;
+ *(*dest)++ = ivalue & 0xff;
+ } else if (ivalue >= -32768 && ivalue <= 32767) { /* shortint */
+ DST_NEED(limit, *dest + 3);
+ *(*dest)++ = 28;
+ *(*dest)++ = (ivalue >> 8) & 0xff;
+ *(*dest)++ = (ivalue) & 0xff;
+ } else { /* Shouldn't come here */
+ CFF_ERROR("Unexpected error.");
+ }
+ }
+
+ cs2_stack_top = 0; /* clear stack */
+
+ return;
+}
+
+/*
+ * Single byte operators:
+ * Path construction, Operator for finishing a path, Hint operators.
+ *
+ * phase:
+ * 0: inital state
+ * 1: hint declaration, first stack-clearing operator appeared
+ * 2: in path construction
+ */
+
+static void
+do_operator1 (card8 **dest, card8 *limit, card8 **data, card8 *endptr)
+{
+ card8 op = **data;
+
+ *data += 1;
+
+ switch (op) {
+ case cs_hstemhm:
+ case cs_vstemhm:
+ /* charstring may have hintmask if above operator have seen */
+ case cs_hstem:
+ case cs_vstem:
+ if (phase == 0 && (cs2_stack_top % 2)) {
+ have_width = 1;
+ width = cs2_arg_stack[0];
+ }
+ num_stems += cs2_stack_top/2;
+ clear_stack(dest, limit);
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = op;
+ phase = 1;
+ break;
+ case cs_hintmask:
+ case cs_cntrmask:
+ if (phase < 2) {
+ if (phase == 0 && (cs2_stack_top % 2)) {
+ have_width = 1;
+ width = cs2_arg_stack[0];
+ }
+ num_stems += cs2_stack_top/2;
+ }
+ clear_stack(dest, limit);
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = op;
+ if (num_stems > 0) {
+ int masklen = (num_stems + 7) / 8;
+ DST_NEED(limit, *dest + masklen);
+ SRC_NEED(endptr, *data + masklen);
+ memmove(*dest, *data, masklen);
+ *data += masklen;
+ *dest += masklen;
+ }
+ phase = 2;
+ break;
+ case cs_rmoveto:
+ if (phase == 0 && (cs2_stack_top % 2)) {
+ have_width = 1;
+ width = cs2_arg_stack[0];
+ }
+ clear_stack(dest, limit);
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = op;
+ phase = 2;
+ break;
+ case cs_hmoveto:
+ case cs_vmoveto:
+ if (phase == 0 && (cs2_stack_top % 2) == 0) {
+ have_width = 1;
+ width = cs2_arg_stack[0];
+ }
+ clear_stack(dest, limit);
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = op;
+ phase = 2;
+ break;
+ case cs_endchar:
+ if (cs2_stack_top == 1) {
+ have_width = 1;
+ width = cs2_arg_stack[0];
+ clear_stack(dest, limit);
+ } else if (cs2_stack_top == 4 || cs2_stack_top == 5) {
+ WARN("\"seac\" character deprecated in Type 2 charstring.");
+ status = CS_PARSE_CFF_ERROR;
+ return;
+ } else if (cs2_stack_top > 0) {
+ WARN("Operand stack not empty.");
+ }
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = op;
+ status = CS_CHAR_END;
+ break;
+ /* above oprators are candidate for first stack-clearing operator */
+ case cs_rlineto:
+ case cs_hlineto:
+ case cs_vlineto:
+ case cs_rrcurveto:
+ case cs_rcurveline:
+ case cs_rlinecurve:
+ case cs_vvcurveto:
+ case cs_hhcurveto:
+ case cs_vhcurveto:
+ case cs_hvcurveto:
+ if (phase < 2) {
+ WARN("Broken Type 2 charstring.");
+ status = CS_PARSE_CFF_ERROR;
+ return;
+ }
+ clear_stack(dest, limit);
+ DST_NEED(limit, *dest + 1);
+ *(*dest)++ = op;
+ break;
+ /* all operotors above are stack-clearing operator */
+ /* no output */
+ case cs_return:
+ case cs_callgsubr:
+ case cs_callsubr:
+ CFF_ERROR("Unexpected call(g)subr/return");
+ break;
+ default:
+ /* no-op ? */
+ WARN("%s: Unknown charstring operator: 0x%02x", CS_TYPE2_DEBUG_STR, op);
+ status = CS_PARSE_CFF_ERROR;
+ break;
+ }
+
+ return;
+}
+
+/*
+ * Double byte operators:
+ * Flex, arithmetic, conditional, and storage operators.
+ *
+ * Following operators are not supported:
+ * random: How random ?
+ */
+static void
+do_operator2 (card8 **dest, card8 *limit, card8 **data, card8 *endptr)
+{
+ card8 op;
+
+ *data += 1;
+
+ SRC_NEED(endptr, *data + 1);
+
+ op = **data;
+ *data += 1;
+
+ switch(op) {
+ case cs_dotsection: /* deprecated */
+ WARN("Operator \"dotsection\" deprecated in Type 2 charstring.");
+ status = CS_PARSE_CFF_ERROR;
+ return;
+ break;
+ case cs_hflex:
+ case cs_flex:
+ case cs_hflex1:
+ case cs_flex1:
+ if (phase < 2) {
+ WARN("%s: Broken Type 2 charstring.", CS_TYPE2_DEBUG_STR);
+ status = CS_PARSE_CFF_ERROR;
+ return;
+ }
+ clear_stack(dest, limit);
+ DST_NEED(limit, *dest + 2);
+ *(*dest)++ = cs_escape;
+ *(*dest)++ = op;
+ break;
+ /* all operator above are stack-clearing */
+ /* no output */
+ case cs_and:
+ NEED(cs2_stack_top, 2);
+ cs2_stack_top--;
+ if (cs2_arg_stack[cs2_stack_top] && cs2_arg_stack[cs2_stack_top-1]) {
+ cs2_arg_stack[cs2_stack_top-1] = 1.0;
+ } else {
+ cs2_arg_stack[cs2_stack_top-1] = 0.0;
+ }
+ break;
+ case cs_or:
+ NEED(cs2_stack_top, 2);
+ cs2_stack_top--;
+ if (cs2_arg_stack[cs2_stack_top] || cs2_arg_stack[cs2_stack_top-1]) {
+ cs2_arg_stack[cs2_stack_top-1] = 1.0;
+ } else {
+ cs2_arg_stack[cs2_stack_top-1] = 0.0;
+ }
+ break;
+ case cs_not:
+ NEED(cs2_stack_top, 1);
+ if (cs2_arg_stack[cs2_stack_top-1]) {
+ cs2_arg_stack[cs2_stack_top-1] = 0.0;
+ } else {
+ cs2_arg_stack[cs2_stack_top-1] = 1.0;
+ }
+ break;
+ case cs_abs:
+ NEED(cs2_stack_top, 1);
+ cs2_arg_stack[cs2_stack_top-1] = fabs(cs2_arg_stack[cs2_stack_top-1]);
+ break;
+ case cs_add:
+ NEED(cs2_stack_top, 2);
+ cs2_arg_stack[cs2_stack_top-2] += cs2_arg_stack[cs2_stack_top-1];
+ cs2_stack_top--;
+ break;
+ case cs_sub:
+ NEED(cs2_stack_top, 2);
+ cs2_arg_stack[cs2_stack_top-2] -= cs2_arg_stack[cs2_stack_top-1];
+ cs2_stack_top--;
+ break;
+ case cs_div: /* doesn't check overflow */
+ NEED(cs2_stack_top, 2);
+ cs2_arg_stack[cs2_stack_top-2] /= cs2_arg_stack[cs2_stack_top-1];
+ cs2_stack_top--;
+ break;
+ case cs_neg:
+ NEED(cs2_stack_top, 1);
+ cs2_arg_stack[cs2_stack_top-1] *= -1.0;
+ break;
+ case cs_eq:
+ NEED(cs2_stack_top, 2);
+ cs2_stack_top--;
+ if (cs2_arg_stack[cs2_stack_top] == cs2_arg_stack[cs2_stack_top-1]) {
+ cs2_arg_stack[cs2_stack_top-1] = 1.0;
+ } else {
+ cs2_arg_stack[cs2_stack_top-1] = 0.0;
+ }
+ break;
+ case cs_drop:
+ NEED(cs2_stack_top, 1);
+ cs2_stack_top--;
+ break;
+ case cs_put:
+ NEED(cs2_stack_top, 2);
+ {
+ int idx = (int)cs2_arg_stack[--cs2_stack_top];
+ NEED(CS_TRANS_ARRAY_MAX, idx);
+ trn_array[idx] = cs2_arg_stack[--cs2_stack_top];
+ }
+ break;
+ case cs_get:
+ NEED(cs2_stack_top, 1);
+ {
+ int idx = (int)cs2_arg_stack[cs2_stack_top-1];
+ NEED(CS_TRANS_ARRAY_MAX, idx);
+ cs2_arg_stack[cs2_stack_top-1] = trn_array[idx];
+ }
+ break;
+ case cs_ifelse:
+ NEED(cs2_stack_top, 4);
+ cs2_stack_top -= 3;
+ if (cs2_arg_stack[cs2_stack_top+1] > cs2_arg_stack[cs2_stack_top+2]) {
+ cs2_arg_stack[cs2_stack_top-1] = cs2_arg_stack[cs2_stack_top];
+ }
+ break;
+ case cs_mul:
+ NEED(cs2_stack_top, 2);
+ cs2_arg_stack[cs2_stack_top-2] = cs2_arg_stack[cs2_stack_top-2] * cs2_arg_stack[cs2_stack_top-1];
+ cs2_stack_top--;
+ break;
+ case cs_sqrt:
+ NEED(cs2_stack_top, 1);
+ cs2_arg_stack[cs2_stack_top-1] = sqrt(cs2_arg_stack[cs2_stack_top-1]);
+ break;
+ case cs_dup:
+ NEED(cs2_stack_top, 1);
+ NEED(CS_ARG_STACK_MAX, cs2_stack_top+1);
+ cs2_arg_stack[cs2_stack_top] = cs2_arg_stack[cs2_stack_top-1];
+ cs2_stack_top++;
+ break;
+ case cs_exch:
+ NEED(cs2_stack_top, 2);
+ {
+ double save = cs2_arg_stack[cs2_stack_top-2];
+ cs2_arg_stack[cs2_stack_top-2] = cs2_arg_stack[cs2_stack_top-1];
+ cs2_arg_stack[cs2_stack_top-1] = save;
+ }
+ break;
+ case cs_index:
+ NEED(cs2_stack_top, 2); /* need two arguments at least */
+ {
+ int idx = (int)cs2_arg_stack[cs2_stack_top-1];
+ if (idx < 0) {
+ cs2_arg_stack[cs2_stack_top-1] = cs2_arg_stack[cs2_stack_top-2];
+ } else {
+ NEED(cs2_stack_top, idx+2);
+ cs2_arg_stack[cs2_stack_top-1] = cs2_arg_stack[cs2_stack_top-idx-2];
+ }
+ }
+ break;
+ case cs_roll:
+ NEED(cs2_stack_top, 2);
+ {
+ int N, J;
+ J = (int)cs2_arg_stack[--cs2_stack_top];
+ N = (int)cs2_arg_stack[--cs2_stack_top];
+ NEED(cs2_stack_top, N);
+ if (J > 0) {
+ J = J % N;
+ while (J-- > 0) {
+ double save = cs2_arg_stack[cs2_stack_top-1];
+ int i = cs2_stack_top - 1;
+ while (i > cs2_stack_top-N) {
+ cs2_arg_stack[i] = cs2_arg_stack[i-1];
+ i--;
+ }
+ cs2_arg_stack[i] = save;
+ }
+ } else {
+ J = (-J) % N;
+ while (J-- > 0) {
+ double save = cs2_arg_stack[cs2_stack_top-N];
+ int i = cs2_stack_top - N;
+ while (i < cs2_stack_top-1) {
+ cs2_arg_stack[i] = cs2_arg_stack[i+1];
+ i++;
+ }
+ cs2_arg_stack[i] = save;
+ }
+ }
+ }
+ break;
+ case cs_random:
+ WARN("%s: Charstring operator \"random\" found.", CS_TYPE2_DEBUG_STR);
+ NEED(CS_ARG_STACK_MAX, cs2_stack_top+1);
+ cs2_arg_stack[cs2_stack_top++] = 1.0;
+ break;
+ default:
+ /* no-op ? */
+ WARN("%s: Unknown charstring operator: 0x0c%02x", CS_TYPE2_DEBUG_STR, op);
+ status = CS_PARSE_CFF_ERROR;
+ break;
+ }
+
+ return;
+}
+
+/*
+ * integer:
+ * exactly the same as the DICT encoding (except 29)
+ */
+static void
+cs2_get_integer (card8 **data, card8 *endptr)
+{
+ long result = 0;
+ card8 b0 = **data, b1, b2;
+
+ *data += 1;
+
+ if (b0 == 28) { /* shortint */
+ SRC_NEED(endptr, *data + 2);
+ b1 = **data;
+ b2 = *(*data+1);
+ result = b1*256+b2;
+ if (result > 0x7fff)
+ result -= 0x10000L;
+ *data += 2;
+ } else if (b0 >= 32 && b0 <= 246) { /* int (1) */
+ result = b0 - 139;
+ } else if (b0 >= 247 && b0 <= 250) { /* int (2) */
+ SRC_NEED(endptr, *data + 1);
+ b1 = **data;
+ result = (b0-247)*256+b1+108;
+ *data += 1;
+ } else if (b0 >= 251 && b0 <= 254) {
+ SRC_NEED(endptr, *data + 1);
+ b1 = **data;
+ result = -(b0-251)*256-b1-108;
+ *data += 1;
+ } else {
+ status = CS_PARSE_CFF_ERROR;
+ return;
+ }
+
+ NEED(CS_ARG_STACK_MAX, cs2_stack_top+1);
+ cs2_arg_stack[cs2_stack_top++] = (double) result;
+
+ return;
+}
+
+/*
+ * Signed 16.16-bits fixed number for Type 2 charstring encoding
+ */
+static void
+get_fixed (card8 **data, card8 *endptr)
+{
+ long ivalue;
+ double rvalue;
+
+ *data += 1;
+
+ SRC_NEED(endptr, *data + 4);
+
+ ivalue = *(*data) * 0x100 + *(*data+1);
+ rvalue = (ivalue > 0x7fffL) ? (ivalue - 0x10000L) : ivalue;
+ ivalue = *(*data+2) * 0x100 + *(*data+3);
+ rvalue += ((double) ivalue) / 0x10000L;
+
+ NEED(CS_ARG_STACK_MAX, cs2_stack_top+1);
+ cs2_arg_stack[cs2_stack_top++] = rvalue;
+ *data += 4;
+
+ return;
+}
+
+/*
+ * Subroutines:
+ * The bias for subroutine number is introduced in type 2 charstrings.
+ *
+ * subr: set to a pointer to the subroutine charstring.
+ * len: set to the length of subroutine charstring.
+ * subr_idx: CFF INDEX data that contains subroutines.
+ * id: biased subroutine number.
+ */
+static void
+get_subr (card8 **subr, long *len, cff_index *subr_idx, long id)
+{
+ card16 count;
+
+ if (subr_idx == NULL)
+ CFF_ERROR("%s: Subroutine called but no subroutine found.", CS_TYPE2_DEBUG_STR);
+
+ count = subr_idx->count;
+
+ /* Adding bias number */
+ if (count < 1240) {
+ id += 107;
+ } else if (count < 33900) {
+ id += 1131;
+ } else {
+ id += 32768;
+ }
+
+ if (id > count)
+ CFF_ERROR("%s: Invalid Subr index: %ld (max=%u)", CS_TYPE2_DEBUG_STR, id, count);
+
+ *len = (subr_idx->offset)[id + 1] - (subr_idx->offset)[id];
+ *subr = subr_idx->data + (subr_idx->offset)[id] - 1;
+
+ return;
+}
+
+/*
+ * NOTE:
+ * The Type 2 interpretation of a number encoded in five-bytes (those with
+ * an initial byte value of 255) differs from how it is interpreted in the
+ * Type 1 format.
+ */
+
+static void
+do_charstring (card8 **dest, card8 *limit,
+ card8 **data, card8 *endptr,
+ cff_index *gsubr_idx, cff_index *subr_idx)
+{
+ card8 b0 = 0, *subr;
+ long len;
+
+ if (cs2_nest > CS_SUBR_NEST_MAX)
+ CFF_ERROR("%s: Subroutine nested too deeply.", CS_TYPE2_DEBUG_STR);
+
+ cs2_nest++;
+
+ while (*data < endptr && status == CS_PARSE_OK) {
+ b0 = **data;
+ if (b0 == 255) { /* 16-bit.16-bit fixed signed number */
+ get_fixed(data, endptr);
+ } else if (b0 == cs_return) {
+ status = CS_SUBR_RETURN;
+ } else if (b0 == cs_callgsubr) {
+ if (cs2_stack_top < 1) {
+ status = CS_STACK_CFF_ERROR;
+ } else {
+ cs2_stack_top--;
+ get_subr(&subr, &len, gsubr_idx, (long) cs2_arg_stack[cs2_stack_top]);
+ if (*dest + len > limit)
+ CFF_ERROR("%s: Possible buffer overflow.", CS_TYPE2_DEBUG_STR);
+ do_charstring(dest, limit, &subr, subr + len,
+ gsubr_idx, subr_idx);
+ *data += 1;
+ }
+ } else if (b0 == cs_callsubr) {
+ if (cs2_stack_top < 1) {
+ status = CS_STACK_CFF_ERROR;
+ } else {
+ cs2_stack_top--;
+ get_subr(&subr, &len, subr_idx, (long) cs2_arg_stack[cs2_stack_top]);
+ if (limit < *dest + len)
+ CFF_ERROR("%s: Possible buffer overflow.", CS_TYPE2_DEBUG_STR);
+ do_charstring(dest, limit, &subr, subr + len,
+ gsubr_idx, subr_idx);
+ *data += 1;
+ }
+ } else if (b0 == cs_escape) {
+ do_operator2(dest, limit, data, endptr);
+ } else if (b0 < 32 && b0 != 28) { /* 19, 20 need mask */
+ do_operator1(dest, limit, data, endptr);
+ } else if ((b0 <= 22 && b0 >= 27) || b0 == 31) { /* reserved */
+ status = CS_PARSE_CFF_ERROR; /* not an error ? */
+ } else { /* integer */
+ cs2_get_integer(data, endptr);
+ }
+ }
+
+ if (status == CS_SUBR_RETURN) {
+ status = CS_PARSE_OK;
+ } else if (status == CS_CHAR_END && *data < endptr) {
+ WARN("%s: Garbage after endchar.", CS_TYPE2_DEBUG_STR);
+ } else if (status < CS_PARSE_OK) { /* error */
+ CFF_ERROR("%s: Parsing charstring failed: (status=%d, stack=%d)",
+ CS_TYPE2_DEBUG_STR, status, cs2_stack_top);
+ }
+
+ cs2_nest--;
+
+ return;
+}
+
+static void
+cs_parse_init (void)
+{
+ status = CS_PARSE_OK;
+ cs2_nest = 0;
+ phase = 0;
+ num_stems = 0;
+ cs2_stack_top = 0;
+}
+
+/*
+ * Not just copying...
+ */
+long
+cs_copy_charstring (card8 *dst, long dstlen,
+ card8 *src, long srclen,
+ cff_index *gsubr, cff_index *subr,
+ double default_width, double nominal_width, cs_ginfo *ginfo)
+{
+ card8 *save = dst;
+
+ cs_parse_init();
+
+ width = 0.0;
+ have_width = 0;
+
+ /* expand call(g)subrs */
+ do_charstring(&dst, dst + dstlen, &src, src + srclen, gsubr, subr);
+
+ if (ginfo) {
+ ginfo->flags = 0; /* not used */
+ if (have_width) {
+ ginfo->wx = nominal_width + width;
+ } else {
+ ginfo->wx = default_width;
+ }
+ }
+
+ return (long)(dst - save);
+}
+
+/* encodings */
+
+/*
+ * Encoding and Charset
+ *
+ * Encoding and Charset arrays always begin with GID = 1.
+ */
+long cff_read_encoding (cff_font *cff)
+{
+ cff_encoding *encoding;
+ long offset, length;
+ card8 i;
+
+ if (cff->topdict == NULL) {
+ CFF_ERROR("Top DICT data not found");
+ }
+
+ if (!cff_dict_known(cff->topdict, "Encoding")) {
+ cff->flag |= ENCODING_STANDARD;
+ cff->encoding = NULL;
+ return 0;
+ }
+
+ offset = (long) cff_dict_get(cff->topdict, "Encoding", 0);
+ if (offset == 0) { /* predefined */
+ cff->flag |= ENCODING_STANDARD;
+ cff->encoding = NULL;
+ return 0;
+ } else if (offset == 1) {
+ cff->flag |= ENCODING_EXPERT;
+ cff->encoding = NULL;
+ return 0;
+ }
+
+ cff->offset= offset;
+ cff->encoding = encoding = xcalloc(1, sizeof(cff_encoding));
+ encoding->format = get_card8(cff);
+ length = 1;
+
+ switch (encoding->format & (~0x80)) {
+ case 0:
+ encoding->num_entries = get_card8(cff);
+ (encoding->data).codes = xcalloc(encoding->num_entries, sizeof(card8));
+ for (i=0;i<(encoding->num_entries);i++) {
+ (encoding->data).codes[i] = get_card8(cff);
+ }
+ length += encoding->num_entries + 1;
+ break;
+ case 1:
+ {
+ cff_range1 *ranges;
+ encoding->num_entries = get_card8(cff);
+ encoding->data.range1 = ranges
+ = xcalloc(encoding->num_entries, sizeof(cff_range1));
+ for (i=0;i<(encoding->num_entries);i++) {
+ ranges[i].first = get_card8(cff);
+ ranges[i].n_left = get_card8(cff);
+ }
+ length += (encoding->num_entries) * 2 + 1;
+ }
+ break;
+ default:
+ xfree(encoding);
+ CFF_ERROR("Unknown Encoding format");
+ break;
+ }
+
+ /* Supplementary data */
+ if ((encoding->format) & 0x80) {
+ cff_map *map;
+ encoding->num_supps = get_card8(cff);
+ encoding->supp = map = xcalloc(encoding->num_supps, sizeof(cff_map));
+ for (i=0;i<(encoding->num_supps);i++) {
+ map[i].code = get_card8(cff);
+ map[i].glyph = get_card16(cff); /* SID */
+ }
+ length += (encoding->num_supps) * 3 + 1;
+ } else {
+ encoding->num_supps = 0;
+ encoding->supp = NULL;
+ }
+
+ return length;
+}
+
+long cff_pack_encoding (cff_font *cff, card8 *dest, long destlen)
+{
+ long len = 0;
+ cff_encoding *encoding;
+ card16 i;
+
+ if (cff->flag & HAVE_STANDARD_ENCODING || cff->encoding == NULL)
+ return 0;
+
+ if (destlen < 2)
+ CFF_ERROR("in cff_pack_encoding(): Buffer overflow");
+
+ encoding = cff->encoding;
+
+ dest[len++] = encoding->format;
+ dest[len++] = encoding->num_entries;
+ switch (encoding->format & (~0x80)) {
+ case 0:
+ if (destlen < len + encoding->num_entries)
+ CFF_ERROR("in cff_pack_encoding(): Buffer overflow");
+ for (i=0;i<(encoding->num_entries);i++) {
+ dest[len++] = (encoding->data).codes[i];
+ }
+ break;
+ case 1:
+ {
+ if (destlen < len + (encoding->num_entries)*2)
+ CFF_ERROR("in cff_pack_encoding(): Buffer overflow");
+ for (i=0;i<(encoding->num_entries);i++) {
+ dest[len++] = (encoding->data).range1[i].first & 0xff;
+ dest[len++] = (encoding->data).range1[i].n_left;
+ }
+ }
+ break;
+ default:
+ CFF_ERROR("Unknown Encoding format");
+ break;
+ }
+
+ if ((encoding->format) & 0x80) {
+ if (destlen < len + (encoding->num_supps)*3 + 1)
+ CFF_ERROR("in cff_pack_encoding(): Buffer overflow");
+ dest[len++] = encoding->num_supps;
+ for (i=0;i<(encoding->num_supps);i++) {
+ dest[len++] = (encoding->supp)[i].code;
+ dest[len++] = ((encoding->supp)[i].glyph >> 8) & 0xff;
+ dest[len++] = (encoding->supp)[i].glyph & 0xff;
+ }
+ }
+
+ return len;
+}
+
+/* CID-Keyed font specific */
+long cff_read_fdselect (cff_font *cff)
+{
+ cff_fdselect *fdsel;
+ long offset, length;
+ card16 i;
+
+ if (cff->topdict == NULL)
+ CFF_ERROR("Top DICT not available");
+
+ if (!(cff->flag & FONTTYPE_CIDFONT))
+ return 0;
+
+ offset = (long) cff_dict_get(cff->topdict, "FDSelect", 0);
+ cff->offset = offset;
+ cff->fdselect = fdsel = xcalloc(1, sizeof(cff_fdselect));
+ fdsel->format = get_card8(cff);
+
+ length = 1;
+
+ switch (fdsel->format) {
+ case 0:
+ fdsel->num_entries = cff->num_glyphs;
+ (fdsel->data).fds = xcalloc(fdsel->num_entries, sizeof(card8));
+ for (i=0;i<(fdsel->num_entries);i++) {
+ (fdsel->data).fds[i] = get_card8(cff);
+ }
+ length += fdsel->num_entries;
+ break;
+ case 3:
+ {
+ cff_range3 *ranges;
+ fdsel->num_entries = get_card16(cff);
+ fdsel->data.ranges = ranges = xcalloc(fdsel->num_entries, sizeof(cff_range3));
+ for (i=0;i<(fdsel->num_entries);i++) {
+ ranges[i].first = get_card16(cff);
+ ranges[i].fd = get_card8(cff);
+ }
+ if (ranges[0].first != 0)
+ CFF_ERROR("Range not starting with 0.");
+ if (cff->num_glyphs != get_card16(cff))
+ CFF_ERROR("Sentinel value mismatched with number of glyphs.");
+ length += (fdsel->num_entries) * 3 + 4;
+ }
+ break;
+ default:
+ xfree(fdsel);
+ CFF_ERROR("Unknown FDSelect format.");
+ break;
+ }
+
+ return length;
+}
+
+
+long cff_pack_fdselect (cff_font *cff, card8 *dest, long destlen)
+{
+ cff_fdselect *fdsel;
+ long len = 0;
+ card16 i;
+
+ if (cff->fdselect == NULL)
+ return 0;
+
+ if (destlen < 1)
+ CFF_ERROR("in cff_pack_fdselect(): Buffur overflow");
+
+ fdsel = cff->fdselect;
+
+ dest[len++] = fdsel->format;
+ switch (fdsel->format) {
+ case 0:
+ if (fdsel->num_entries != cff->num_glyphs)
+ CFF_ERROR("in cff_pack_fdselect(): Invalid data");
+ if (destlen < len + fdsel->num_entries)
+ CFF_ERROR("in cff_pack_fdselect(): Buffer overflow");
+ for (i=0;i<fdsel->num_entries;i++) {
+ dest[len++] = (fdsel->data).fds[i];
+ }
+ break;
+ case 3:
+ {
+ if (destlen < len + 2)
+ CFF_ERROR("in cff_pack_fdselect(): Buffer overflow");
+ len += 2;
+ for (i=0;i<(fdsel->num_entries);i++) {
+ if (destlen < len + 3)
+ CFF_ERROR("in cff_pack_fdselect(): Buffer overflow");
+ dest[len++] = ((fdsel->data).ranges[i].first >> 8) & 0xff;
+ dest[len++] = (fdsel->data).ranges[i].first & 0xff;
+ dest[len++] = (fdsel->data).ranges[i].fd;
+ }
+ if (destlen < len + 2)
+ CFF_ERROR("in cff_pack_fdselect(): Buffer overflow");
+ dest[len++] = (cff->num_glyphs >> 8) & 0xff;
+ dest[len++] = cff->num_glyphs & 0xff;
+ dest[1] = ((len/3 - 1) >> 8) & 0xff;
+ dest[2] = (len/3 - 1) & 0xff;
+ }
+ break;
+ default:
+ CFF_ERROR("Unknown FDSelect format.");
+ break;
+ }
+
+ return len;
+}
+
+
+
+/*
+ * Create an instance of embeddable font.
+ */
+static void
+write_fontfile (cff_font *cffont, char *fullname)
+{
+ cff_index *topdict, *fdarray, *private;
+ unsigned char *dest;
+ long destlen = 0, i, size;
+ long offset, topdict_offset, fdarray_offset;
+
+ /* DICT sizes (offset set to long int) */
+ topdict = cff_new_index(1);
+ fdarray = cff_new_index(cffont->num_fds);
+ private = cff_new_index(cffont->num_fds);
+
+ cff_dict_remove(cffont->topdict, "UniqueID");
+ cff_dict_remove(cffont->topdict, "XUID");
+ cff_dict_remove(cffont->topdict, "Private"); /* some bad font may have */
+ cff_dict_remove(cffont->topdict, "Encoding"); /* some bad font may have */
+
+ topdict->offset[1] = cff_dict_pack(cffont->topdict,
+ (card8 *) work_buffer,
+ WORK_BUFFER_SIZE) + 1;
+ for (i = 0;i < cffont->num_fds; i++) {
+ size = 0;
+ if (cffont->private && cffont->private[i]) {
+ size = cff_dict_pack(cffont->private[i],
+ (card8 *) work_buffer, WORK_BUFFER_SIZE);
+ if (size < 1) { /* Private had contained only Subr */
+ cff_dict_remove(cffont->fdarray[i], "Private");
+ }
+ }
+ (private->offset)[i+1] = (private->offset)[i] + size;
+ (fdarray->offset)[i+1] = (fdarray->offset)[i] +
+ cff_dict_pack(cffont->fdarray[i],
+ (card8 *) work_buffer, WORK_BUFFER_SIZE);
+ }
+
+ destlen = 4; /* header size */
+ destlen += cff_set_name(cffont, fullname);
+ destlen += cff_index_size(topdict);
+ destlen += cff_index_size(cffont->string);
+ destlen += cff_index_size(cffont->gsubr);
+ destlen += (cffont->charsets->num_entries) * 2 + 1; /* charset format 0 */
+ destlen += (cffont->fdselect->num_entries) * 3 + 5; /* fdselect format 3 */
+ destlen += cff_index_size(cffont->cstrings);
+ destlen += cff_index_size(fdarray);
+ destlen += private->offset[private->count] - 1; /* Private is not INDEX */
+
+ dest = xcalloc(destlen, sizeof(card8));
+
+ offset = 0;
+ /* Header */
+ offset += cff_put_header(cffont, dest + offset, destlen - offset);
+ /* Name */
+ offset += cff_pack_index(cffont->name, dest + offset, destlen - offset);
+ /* Top DICT */
+ topdict_offset = offset;
+ offset += cff_index_size(topdict);
+ /* Strings */
+ offset += cff_pack_index(cffont->string, dest + offset, destlen - offset);
+ /* Global Subrs */
+ offset += cff_pack_index(cffont->gsubr, dest + offset, destlen - offset);
+
+ /* charset */
+ cff_dict_set(cffont->topdict, "charset", 0, offset);
+ offset += cff_pack_charsets(cffont, dest + offset, destlen - offset);
+
+ /* FDSelect */
+ cff_dict_set(cffont->topdict, "FDSelect", 0, offset);
+ offset += cff_pack_fdselect(cffont, dest + offset, destlen - offset);
+
+ /* CharStrings */
+ cff_dict_set(cffont->topdict, "CharStrings", 0, offset);
+ offset += cff_pack_index(cffont->cstrings,
+ dest + offset, cff_index_size(cffont->cstrings));
+ cff_release_index(cffont->cstrings);
+ cffont->cstrings = NULL; /* Charstrings cosumes huge memory */
+
+ /* FDArray and Private */
+ cff_dict_set(cffont->topdict, "FDArray", 0, offset);
+ fdarray_offset = offset;
+ offset += cff_index_size(fdarray);
+
+ fdarray->data = xcalloc(fdarray->offset[fdarray->count] - 1, sizeof(card8));
+ for (i = 0; i < cffont->num_fds; i++) {
+ size = private->offset[i+1] - private->offset[i];
+ if (cffont->private[i] && size > 0) {
+ cff_dict_pack(cffont->private[i], dest + offset, size);
+ cff_dict_set(cffont->fdarray[i], "Private", 0, size);
+ cff_dict_set(cffont->fdarray[i], "Private", 1, offset);
+ }
+ cff_dict_pack(cffont->fdarray[i],
+ fdarray->data + (fdarray->offset)[i] - 1,
+ fdarray->offset[fdarray->count] - 1);
+ offset += size;
+ }
+
+ cff_pack_index(fdarray, dest + fdarray_offset, cff_index_size(fdarray));
+ cff_release_index(fdarray);
+ cff_release_index(private);
+
+ /* Finally Top DICT */
+ topdict->data = xcalloc(topdict->offset[topdict->count] - 1, sizeof(card8));
+ cff_dict_pack(cffont->topdict,
+ topdict->data, topdict->offset[topdict->count] - 1);
+ cff_pack_index(topdict, dest + topdict_offset, cff_index_size(topdict));
+ cff_release_index(topdict);
+
+ for (i = 0; i < offset; i++)
+ fb_putchar (dest[i]);
+
+ /*fprintf(stdout," (%i/%i)",offset,cffont->stream_size);*/
+ xfree(dest);
+ return ;
+}
+
+
+/* if the CFF data was converted from an old type1 font, then the .notdef
+ glyph may not be at id 0, so in that case |uglytype1fix| is nonzero */
+
+void write_cff(cff_font *cffont, fd_entry *fd, int uglytype1fix) {
+ cff_index *charstrings, *cs_idx;
+
+ long charstring_len, max_len;
+ long size, offset = 0;
+
+ card8 *data;
+ card16 num_glyphs, cs_count, code, gid, last_cid;
+
+ double nominal_width, default_width;
+
+ char *fullname;
+
+ glw_entry *glyph, *found;
+ struct avl_traverser t;
+
+
+
+
+ fullname = xcalloc(8+strlen(fd->fontname),1);
+ sprintf(fullname,"%s+%s",fd->subset_tag,fd->fontname);
+
+ /* finish parsing the CFF */
+ cff_read_private(cffont);
+ cff_read_subrs (cffont);
+
+ /*
+ * Widths
+ */
+ if (cffont->private[0] &&
+ cff_dict_known(cffont->private[0], "defaultWidthX")) {
+ default_width = (double) cff_dict_get(cffont->private[0], "defaultWidthX", 0);
+ } else {
+ default_width = CFF_DEFAULTWIDTHX_DEFAULT;
+ }
+ if (cffont->private[0] &&
+ cff_dict_known(cffont->private[0], "nominalWidthX")) {
+ nominal_width = (double) cff_dict_get(cffont->private[0], "nominalWidthX", 0);
+ } else {
+ nominal_width = CFF_NOMINALWIDTHX_DEFAULT;
+ }
+
+ num_glyphs = 0;
+ last_cid = 0;
+ glyph = xtalloc(1,glw_entry);
+
+ /* insert notdef */
+ glyph->id = uglytype1fix;
+ if (avl_find(fd->gl_tree, glyph)==NULL) {
+ /*fprintf(stderr,"seeding .notdef at %i\n",uglytype1fix);*/
+ avl_insert(fd->gl_tree, glyph);
+ glyph = xtalloc(1,glw_entry);
+ }
+
+
+ avl_t_init(&t, fd->gl_tree);
+ for (found = (glw_entry *) avl_t_first(&t, fd->gl_tree);
+ found != NULL;
+ found = (glw_entry *) avl_t_next(&t)) {
+ if (found->id > last_cid)
+ last_cid = found->id;
+ num_glyphs++;
+ }
+
+ {
+ cff_fdselect *fdselect;
+
+ fdselect = xcalloc(1, sizeof(cff_fdselect));
+ fdselect->format = 3;
+ fdselect->num_entries = 1;
+ fdselect->data.ranges = xcalloc(1, sizeof(cff_range3));
+ fdselect->data.ranges[0].first = 0;
+ fdselect->data.ranges[0].fd = 0;
+ cffont->fdselect = fdselect;
+ }
+
+ {
+ cff_charsets *charset;
+
+ charset = xcalloc(1, sizeof(cff_charsets));
+ charset->format = 0;
+ charset->num_entries = num_glyphs-1;
+ charset->data.glyphs = xcalloc(num_glyphs, sizeof(s_SID));
+
+ gid = 0;
+
+ avl_t_init(&t, fd->gl_tree);
+ for (found = (glw_entry *) avl_t_first(&t, fd->gl_tree);
+ found != NULL;
+ found = (glw_entry *) avl_t_next(&t)) {
+ if(found->id!=0) {
+ charset->data.glyphs[gid] = found->id;
+ gid++;
+ }
+ }
+ cffont->charsets = charset;
+ }
+
+ cff_dict_add(cffont->topdict, "CIDCount", 1);
+ cff_dict_set(cffont->topdict, "CIDCount", 0, last_cid + 1);
+
+ cffont->fdarray = xcalloc(1, sizeof(cff_dict *));
+ cffont->fdarray[0] = cff_new_dict();
+ cff_dict_add(cffont->fdarray[0], "FontName", 1);
+ cff_dict_set(cffont->fdarray[0], "FontName", 0,
+ (double) cff_add_string(cffont, fullname)); /* FIXME: Skip XXXXXX+ */
+ cff_dict_add(cffont->fdarray[0], "Private", 2);
+ cff_dict_set(cffont->fdarray[0], "Private", 0, 0.0);
+ cff_dict_set(cffont->fdarray[0], "Private", 0, 0.0);
+ /* FDArray - index offset, not known yet */
+ cff_dict_add(cffont->topdict, "FDArray", 1);
+ cff_dict_set(cffont->topdict, "FDArray", 0, 0.0);
+ /* FDSelect - offset, not known yet */
+ cff_dict_add(cffont->topdict, "FDSelect", 1);
+ cff_dict_set(cffont->topdict, "FDSelect", 0, 0.0);
+
+ cff_dict_remove(cffont->topdict, "UniqueID");
+ cff_dict_remove(cffont->topdict, "XUID");
+ cff_dict_remove(cffont->topdict, "Private");
+ cff_dict_remove(cffont->topdict, "Encoding");
+
+ cffont->offset = cff_dict_get(cffont->topdict, "CharStrings", 0);
+ cs_idx = cff_get_index_header(cffont);
+
+ offset = cffont->offset;
+ cs_count = cs_idx->count;
+ if (cs_count < 2) {
+ CFF_ERROR("No valid charstring data found.");
+ }
+
+ /* build the new charstrings entry */
+ charstrings = cff_new_index(cs_count+1);
+ max_len = 2 * CS_STR_LEN_MAX;
+ charstrings->data = xcalloc(max_len, sizeof(card8));
+ charstring_len = 0;
+
+ gid = 0;
+ data = xcalloc(CS_STR_LEN_MAX, sizeof(card8));
+
+ for (code=0; code < cs_count; code++) {
+ glyph->id = code;
+ if ((avl_find(fd->gl_tree,glyph) != NULL)) {
+ size = cs_idx->offset[code+1] - cs_idx->offset[code];
+
+ if (size > CS_STR_LEN_MAX) {
+ pdftex_fail("Charstring too long: gid=%u, %ld bytes", code, size);
+ }
+ if (charstring_len + CS_STR_LEN_MAX >= max_len) {
+ max_len = charstring_len + 2 * CS_STR_LEN_MAX;
+ charstrings->data = xrealloc(charstrings->data, max_len*sizeof(card8));
+ }
+ (charstrings->offset)[gid] = charstring_len + 1;
+ cffont->offset= offset + (cs_idx->offset)[code] - 1;
+ memcpy(data,&cffont->stream[cffont->offset],size);
+ charstring_len += cs_copy_charstring(charstrings->data + charstring_len,
+ max_len - charstring_len,
+ data, size,
+ cffont->gsubr, (cffont->subrs)[0],
+ default_width, nominal_width, NULL);
+ gid++;
+ }
+ }
+
+ /* this happens if the internal metrics do not agree with the actual disk font */
+ if (gid < num_glyphs) {
+ WARN("embedded subset is smaller than expected: %d instead of %d glyphs.", gid, num_glyphs);
+ num_glyphs = gid;
+ }
+
+ xfree(data);
+ cff_release_index(cs_idx);
+
+ (charstrings->offset)[num_glyphs] = charstring_len + 1;
+ charstrings->count = num_glyphs;
+ cffont->num_glyphs = num_glyphs;
+ cffont->cstrings = charstrings;
+
+ /*
+ * We don't use subroutines at all.
+ */
+ if (cffont->gsubr)
+ cff_release_index(cffont->gsubr);
+ cffont->gsubr = cff_new_index(0);
+
+ if (cffont->subrs && cffont->subrs[0])
+ cff_release_index(cffont->subrs[0]);
+ cffont->subrs[0] = NULL;
+
+ if (cffont->private && (cffont->private)[0]) {
+ cff_dict_remove((cffont->private)[0], "Subrs"); /* no Subrs */
+ }
+
+ cff_add_string(cffont, (char *)"Adobe");
+ cff_add_string(cffont, (char *)"Identity");
+
+ cff_dict_update(cffont->topdict, cffont);
+ cff_dict_update(cffont->private[0], cffont);
+ cff_update_string(cffont);
+
+ /* CFF code need to be rewrote... */
+ cff_dict_add(cffont->topdict, "ROS", 3);
+ cff_dict_set(cffont->topdict, "ROS", 0,
+ (double) cff_get_sid(cffont, (char *)"Adobe"));
+ cff_dict_set(cffont->topdict, "ROS", 1,
+ (double) cff_get_sid(cffont, (char *)"Identity"));
+ cff_dict_set(cffont->topdict, "ROS", 2, 0.0);
+
+ write_fontfile(cffont,fullname);
+ xfree(fullname);
+ cff_close (cffont);
+
+}
+
+#define ERROR(a) { perror(a); return 0; }
+
+/* Input : SID or CID (16-bit unsigned int)
+ * Output: glyph index
+ */
+card16
+cff_charsets_lookup (cff_font *cff, card16 cid)
+{
+ card16 gid = 0;
+ cff_charsets *charset;
+ card16 i;
+
+ if (cff->flag & (CHARSETS_ISOADOBE|CHARSETS_EXPERT|CHARSETS_EXPSUB)) {
+ ERROR("Predefined CFF charsets not supported yet");
+ } else if (cff->charsets == NULL) {
+ ERROR("Charsets data not available");
+ }
+
+ if (cid == 0) {
+ return 0; /* GID 0 (.notdef) */
+ }
+
+ charset = cff->charsets;
+
+ gid = 0;
+ switch (charset->format) {
+ case 0:
+ for (i = 0; i <charset->num_entries; i++) {
+ if (cid == charset->data.glyphs[i]) {
+ gid = i + 1;
+ return gid;
+ }
+ }
+ break;
+ case 1:
+ for (i = 0; i < charset->num_entries; i++) {
+ if (cid >= charset->data.range1[i].first &&
+ cid <= charset->data.range1[i].first + charset->data.range1[i].n_left) {
+ gid += cid - charset->data.range1[i].first + 1;
+ return gid;
+ }
+ gid += charset->data.range1[i].n_left + 1;
+ }
+ break;
+ case 2:
+ for (i = 0; i < charset->num_entries; i++) {
+ if (cid >= charset->data.range2[i].first &&
+ cid <= charset->data.range2[i].first + charset->data.range2[i].n_left) {
+ gid += cid - charset->data.range2[i].first + 1;
+ return gid;
+ }
+ gid += charset->data.range2[i].n_left + 1;
+ }
+ break;
+ default:
+ ERROR("Unknown Charset format");
+ }
+
+ return 0; /* not found */
+}
+
+
+#define is_cidfont(a) ((a)->flag & FONTTYPE_CIDFONT)
+#define CID_MAX 65535
+
+void write_cid_cff(cff_font *cffont, fd_entry *fd, int uglytype1fix) {
+ cff_index *charstrings, *cs_idx;
+
+ long charstring_len, max_len;
+ long size, offset = 0;
+
+ card8 *data;
+ card16 num_glyphs, cs_count, gid, last_cid;
+
+
+ int fdsel, prev_fd, cid_count, cid;
+ char *fullname;
+
+ glw_entry *glyph;
+
+ unsigned char *CIDToGIDMap = NULL;
+
+ cff_fdselect *fdselect = NULL;
+ cff_charsets *charset = NULL;
+
+
+ if (!is_cidfont(cffont)) {
+ perror("Not a CIDfont.");
+ return;
+ }
+
+ fullname = xcalloc(8+strlen(fd->fontname),1);
+ sprintf(fullname,"%s+%s",fd->subset_tag,fd->fontname);
+
+ /* finish parsing the CFF */
+
+ if (cff_dict_known(cffont->topdict, "CIDCount")) {
+ cid_count = (card16) cff_dict_get(cffont->topdict, "CIDCount", 0);
+ } else {
+ cid_count = CFF_CIDCOUNT_DEFAULT;
+ }
+ cff_read_charsets(cffont);
+ CIDToGIDMap = xmalloc((2*cid_count) * sizeof(unsigned char));
+ memset(CIDToGIDMap, 0, 2*cid_count);
+
+
+ glyph = xtalloc(1,glw_entry);
+ /* insert notdef */
+ glyph->id = uglytype1fix;
+ if (avl_find(fd->gl_tree, glyph)==NULL) {
+ avl_insert(fd->gl_tree, glyph);
+ glyph = xtalloc(1,glw_entry);
+ }
+
+ cid = 0; last_cid = 0; num_glyphs = 0;
+ for (cid = 0; cid <= CID_MAX; cid++) {
+ glyph->id = cid;
+ if (avl_find(fd->gl_tree,glyph) != NULL) {
+ gid = cff_charsets_lookup(cffont, cid);
+ CIDToGIDMap[2*cid] = (gid >> 8) & 0xff;
+ CIDToGIDMap[2*cid+1] = gid & 0xff;
+ last_cid = cid;
+ num_glyphs++;
+ }
+ }
+
+ cff_read_fdselect(cffont);
+ cff_read_fdarray(cffont);
+ cff_read_private(cffont);
+
+ cff_read_subrs (cffont);
+
+
+ cffont->offset = cff_dict_get(cffont->topdict, "CharStrings", 0);
+ cs_idx = cff_get_index_header(cffont);
+
+ offset = cffont->offset;
+ cs_count = cs_idx->count;
+ if (cs_count < 2) {
+ CFF_ERROR("No valid charstring data found.");
+ }
+
+ charset = xcalloc(1, sizeof(cff_charsets));
+ charset->format = 0;
+ charset->num_entries = 0;
+ charset->data.glyphs = xcalloc(num_glyphs, sizeof(s_SID));
+
+ fdselect = xcalloc(1, sizeof(cff_fdselect));
+ fdselect->format = 3;
+ fdselect->num_entries = 0;
+ fdselect->data.ranges = xcalloc(num_glyphs, sizeof(cff_range3));
+
+ charstrings = cff_new_index(cs_count+1);
+ max_len = 2 * CS_STR_LEN_MAX;
+ charstrings->data = xcalloc(max_len, sizeof(card8));
+ charstring_len = 0;
+
+ prev_fd = -1; gid = 0;
+ data = xcalloc(CS_STR_LEN_MAX, sizeof(card8));
+ for (cid=0; cid <= last_cid; cid++) {
+ unsigned short gid_org;
+
+ glyph->id = cid;
+ if (avl_find(fd->gl_tree,glyph) == NULL)
+ continue;
+
+ gid_org = (CIDToGIDMap[2*cid] << 8)|(CIDToGIDMap[2*cid+1]);
+ size = cs_idx->offset[gid_org+1] - cs_idx->offset[gid_org];
+ if (size > CS_STR_LEN_MAX) {
+ pdftex_fail("Charstring too long: gid=%u, %ld bytes", cid, size);
+ }
+ if (charstring_len + CS_STR_LEN_MAX >= max_len) {
+ max_len = charstring_len + 2 * CS_STR_LEN_MAX;
+ charstrings->data = xrealloc(charstrings->data, max_len*sizeof(card8));
+ }
+ (charstrings->offset)[gid] = charstring_len + 1;
+ cffont->offset= offset + (cs_idx->offset)[gid_org] - 1;
+ memcpy(data,&cffont->stream[cffont->offset],size);
+ fdsel = cff_fdselect_lookup(cffont, gid_org);
+ charstring_len += cs_copy_charstring(charstrings->data + charstring_len,
+ max_len - charstring_len,
+ data, size,
+ cffont->gsubr, (cffont->subrs)[fdsel],
+ 0, 0, NULL);
+
+ if (cid>0 && gid_org > 0) {
+ charset->data.glyphs[charset->num_entries] = cid;
+ charset->num_entries += 1;
+ }
+ if (fdsel != prev_fd) {
+ fdselect->data.ranges[fdselect->num_entries].first = gid;
+ fdselect->data.ranges[fdselect->num_entries].fd = fdsel;
+ fdselect->num_entries += 1;
+ prev_fd = fdsel;
+ }
+ gid++;
+ }
+
+ if (gid != num_glyphs)
+ CFF_ERROR("Unexpected error: %i != %i", gid, num_glyphs);
+ xfree(data);
+ cff_release_index(cs_idx);
+
+ xfree(CIDToGIDMap);
+
+ (charstrings->offset)[num_glyphs] = charstring_len + 1;
+ charstrings->count = num_glyphs;
+ cffont->num_glyphs = num_glyphs;
+ cffont->cstrings = charstrings;
+
+ cff_release_charsets(cffont->charsets);
+ cffont->charsets = charset;
+ cff_release_fdselect(cffont->fdselect);
+ cffont->fdselect = fdselect;
+
+ /*
+ * We don't use subroutines at all.
+ */
+ if (cffont->gsubr)
+ cff_release_index(cffont->gsubr);
+ cffont->gsubr = cff_new_index(0);
+
+ for (fdsel = 0; fdsel < cffont->num_fds; fdsel++) {
+ if (cffont->subrs && cffont->subrs[fdsel]) {
+ cff_release_index(cffont->subrs[fdsel]);
+ cffont->subrs[fdsel] = NULL;
+ }
+ if (cffont->private && (cffont->private)[fdsel]) {
+ cff_dict_remove((cffont->private)[fdsel], "Subrs"); /* no Subrs */
+ }
+ }
+
+ write_fontfile(cffont,fullname);
+ xfree(fullname);
+ cff_close (cffont);
+
+}
+
+
+/* here is a sneaky trick: fontforge knows how to convert Type1 to CFF, so
+ * I have defined a utility function in luafflib.c that does exactly that.
+ * If it works out ok, I will clean up this code.
+ */
+
+extern int ff_createcff (char *, unsigned char **, integer *);
+
+void writetype1w (fd_entry *fd) {
+ cff_font *cff;
+ int i;
+ FILE *fp;
+ ff_entry *ff;
+ unsigned char *tfm_buffer = NULL;
+ integer tfm_size = 0;
+ int notdefpos = 0;
+
+ ff = check_ff_exist(fd->fm->ff_name, 0);
+
+ fp = fopen (ff->ff_path, "rb");
+ cur_file_name = ff->ff_path;
+
+ if (!fp) {
+ fprintf(stderr,"Type1: Could not open Type1 font: %s", cur_file_name);
+ uexit(1);
+ }
+ fclose(fp);
+
+ if (tracefilenames) {
+ if (is_subsetted(fd->fm))
+ tex_printf ("<%s", cur_file_name);
+ else
+ tex_printf ("<<%s", cur_file_name);
+ }
+
+ notdefpos = ff_createcff(ff->ff_path,&tfm_buffer,&tfm_size);
+
+ if (tfm_size>0) {
+ cff = read_cff(tfm_buffer,tfm_size,0);
+ if (cff != NULL) {
+ write_cff(cff,fd,notdefpos);
+ } else {
+ for (i = 0; i < tfm_size ; i++)
+ fb_putchar (tfm_buffer[i]);
+ }
+ fd->ff_found = 1;
+ } else {
+ fprintf(stderr,"Type1: Could not understand Type1 font: %s", cur_file_name);
+ uexit(1);
+ }
+ if (tracefilenames) {
+ if (is_subsetted (fd->fm))
+ tex_printf (">");
+ else
+ tex_printf (">>");
+ }
+ cur_file_name = NULL;
+}
+
+
diff --git a/Build/source/texk/web2c/luatexdir/font/writecff.h b/Build/source/texk/web2c/luatexdir/font/writecff.h
new file mode 100644
index 00000000000..8cb93024f7a
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writecff.h
@@ -0,0 +1,349 @@
+/* $Header: /home/cvsroot/dvipdfmx/src/cff_limits.h,v 1.3 2002/10/30 02:27:05 chofchof Exp $
+
+ This is dvipdfmx, an eXtended version of dvipdfm by Mark A. Wicks.
+
+ Copyright (C) 2002 by Jin-Hwan Cho and Shunsaku Hirata,
+ the dvipdfmx project team <dvipdfmx@project.ktug.or.kr>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+*/
+
+#ifndef _CFF_LIMITS_H_
+#define _CFF_LIMITS_H_
+
+#include <limits.h>
+
+#define CFF_INT_MAX 0x7fffffff
+#define CFF_INT_MIN (-0x7fffffff - 1)
+
+#if (LONG_MAX < CFF_INT_MAX || LONG_MIN > CFF_INT_MIN)
+#error "CFF support won't work on this system."
+#endif
+
+#define CFF_SID_MAX 64999
+#define CFF_STDSTR_MAX 391
+
+/* Type 2 Charstring */
+#define CS_NUM_SUBR_MAX 65536
+#define CS_STR_LEN_MAX 65536
+#define CS_STEM_ZONE_MAX 96
+#define CS_ARG_STACK_MAX 48
+#define CS_TRANS_ARRAY_MAX 32
+#define CS_SUBR_NEST_MAX 10
+
+#endif /* _CFF_LIMITS_H_ */
+
+#ifndef _CFF_TYPES_H_
+#define _CFF_TYPES_H_
+
+/* CFF Data Types */
+
+#define CFF_TYPE_UNKNOWN 0
+#define CFF_TYPE_INTEGER (1 << 0)
+#define CFF_TYPE_REAL (1 << 1)
+#define CFF_TYPE_NUMBER (CFF_TYPE_INTEGER|CFF_TYPE_REAL)
+#define CFF_TYPE_BOOLEAN (1 << 2)
+#define CFF_TYPE_SID (1 << 3)
+#define CFF_TYPE_ARRAY (1 << 4)
+#define CFF_TYPE_DELTA (1 << 5)
+
+/* SID SID number */
+#define CFF_TYPE_ROS (1 << 6)
+/* offset(0) */
+#define CFF_TYPE_OFFSET (1 << 7)
+/* size offset(0) */
+#define CFF_TYPE_SZOFF (1 << 8)
+
+typedef unsigned char card8; /* 1-byte unsigned number */
+typedef unsigned short card16; /* 2-byte unsigned number */
+typedef unsigned char c_offsize; /* 1-byte unsigned number specifies the size
+ of an Offset field or fields, range 1-4 */
+typedef unsigned long l_offset; /* 1, 2, 3, or 4-byte offset */
+typedef unsigned short s_SID; /* 2-byte string identifier */
+
+typedef unsigned long l_size;
+
+typedef struct {
+ card16 count; /* number of objects stored in INDEX */
+ c_offsize offsize; /* Offset array element size, 1-4 */
+ l_offset *offset; /* Offset array, count + 1 offsets */
+ card8 *data; /* Object data */
+} cff_index;
+
+
+/* Dictionary */
+typedef struct {
+ int id; /* encoded data value (as card8 or card16) */
+ char *key; /* opname */
+ int count; /* number of values */
+ double *values; /* values */
+} cff_dict_entry;
+
+typedef struct {
+ int max;
+ int count;
+ cff_dict_entry *entries;
+} cff_dict;
+
+/* Encoding, Charset and FDSelect */
+typedef struct
+{
+ s_SID first; /* SID or CID, or card8 for Encoding */
+ card8 n_left; /* no. of remaining gids/codes in this range */
+} cff_range1;
+
+typedef struct
+{
+ s_SID first; /* SID or CID (card16) */
+ card16 n_left; /* card16-version of range1 */
+} cff_range2;
+
+typedef struct
+{
+ card8 code;
+ s_SID glyph;
+} cff_map;
+
+typedef struct
+{
+ card8 format; /* if (format & 0x80) then have supplement */
+ card8 num_entries; /* number of entries */
+ union {
+ card8 *codes; /* format 0 */
+ cff_range1 *range1; /* format 1 */
+ } data;
+ card8 num_supps; /* number of supplementary data */
+ cff_map *supp; /* supplement */
+} cff_encoding;
+
+typedef struct
+{
+ card8 format;
+ card16 num_entries;
+ union {
+ s_SID *glyphs; /* format 0 */
+ cff_range1 *range1; /* format 1 */
+ cff_range2 *range2; /* format 2 */
+ } data;
+} cff_charsets;
+
+/* CID-Keyed font specific */
+typedef struct
+{
+ card16 first;
+ card8 fd;
+} cff_range3;
+
+typedef struct
+{
+ card8 format;
+ card16 num_entries; /* number of glyphs/ranges */
+ union {
+ card8 *fds; /* format 0 */
+ cff_range3 *ranges; /* format 3 */
+ } data;
+ /* card16 sentinel; */ /* format 3 only, must be equals to num_glyphs */
+} cff_fdselect;
+
+#endif /* _CFF_TYPES_H_ */
+
+#ifndef _CFF_STDSTR_H_
+#define _CFF_STDSTR_H_
+
+#define CFF_STDSTR_MAX 391
+
+extern const char *const cff_stdstr[];
+#endif /* _CFF_STDSTR_H_ */
+
+#ifndef _CFF_H_
+#define _CFF_H_
+
+/*#include "mfileio.h"*/
+
+/* Flag */
+#define FONTTYPE_CIDFONT (1 << 0)
+#define FONTTYPE_FONT (1 << 1)
+#define FONTTYPE_MMASTER (1 << 2)
+
+#define ENCODING_STANDARD (1 << 3)
+#define ENCODING_EXPERT (1 << 4)
+
+#define CHARSETS_ISOADOBE (1 << 5)
+#define CHARSETS_EXPERT (1 << 6)
+#define CHARSETS_EXPSUB (1 << 7)
+
+#define HAVE_STANDARD_ENCODING (ENCODING_STANDARD|ENCODING_EXPERT)
+#define HAVE_STANDARD_CHARSETS \
+ (CHARSETS_ISOADOBE|CHARSETS_EXPERT|CHARSETS_EXPSUB)
+
+#define CFF_STRING_NOTDEF 65535
+
+typedef struct
+{
+ char *fontname; /* FontName */
+
+ /* - CFF structure - */
+
+ card8 header_major; /* major version */
+ card8 header_minor; /* minor version */
+ card8 header_hdr_size; /* Header size (bytes) */
+ c_offsize header_offsize; /* Absolute offset (0) size */
+
+ cff_index *name; /* Name INDEX */
+ cff_dict *topdict; /* Top DICT (single) */
+ cff_index *string; /* String INDEX */
+ cff_index *gsubr; /* Global Subr INDEX */
+ cff_encoding *encoding; /* Encodings */
+ cff_charsets *charsets; /* Charsets */
+ cff_fdselect *fdselect; /* FDSelect, CIDFont only */
+ cff_index *cstrings; /* CharStrings */
+ cff_dict **fdarray; /* CIDFont only */
+ cff_dict **private; /* per-Font DICT */
+ cff_index **subrs; /* Local Subr INDEX, per-Private DICT */
+
+ /* -- extra data -- */
+ l_offset gsubr_offset;
+ card16 num_glyphs; /* number of glyphs (CharString INDEX count) */
+ card8 num_fds; /* number of Font DICT */
+
+ /* Updated String INDEX.
+ * Please fix this. We should separate input and output.
+ */
+ cff_index *_string;
+
+ unsigned char *stream;
+ l_offset offset;
+ l_offset stream_size;
+
+ int index; /* CFF fontset index */
+ int flag; /* Flag: see above */
+} cff_font;
+
+extern cff_font *cff_open(unsigned char *stream, long stream_size, int n);
+extern void cff_close (cff_font *cff);
+
+#define cff_seek_set(c, p) seek_absolute (((c)->stream), ((c)->offset) + (p));
+
+/* CFF Header */
+extern long cff_put_header (cff_font *cff, card8 *dest, long destlen);
+
+/* CFF INDEX */
+extern cff_index *cff_get_index (cff_font *cff);
+extern cff_index *cff_get_index_header (cff_font *cff);
+extern void cff_release_index (cff_index *idx);
+extern cff_index *cff_new_index (card16 count);
+extern long cff_index_size (cff_index *idx);
+extern long cff_pack_index (cff_index *idx, card8 *dest, long destlen);
+
+/* Name INDEX */
+extern char *cff_get_name (cff_font *cff);
+extern long cff_set_name (cff_font *cff, char *name);
+
+/* Global and Local Subrs INDEX */
+extern long cff_read_subrs (cff_font *cff);
+
+/* Encoding */
+extern long cff_read_encoding (cff_font *cff);
+extern long cff_pack_encoding (cff_font *cff, card8 *dest, long destlen);
+extern card16 cff_encoding_lookup (cff_font *cff, card8 code);
+extern void cff_release_encoding (cff_encoding *encoding);
+
+/* Charsets */
+extern long cff_read_charsets (cff_font *cff);
+extern long cff_pack_charsets (cff_font *cff, card8 *dest, long destlen);
+
+/* Returns GID of PS name "glyph" */
+extern card16 cff_glyph_lookup (cff_font *cff, const char *glyph);
+/* Returns GID of glyph with SID/CID "cid" */
+extern card16 cff_charsets_lookup (cff_font *cff, card16 cid);
+extern void cff_release_charsets (cff_charsets *charset);
+/* Returns SID or CID */
+extern card16 cff_charsets_lookup_inverse (cff_font *cff, card16 gid);
+
+/* FDSelect */
+extern long cff_read_fdselect (cff_font *cff);
+extern long cff_pack_fdselect (cff_font *cff, card8 *dest, long destlen);
+extern card8 cff_fdselect_lookup (cff_font *cff, card16 gid);
+extern void cff_release_fdselect (cff_fdselect *fdselect);
+
+/* Font DICT(s) */
+extern long cff_read_fdarray (cff_font *cff);
+
+/* Private DICT(s) */
+extern long cff_read_private (cff_font *cff);
+
+/* String */
+extern int cff_match_string (cff_font *cff, const char *str, s_SID sid);
+extern char *cff_get_string (cff_font *cff, s_SID id);
+extern long cff_get_sid (cff_font *cff, char *str);
+extern s_SID cff_add_string (cff_font *cff, char *str);
+extern void cff_update_string (cff_font *cff);
+
+#define cff_is_stdstr(s) (cff_get_sid(NULL, (s)) >= 0)
+
+#endif /* _CFF_H_ */
+
+#ifndef _CFF_DICT_H_
+#define _CFF_DICT_H_
+
+#define CFF_CIDCOUNT_DEFAULT 8720
+#define CFF_NOMINALWIDTHX_DEFAULT 0.0
+#define CFF_DEFAULTWIDTHX_DEFAULT 0.0
+
+extern cff_dict *cff_new_dict (void);
+extern void cff_release_dict (cff_dict *dict);
+
+extern void cff_dict_set (cff_dict *dict, const char *key, int idx, double value);
+extern double cff_dict_get (cff_dict *dict, const char *key, int idx);
+extern void cff_dict_add (cff_dict *dict, const char *key, int count);
+extern void cff_dict_remove (cff_dict *dict, const char *key);
+extern int cff_dict_known (cff_dict *dict, const char *key);
+
+/* decode/encode DICT */
+extern cff_dict *cff_dict_unpack (card8 *data, card8 *endptr);
+extern long cff_dict_pack (cff_dict *dict, card8 *dest, long destlen);
+
+extern void cff_dict_update (cff_dict *dict, cff_font *cff);
+
+#endif /* _CFF_DICT_H_ */
+
+#ifndef _CS_TYPE2_H_
+#define _CS_TYPE2_H_
+
+typedef struct {
+ int flags; /* unused in Type 2 charstring */
+ double wx, wy;
+ struct {
+ double llx, lly, urx, ury;
+ } bbox;
+ struct {
+ double asb, adx, ady;
+ card8 bchar, achar;
+ } seac; /* unused in Type 2 charstring */
+} cs_ginfo;
+
+extern long cs_copy_charstring (card8 *dest, long destlen,
+ card8 *src, long srclen,
+ cff_index *gsubr, cff_index *subr,
+ double default_width, double nominal_width, cs_ginfo *ginfo);
+#endif /* _CS_TYPE2_H_ */
+
+#define cff_is_cidfont(a) (a->flag & FONTTYPE_CIDFONT)
+#define cff_understandable(a) (a->header_major==1)
+
+extern cff_font *read_cff(unsigned char *buf,long buflength, int subf);
+
+extern void write_cff(cff_font *cff, fd_entry *fd, int hack);
+extern void write_cid_cff(cff_font *cffont, fd_entry *fd, int uglytype1fix) ;
diff --git a/Build/source/texk/web2c/luatexdir/font/writeenc.c b/Build/source/texk/web2c/luatexdir/font/writeenc.c
new file mode 100644
index 00000000000..feaf1407d1e
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writeenc.c
@@ -0,0 +1,183 @@
+/*
+Copyright (c) 1996-2005 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writeenc.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+
+/**********************************************************************/
+/* All encoding entries go into AVL tree for fast search by name. */
+
+struct avl_table *fe_tree = NULL;
+
+/* AVL sort fe_entry into fe_tree by name */
+
+static int comp_fe_entry(const void *pa, const void *pb, void *p)
+{
+ return strcmp(((const fe_entry *) pa)->name, ((const fe_entry *) pb)->name);
+}
+
+fe_entry *new_fe_entry()
+{
+ fe_entry *fe;
+ fe = xtalloc(1, fe_entry);
+ fe->name = NULL;
+ fe->fe_objnum = 0;
+ fe->glyph_names = NULL; /* encoding file not yet read in */
+ fe->tx_tree = NULL;
+ return fe;
+}
+
+fe_entry *lookup_fe_entry(char *s)
+{
+ fe_entry fe;
+ assert(s != NULL);
+ fe.name = s;
+ if (fe_tree == NULL) {
+ fe_tree = avl_create(comp_fe_entry, NULL, &avl_xallocator);
+ assert(fe_tree != NULL);
+ }
+ return (fe_entry *) avl_find(fe_tree, &fe);
+}
+
+void register_fe_entry(fe_entry * fe)
+{
+ void **aa;
+ if (fe_tree == NULL) {
+ fe_tree = avl_create(comp_fe_entry, NULL, &avl_xallocator);
+ assert(fe_tree != NULL);
+ }
+ assert(fe != NULL);
+ assert(fe->name != NULL);
+ assert(lookup_fe_entry(fe->name) == NULL); /* encoding not yet registered */
+ aa = avl_probe(fe_tree, fe);
+ assert(aa != NULL);
+}
+
+fe_entry *get_fe_entry(char *s)
+{
+ fe_entry *fe;
+ char **gl;
+ if ((fe = lookup_fe_entry(s)) == NULL && (gl = load_enc_file(s)) != NULL) {
+ fe = new_fe_entry();
+ fe->name = s;
+ fe->glyph_names = gl;
+ register_fe_entry(fe);
+ }
+ return fe;
+}
+
+/**********************************************************************/
+
+void epdf_write_enc(char **glyph_names, integer fe_objnum)
+{
+ int i, i_old;
+ assert(glyph_names != NULL);
+ assert(fe_objnum != 0);
+ pdf_begin_dict(fe_objnum, 1);
+ pdf_puts("/Type /Encoding\n");
+ pdf_printf("/Differences [");
+ for (i = 0, i_old = -2; i < 256; i++)
+ if (glyph_names[i] != notdef) {
+ if (i == i_old + 1) /* no gap */
+ pdf_printf("/%s", glyph_names[i]);
+ else {
+ if (i_old == -2)
+ pdf_printf("%i/%s", i, glyph_names[i]);
+ else
+ pdf_printf(" %i/%s", i, glyph_names[i]);
+ }
+ i_old = i;
+ }
+ pdf_puts("]\n");
+ pdf_end_dict();
+}
+
+void write_enc(char **glyph_names, struct avl_table *tx_tree, integer fe_objnum)
+{
+ int i_old, *p;
+ struct avl_traverser t;
+ assert(glyph_names != NULL);
+ assert(tx_tree != NULL);
+ assert(fe_objnum != 0);
+ pdf_begin_dict(fe_objnum, 1);
+ pdf_puts("/Type /Encoding\n");
+ pdf_printf("/Differences [");
+ avl_t_init(&t, tx_tree);
+ for (i_old = -2, p = (int *) avl_t_first(&t, tx_tree); p != NULL;
+ p = (int *) avl_t_next(&t)) {
+ if (*p == i_old + 1) /* no gap */
+ pdf_printf("/%s", glyph_names[*p]);
+ else {
+ if (i_old == -2)
+ pdf_printf("%i/%s", *p, glyph_names[*p]);
+ else
+ pdf_printf(" %i/%s", *p, glyph_names[*p]);
+ }
+ i_old = *p;
+ }
+ pdf_puts("]\n");
+ pdf_end_dict();
+}
+
+void write_fontencoding(fe_entry * fe)
+{
+ assert(fe != NULL);
+ write_enc(fe->glyph_names, fe->tx_tree, fe->fe_objnum);
+}
+
+void write_fontencodings()
+{
+ fe_entry *fe;
+ struct avl_traverser t;
+ if (fe_tree == NULL)
+ return;
+ avl_t_init(&t, fe_tree);
+ for (fe = (fe_entry *) avl_t_first(&t, fe_tree); fe != NULL;
+ fe = (fe_entry *) avl_t_next(&t))
+ if (fe->fe_objnum != 0)
+ write_fontencoding(fe);
+}
+
+/**********************************************************************/
+/* cleaning up... */
+
+static void destroy_fe_entry(void *pa, void *pb)
+{
+ fe_entry *p;
+ int i;
+ p = (fe_entry *) pa;
+ xfree(p->name);
+ if (p->glyph_names != NULL)
+ for (i = 0; i < 256; i++)
+ if (p->glyph_names[i] != notdef)
+ xfree(p->glyph_names[i]);
+ xfree(p->glyph_names);
+ xfree(p);
+}
+
+void enc_free()
+{
+ if (fe_tree != NULL)
+ avl_destroy(fe_tree, destroy_fe_entry);
+ fe_tree = NULL;
+}
+
+/**********************************************************************/
diff --git a/Build/source/texk/web2c/luatexdir/font/writefont.c b/Build/source/texk/web2c/luatexdir/font/writefont.c
new file mode 100644
index 00000000000..05257746889
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writefont.c
@@ -0,0 +1,885 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writefont.c 1112 2008-03-20 14:46:32Z taco $
+*/
+
+#include "ptexlib.h"
+
+extern void writetype0 (fd_entry * fd) ;
+extern void writetype2 (fd_entry * fd) ;
+extern unsigned long cidtogid_obj;
+
+#ifdef DO_TYPE1C
+extern void writet1c(fd_entry * fd); /* in writecff.c */
+#endif
+
+extern void writet1w (fd_entry * fd); /* in writecff.c */
+extern void writetype1w (fd_entry * fd);
+extern integer write_cid_tounicode(fo_entry * fo, internalfontnumber f); /* in tounicode.c */
+
+
+void write_cid_fontdictionary(fo_entry * fo, internalfontnumber f);
+void create_cid_fontdictionary(fm_entry * fm, integer font_objnum, internalfontnumber f);
+
+/**********************************************************************/
+
+struct avl_table *fo_tree = NULL; /* tree of font dictionaries */
+struct avl_table *fd_tree = NULL; /* tree of font descriptor objects */
+
+static int comp_fo_entry(const void *pa, const void *pb, void *p)
+{
+ return strcmp(((const fo_entry *) pa)->fm->tfm_name,
+ ((const fo_entry *) pb)->fm->tfm_name);
+}
+
+static int comp_fd_entry(const void *pa, const void *pb, void *p)
+{
+ int i;
+ const fd_entry *p1 = (const fd_entry *) pa, *p2 = (const fd_entry *) pb;
+ assert(p1->fm != NULL && is_fontfile(p1->fm) &&
+ p2->fm != NULL && is_fontfile(p2->fm));
+ if ((i = strcmp(p1->fm->ff_name, p2->fm->ff_name)) != 0)
+ return i;
+ cmp_return(p1->fm->slant, p2->fm->slant);
+ cmp_return(p1->fm->extend, p2->fm->extend);
+ return 0;
+}
+
+/**********************************************************************/
+/* initialize data structure for /Type /Font */
+
+fo_entry *new_fo_entry(void)
+{
+ fo_entry *fo;
+ fo = xtalloc(1, fo_entry);
+ fo->fo_objnum = 0;
+ fo->tex_font = 0;
+ fo->fm = NULL;
+ fo->fd = NULL;
+ fo->fe = NULL;
+ fo->cw_objnum = 0;
+ fo->first_char = 1;
+ fo->last_char = 0;
+ fo->tx_tree = NULL;
+ fo->tounicode_objnum = 0;
+ return fo;
+}
+
+/* initialize data structure for /Type /FontDescriptor */
+
+fd_entry *new_fd_entry(void)
+{
+ fd_entry *fd;
+ int i;
+ fd = xtalloc(1, fd_entry);
+ fd->fd_objnum = 0;
+ fd->fontname = NULL;
+ fd->subset_tag = NULL;
+ fd->ff_found = false;
+ fd->ff_objnum = 0;
+ fd->fn_objnum = 0;
+ fd->all_glyphs = false;
+ fd->write_ttf_glyph_names = false;
+ for (i = 0; i < INT_KEYS_NUM; i++) {
+ fd->font_dim[i].val = 0;
+ fd->font_dim[i].set = false;
+ }
+ fd->fe = NULL;
+ fd->builtin_glyph_names = NULL;
+ fd->fm = NULL;
+ fd->tx_tree = NULL;
+ fd->gl_tree = NULL;
+ return fd;
+}
+
+/**********************************************************************/
+/*
+ * Only fallback values of font metrics are taken from the TFM info
+ * of f by preset_fontmetrics(). During reading of the font file,
+ * these values are replaced by metrics from the font, if available.
+ */
+
+static void preset_fontmetrics(fd_entry * fd, internalfontnumber f)
+{
+ int i;
+ fd->font_dim[ITALIC_ANGLE_CODE].val =
+ divide_scaled(-atan(get_slant(f) / 65536.0) * (180 / M_PI),
+ pdf_font_size(f), 3);
+ fd->font_dim[ASCENT_CODE].val =
+ divide_scaled(char_height(f, 'h'), pdf_font_size(f), 3);
+ fd->font_dim[CAPHEIGHT_CODE].val =
+ divide_scaled(char_height(f, 'H'), pdf_font_size(f), 3);
+ i = -divide_scaled(char_depth(f, 'y'), pdf_font_size(f), 3);
+ fd->font_dim[DESCENT_CODE].val = i < 0 ? i : 0;
+ fd->font_dim[STEMV_CODE].val =
+ divide_scaled(char_width(f, '.') / 3, pdf_font_size(f), 3);
+ fd->font_dim[XHEIGHT_CODE].val =
+ divide_scaled(get_x_height(f), pdf_font_size(f), 3);
+ fd->font_dim[FONTBBOX1_CODE].val = 0;
+ fd->font_dim[FONTBBOX2_CODE].val = fd->font_dim[DESCENT_CODE].val;
+ fd->font_dim[FONTBBOX3_CODE].val =
+ divide_scaled(get_quad(f), pdf_font_size(f), 3);
+ fd->font_dim[FONTBBOX4_CODE].val =
+ fd->font_dim[CAPHEIGHT_CODE].val > fd->font_dim[ASCENT_CODE].val ?
+ fd->font_dim[CAPHEIGHT_CODE].val : fd->font_dim[ASCENT_CODE].val;
+ for (i = 0; i < INT_KEYS_NUM; i++)
+ fd->font_dim[i].set = true;
+}
+
+static void write_fontmetrics(fd_entry * fd)
+{
+ int i;
+ if (fd->font_dim[FONTBBOX1_CODE].set && fd->font_dim[FONTBBOX2_CODE].set
+ && fd->font_dim[FONTBBOX3_CODE].set && fd->font_dim[FONTBBOX4_CODE].set)
+ pdf_printf("/%s [%i %i %i %i]\n", font_key[FONTBBOX1_CODE].pdfname,
+ (int) fd->font_dim[FONTBBOX1_CODE].val,
+ (int) fd->font_dim[FONTBBOX2_CODE].val,
+ (int) fd->font_dim[FONTBBOX3_CODE].val,
+ (int) fd->font_dim[FONTBBOX4_CODE].val);
+ for (i = 0; i < GEN_KEY_NUM; i++)
+ if (fd->font_dim[i].set)
+ pdf_printf("/%s %i\n", font_key[i].pdfname, fd->font_dim[i].val);
+}
+
+/**********************************************************************/
+
+static void preset_fontname(fo_entry * fo)
+{
+ if (fo->fm->ps_name != NULL)
+ fo->fd->fontname = xstrdup(fo->fm->ps_name); /* just fallback */
+ else
+ fo->fd->fontname = xstrdup(fo->fm->tfm_name);
+}
+
+static void write_fontname(fd_entry * fd, char *key)
+{
+ assert(fd->fontname != NULL);
+ pdf_puts("/");
+ if (key != NULL)
+ pdf_printf("%s /", key);
+ if (fd->subset_tag != NULL)
+ pdf_printf("%s+", fd->subset_tag);
+ pdf_printf("%s\n", fd->fontname);
+}
+
+static void write_fontname_object(fd_entry * fd)
+{
+ assert(fd->fn_objnum != 0);
+ pdf_begin_obj(fd->fn_objnum, 1);
+ write_fontname(fd, NULL);
+ pdf_end_obj();
+}
+
+/**********************************************************************/
+
+fd_entry *lookup_fd_entry(char *s, integer slant, integer extend)
+{
+ fd_entry fd;
+ fm_entry fm;
+ assert(s != NULL);
+ fm.ff_name = s;
+ fm.slant = slant;
+ fm.extend = extend;
+ fd.fm = &fm;
+ if (fd_tree == NULL) {
+ fd_tree = avl_create(comp_fd_entry, NULL, &avl_xallocator);
+ assert(fd_tree != NULL);
+ }
+ return (fd_entry *) avl_find(fd_tree, &fd);
+}
+
+fd_entry *lookup_fontdescriptor(fo_entry * fo)
+{
+ assert(fo != NULL);
+ assert(fo->fm != NULL);
+ assert(is_fontfile(fo->fm));
+ return lookup_fd_entry(fo->fm->ff_name, fo->fm->slant, fo->fm->extend);
+}
+
+void register_fd_entry(fd_entry * fd)
+{
+ void **aa;
+ if (fd_tree == NULL) {
+ fd_tree = avl_create(comp_fd_entry, NULL, &avl_xallocator);
+ assert(fd_tree != NULL);
+ }
+ assert(fd != NULL && fd->fm != NULL && is_fontfile(fd->fm));
+ assert(lookup_fd_entry(fd->fm->ff_name, fd->fm->slant, fd->fm->extend) == NULL); /* font descriptor not yet registered */
+ aa = avl_probe(fd_tree, fd);
+ assert(aa != NULL);
+}
+
+void create_fontdescriptor(fo_entry * fo, internalfontnumber f)
+{
+ assert(fo != NULL);
+ assert(fo->fm != NULL);
+ assert(fo->fd == NULL);
+ fo->fd = new_fd_entry();
+ preset_fontname(fo);
+ preset_fontmetrics(fo->fd, f);
+ fo->fd->fe = fo->fe; /* encoding needed by TrueType writing */
+ fo->fd->fm = fo->fm; /* map entry needed by TrueType writing */
+ fo->fd->gl_tree = avl_create(comp_string_entry, NULL, &avl_xallocator);
+ assert(fo->fd->gl_tree != NULL);
+}
+
+/**********************************************************************/
+/*
+ * For all used characters of TeX font f, get corresponding glyph names
+ * from external reencoding (.enc) file and collect these in the glyph
+ * tree gl_tree of font descriptor fd referenced by font dictionary fo.
+ */
+
+void mark_reenc_glyphs(fo_entry * fo, internalfontnumber f)
+{
+ int i;
+ char **g;
+ void **aa;
+ assert(fo->fe != NULL);
+ if (is_subsetted(fo->fm)) {
+ assert(is_included(fo->fm));
+ /* mark glyphs from TeX (externally reencoded characters) */
+ g = fo->fe->glyph_names;
+ for (i = fo->first_char; i <= fo->last_char; i++) {
+ if (pdf_char_marked(f, i) && g[i] != notdef
+ && (char *) avl_find(fo->fd->gl_tree, g[i]) == NULL) {
+ aa = avl_probe(fo->fd->gl_tree, xstrdup(g[i]));
+ assert(aa != NULL);
+ }
+ }
+ }
+}
+
+/*
+ * Function mark_chars() has 2 uses:
+ * 1. Mark characters as chars on TeX level.
+ * 2. Mark encoding pairs used by TeX to optimize encoding vector.
+ */
+
+struct avl_table *mark_chars(fo_entry * fo, struct avl_table *tx_tree,
+ internalfontnumber f)
+{
+ int i, *j;
+ void **aa;
+ if (tx_tree == NULL) {
+ tx_tree = avl_create(comp_int_entry, NULL, &avl_xallocator);
+ assert(tx_tree != NULL);
+ }
+ for (i = fo->first_char; i <= fo->last_char; i++) {
+ if (pdf_char_marked(f, i) && (int *) avl_find(tx_tree, &i) == NULL) {
+ j = xtalloc(1, int);
+ *j = i;
+ aa = avl_probe(tx_tree, j);
+ assert(aa != NULL);
+ }
+ }
+ return tx_tree;
+}
+
+/**********************************************************************/
+
+void get_char_range(fo_entry * fo, internalfontnumber f)
+{
+ int i;
+ assert(fo != NULL);
+ for (i = font_bc(f); i <= font_ec(f); i++) /* search for first_char and last_char */
+ if (pdf_char_marked(f, i))
+ break;
+ fo->first_char = i;
+ for (i = font_ec(f); i >= font_bc(f); i--)
+ if (pdf_char_marked(f, i))
+ break;
+ fo->last_char = i;
+ if ((fo->first_char > fo->last_char)
+ || !pdf_char_marked(f, fo->first_char)) { /* no character used from this font */
+ fo->last_char = 0;
+ fo->first_char = fo->last_char + 1;
+ }
+}
+
+static void write_charwidth_array(fo_entry * fo, internalfontnumber f)
+{
+ int i, j, *ip, *fip, width;
+ struct avl_traverser t;
+ assert(fo->tx_tree != NULL);
+ assert(fo->cw_objnum == 0);
+ fo->cw_objnum = pdf_new_objnum();
+ pdf_begin_obj(fo->cw_objnum, 1);
+ avl_t_init(&t, fo->tx_tree);
+ fip = (int *) avl_t_first(&t, fo->tx_tree);
+ assert(fip != NULL);
+ pdf_puts("[");
+ for (ip = fip, j = *ip; ip != NULL; ip = (int *) avl_t_next(&t)) {
+ if (ip != fip)
+ pdf_puts(" ");
+ i = *ip;
+ while (j < i - 1) {
+ pdf_puts("0 ");
+ j++;
+ }
+ j = i;
+ width = divide_scaled(char_width(f, i), pdf_font_size(f), 4);
+ pdf_printf("%i", (int) width / 10); /* see adv_char_width() in pdftex.web */
+ if ((width = width % 10) != 0)
+ pdf_printf(".%i", width);
+ }
+ pdf_puts("]\n");
+ pdf_end_obj();
+}
+
+/**********************************************************************/
+/*
+ * Remark: Font objects from embedded PDF files are never registered
+ * into fo_tree; they are individually written out.
+ */
+
+fo_entry *lookup_fo_entry(char *s)
+{
+ fo_entry fo;
+ fm_entry fm;
+ assert(s != NULL);
+ fm.tfm_name = s;
+ fo.fm = &fm;
+ if (fo_tree == NULL) {
+ fo_tree = avl_create(comp_fo_entry, NULL, &avl_xallocator);
+ assert(fo_tree != NULL);
+ }
+ return (fo_entry *) avl_find(fo_tree, &fo);
+}
+
+void register_fo_entry(fo_entry * fo)
+{
+ void **aa;
+ if (fo_tree == NULL) {
+ fo_tree = avl_create(comp_fo_entry, NULL, &avl_xallocator);
+ assert(fo_tree != NULL);
+ }
+ assert(fo != NULL);
+ assert(fo->fm != NULL);
+ assert(fo->fm->tfm_name != NULL);
+ assert (lookup_fo_entry(fo->fm->tfm_name) == NULL) ;
+ aa = avl_probe(fo_tree, fo);
+ assert(aa != NULL);
+}
+
+/**********************************************************************/
+
+static void write_fontfile(fd_entry * fd)
+{
+ assert(is_included(fd->fm));
+ if (is_cidkeyed(fd->fm)) {
+ if (is_opentype(fd->fm))
+ writetype0(fd);
+ else if (is_truetype(fd->fm))
+ writetype2(fd);
+ else if (is_type1(fd->fm))
+ writetype1w(fd);
+ else
+ assert(0);
+ } else {
+ if (is_type1(fd->fm))
+#ifdef DO_TYPE1C
+ writet1c(fd);
+#else
+ writet1(fd);
+#endif
+ else if (is_truetype(fd->fm))
+ writettf(fd);
+ else if (is_opentype(fd->fm))
+ writeotf(fd);
+ else
+ assert(0);
+ }
+ if (!fd->ff_found)
+ return;
+ assert(fd->ff_objnum == 0);
+ fd->ff_objnum = pdf_new_objnum();
+ pdf_begin_dict(fd->ff_objnum, 0); /* font file stream */
+ if (is_cidkeyed(fd->fm)) {
+ /* No subtype is used for TrueType-based OpenType fonts */
+ if (is_opentype(fd->fm) || is_type1(fd->fm))
+ pdf_puts("/Subtype /CIDFontType0C\n");
+ /* else
+ pdf_puts("/Subtype /OpenType\n");*/
+ } else {
+ if (is_type1(fd->fm))
+ pdf_printf("/Length1 %i\n/Length2 %i\n/Length3 %i\n",
+ (int) t1_length1, (int) t1_length2, (int) t1_length3);
+ else if (is_truetype(fd->fm))
+ pdf_printf("/Length1 %i\n", (int) ttf_length);
+ else if (is_opentype(fd->fm))
+ pdf_puts("/Subtype /Type1C\n");
+ else
+ assert(0);
+ }
+ pdf_begin_stream();
+ fb_flush();
+ pdf_end_stream();
+}
+
+/**********************************************************************/
+
+static void write_fontdescriptor(fd_entry * fd)
+{
+ char *glyph;
+ struct avl_traverser t;
+ assert(fd != NULL && fd->fm != NULL);
+
+ if (is_fontfile(fd->fm))
+ write_fontfile(fd); /* this will set fd->ff_found if font file is found */
+ if (fd->fn_objnum != 0)
+ write_fontname_object(fd);
+ if (fd->fd_objnum == 0)
+ fd->fd_objnum = pdf_new_objnum();
+ pdf_begin_dict(fd->fd_objnum, 1);
+ pdf_puts("/Type /FontDescriptor\n");
+ write_fontname(fd, "FontName");
+ if (!fd->ff_found && fd->fm->fd_flags == 4)
+ pdf_puts("/Flags 34\n"); /* assumes a roman sans serif font */
+ else
+ pdf_printf("/Flags %i\n", (int) fd->fm->fd_flags);
+ write_fontmetrics(fd);
+ if (is_cidkeyed(fd->fm)) {
+ if (is_type1(fd->fm))
+ pdf_printf("/FontFile3 %i 0 R\n", (int) fd->ff_objnum);
+ else if (is_truetype(fd->fm))
+ pdf_printf("/FontFile2 %i 0 R\n", (int) fd->ff_objnum);
+ else if (is_opentype(fd->fm))
+ pdf_printf("/FontFile3 %i 0 R\n", (int) fd->ff_objnum);
+ else
+ assert(0);
+ } else {
+ if (fd->ff_found) {
+ if (is_subsetted(fd->fm) && is_type1(fd->fm)) {
+ /* /CharSet is optional; names may appear in any order */
+ assert(fd->gl_tree != NULL);
+ avl_t_init(&t, fd->gl_tree);
+ pdf_puts("/CharSet (");
+ for (glyph = (char *) avl_t_first(&t, fd->gl_tree); glyph != NULL;
+ glyph = (char *) avl_t_next(&t))
+ pdf_printf("/%s", glyph);
+ pdf_puts(")\n");
+ }
+ if (is_type1(fd->fm))
+ pdf_printf("/FontFile %i 0 R\n", (int) fd->ff_objnum);
+ else if (is_truetype(fd->fm))
+ pdf_printf("/FontFile2 %i 0 R\n", (int) fd->ff_objnum);
+ else if (is_opentype(fd->fm))
+ pdf_printf("/FontFile3 %i 0 R\n", (int) fd->ff_objnum);
+ else
+ assert(0);
+ }
+ }
+ /* TODO: Optional keys for CID fonts.
+
+ The most interesting ones are
+ /Style << /Panose <12-byte string>>>
+ and
+ /CIDSET <stream>
+ the latter can be used in subsets, to give the included CIDs
+ as a bitmap on the whole list.
+ */
+ pdf_end_dict();
+}
+
+void write_fontdescriptors()
+{
+ fd_entry *fd;
+ struct avl_traverser t;
+ if (fd_tree == NULL)
+ return;
+ avl_t_init(&t, fd_tree);
+ for (fd = (fd_entry *) avl_t_first(&t, fd_tree); fd != NULL;
+ fd = (fd_entry *) avl_t_next(&t))
+ write_fontdescriptor(fd);
+}
+
+/**********************************************************************/
+
+void write_fontdictionary(fo_entry * fo)
+{
+ assert(fo != NULL);
+ assert(fo->fm != NULL);
+ assert(fo->fo_objnum != 0); /* reserved as pdf_font_num(f) in pdftex.web */
+
+ /* write ToUnicode entry if needed */
+ if (fixed_gen_tounicode > 0 && fo->fd != NULL) {
+ if (fo->fe != NULL) {
+ fo->tounicode_objnum =
+ write_tounicode(fo->fe->glyph_names, fo->fe->name);
+ } else if (is_type1(fo->fm)) {
+ assert(fo->fd->builtin_glyph_names != NULL);
+ fo->tounicode_objnum =
+ write_tounicode(fo->fd->builtin_glyph_names, fo->fm->tfm_name);
+ }
+ }
+
+ pdf_begin_dict(fo->fo_objnum, 1);
+ pdf_puts("/Type /Font\n");
+ pdf_puts("/Subtype /");
+ if (is_type1(fo->fm))
+#ifdef DO_TYPE1C
+ pdf_printf("%s\n", "Type1C");
+#else
+ pdf_printf("%s\n", "Type1");
+#endif
+ else if (is_truetype(fo->fm))
+ pdf_printf("%s\n", "TrueType");
+ else if (is_opentype(fo->fm))
+ pdf_printf("%s\n", "Type1");
+ else
+ assert(0);
+ assert(fo->fd != NULL && fo->fd->fd_objnum != 0);
+ write_fontname(fo->fd, "BaseFont");
+ pdf_printf("/FontDescriptor %i 0 R\n", (int) fo->fd->fd_objnum);
+ assert(fo->cw_objnum != 0);
+ pdf_printf("/FirstChar %i\n/LastChar %i\n/Widths %i 0 R\n",
+ (int) fo->first_char, (int) fo->last_char,
+ (int) fo->cw_objnum);
+ if ((is_type1(fo->fm) || is_opentype(fo->fm)) && fo->fe != NULL && fo->fe->fe_objnum != 0)
+ pdf_printf("/Encoding %i 0 R\n", (int) fo->fe->fe_objnum);
+ if (fo->tounicode_objnum != 0)
+ pdf_printf("/ToUnicode %i 0 R\n", (int) fo->tounicode_objnum);
+ if (pdf_font_attr(fo->tex_font) != get_nullstr()) {
+ pdf_print(pdf_font_attr(fo->tex_font));
+ pdf_puts("\n");
+ }
+ pdf_end_dict();
+}
+
+void write_fontdictionaries()
+{
+ fo_entry *fo;
+ struct avl_traverser t;
+ if (fo_tree == NULL)
+ return;
+ avl_t_init(&t, fo_tree);
+ for (fo = (fo_entry *) avl_t_first(&t, fo_tree); fo != NULL;
+ fo = (fo_entry *) avl_t_next(&t))
+ write_fontdictionary(fo);
+}
+
+/**********************************************************************/
+/*
+ * Final flush of all font related stuff by call from
+ * @<Output fonts definition@>= in pdftex.web.
+ */
+
+void write_fontstuff()
+{
+ write_fontdescriptors();
+ write_fontencodings(); /* see writeenc.c */
+ write_fontdictionaries();
+}
+
+/**********************************************************************/
+
+void create_fontdictionary(fm_entry * fm, integer font_objnum,
+ internalfontnumber f)
+{
+ fo_entry *fo = new_fo_entry();
+ get_char_range(fo, f); /* set fo->first_char and fo->last_char from f */
+ assert(fo->last_char >= fo->first_char);
+ fo->fm = fm;
+ fo->fo_objnum = font_objnum;
+ fo->tex_font = f;
+ if (is_reencoded(fo->fm)) { /* at least the map entry tells so */
+ fo->fe = get_fe_entry(fo->fm->encname); /* returns NULL if .enc file couldn't be opened */
+ if (fo->fe != NULL && (is_type1(fo->fm) || is_opentype(fo->fm))) {
+ if (fo->fe->fe_objnum == 0)
+ fo->fe->fe_objnum = pdf_new_objnum(); /* then it will be written out */
+ /* mark encoding pairs used by TeX to optimize encoding vector */
+ fo->fe->tx_tree = mark_chars(fo, fo->fe->tx_tree, f);
+ }
+ }
+ fo->tx_tree = mark_chars(fo, fo->tx_tree, f); /* for write_charwidth_array() */
+ write_charwidth_array(fo, f);
+ if (!is_builtin(fo->fm)) {
+ if (is_type1(fo->fm)) {
+ if ((fo->fd = lookup_fontdescriptor(fo)) == NULL) {
+ create_fontdescriptor(fo, f);
+ register_fd_entry(fo->fd);
+ }
+ } else
+ create_fontdescriptor(fo, f);
+ if (fo->fe != NULL) {
+ mark_reenc_glyphs(fo, f);
+ if (!is_type1(fo->fm)) {
+ /* mark reencoded characters as chars on TeX level */
+ assert(fo->fd->tx_tree == NULL);
+ fo->fd->tx_tree = mark_chars(fo, fo->fd->tx_tree, f);
+ if (is_truetype(fo->fm))
+ fo->fd->write_ttf_glyph_names = true;
+ }
+ } else
+ /* mark non-reencoded characters as chars on TeX level */
+ fo->fd->tx_tree = mark_chars(fo, fo->fd->tx_tree, f);
+ if (!is_type1(fo->fm))
+ write_fontdescriptor(fo->fd);
+ } else {
+ /* builtin fonts still need the /Widths array and /FontDescriptor
+ * (to avoid error 'font FOO contains bad /BBox')
+ */
+ create_fontdescriptor(fo, f);
+ write_fontdescriptor(fo->fd);
+ if (!is_std_t1font(fo->fm))
+ pdftex_warn("font `%s' is not a standard font; "
+ "I suppose it is available to your PDF viewer then",
+ fo->fm->ps_name);
+ }
+ if (is_type1(fo->fm))
+ register_fo_entry(fo);
+ else
+ write_fontdictionary(fo);
+}
+
+/**********************************************************************/
+
+
+void do_pdf_font(integer font_objnum, internalfontnumber f)
+{
+ fm_entry *fm;
+ /* This is not 100% true: CID is actually needed whenever (and
+ * only) there are more than 256 separate glyphs used. But for
+ * now, just assume the user knows what he is doing;
+ */
+ if (font_encodingbytes(f)==2) {
+ /* Create a virtual font map entry, as this is needed by the
+ * rest of the font inclusion mechanism.
+ */
+ fm = new_fm_entry();
+ fm->tfm_name = font_name(f); /* or whatever, not a real tfm */
+ fm->ff_name = font_filename(f); /* the actual file */
+ fm->encname = font_encodingname(f); /* for the CIDSystemInfo */
+ fm->ps_name = font_fullname(f); /* the true name */
+ fm->slant = font_slant(f); /* slant factor */
+ fm->extend = font_extend(f); /* extension factor */
+ fm->fd_flags = 4; /* can perhaps be done better */
+ fm->in_use = true;
+
+ switch (font_format(f)) {
+ case opentype_format: set_opentype(fm); break;
+ case truetype_format: set_truetype(fm); break;
+ case type1_format: set_type1(fm); break;
+ default:
+ pdftex_fail("writefont.c: The file format (%s) for font `%s' is incompatible with wide characters\n",
+ font_format_name(f),font_name(f));
+ }
+ /* This makes "unknown" default to subsetted inclusion */
+ if (font_embedding(f)!=no_embedding) {
+ set_included(fm);
+ if (font_embedding(f)!=full_embedding) {
+ set_subsetted(fm);
+ }
+ }
+ set_cidkeyed(fm);
+ create_cid_fontdictionary(fm, font_objnum, f);
+
+ } else {
+ fm = hasfmentry(f) ? (fm_entry *) font_map(f) : NULL;
+ if (fm == NULL || (fm->ps_name == NULL && fm->ff_name == NULL))
+ writet3(font_objnum, f);
+ else
+ create_fontdictionary(fm, font_objnum, f);
+ }
+}
+
+/**********************************************************************/
+
+
+/*
+ The glyph width is included in |glw_entry|, because that width
+ depends on the value it has in the font where it is actually
+ typeset from, not the font that is the 'owner' of the fd entry.
+
+ TODO: It is possible that the user messes with the metric width,
+ but handling that properly would require access to the 'hmtx' table
+ at this point in the program.
+*/
+
+int comp_glw_entry(const void *pa, const void *pb, void *p)
+{
+ unsigned short i, j;
+ i = (*(glw_entry *)pa).id;
+ j = (*(glw_entry *)pb).id;
+ cmp_return(i,j);
+ return 0;
+}
+
+void create_cid_fontdescriptor(fo_entry * fo, internalfontnumber f)
+{
+ assert(fo != NULL);
+ assert(fo->fm != NULL);
+ assert(fo->fd == NULL);
+ fo->fd = new_fd_entry();
+ preset_fontname(fo);
+ preset_fontmetrics(fo->fd, f);
+ fo->fd->fe = fo->fe; /* encoding needed by TrueType writing */
+ fo->fd->fm = fo->fm; /* map entry needed by TrueType writing */
+ fo->fd->gl_tree = avl_create(comp_glw_entry, NULL, &avl_xallocator);
+ assert(fo->fd->gl_tree != NULL);
+}
+
+/*
+ The values |font_bc()| and |font_ec()| are potentially large
+ character ids, but the strings that are written out use CID
+ indexes, and those are limited to 16-bit values.
+*/
+
+static void mark_cid_subset_glyphs(fo_entry *fo, internal_font_number f)
+{
+ int i, k;
+ glw_entry *j;
+ void *aa;
+ for (k = 1; k <= max_font_id(); k++) {
+ if ( k == f || -f == pdf_font_num(k)) {
+ for (i = font_bc(k); i <= font_ec(k); i++) {
+ if (char_exists(k,i) && char_used(k,i)) {
+ j = xtalloc(1,glw_entry);
+ j->id = char_index(k,i);
+ j->wd = divide_scaled_n(char_width(k, i), pdf_font_size(k), 10000.0);
+ if ((glw_entry *)avl_find(fo->fd->gl_tree,j) == NULL) {
+ aa = avl_probe(fo->fd->gl_tree, j);
+ assert(aa != NULL);
+ }
+ }
+ }
+ }
+ }
+}
+
+/*
+ It is possible to compress the widths array even better, by using the
+ alternate 'range' syntax and possibly even using /DW to set
+ a default value.
+
+ There is a some optimization here already: glyphs that are
+ not used do not appear in the widths array at all.
+
+ We have to make sure that we do not output an (incorrect!)
+ width for a character that exists in the font, but is not used
+ in typesetting. An enormous negative width is used as sentinel value
+*/
+
+
+static void write_cid_charwidth_array(fo_entry * fo)
+{
+ int i, j;
+ glw_entry *glyph;
+ struct avl_traverser t;
+
+ assert(fo->cw_objnum == 0);
+ fo->cw_objnum = pdf_new_objnum();
+ pdf_begin_obj(fo->cw_objnum, 1);
+ avl_t_init(&t, fo->fd->gl_tree);
+ glyph = (glw_entry *) avl_t_first(&t, fo->fd->gl_tree);
+ assert(glyph != NULL);
+ i = glyph->id;
+ pdf_printf("[ %i [", i);
+ for (; glyph != NULL; glyph = (glw_entry *) avl_t_next(&t)) {
+ j = glyph->wd;
+ if (glyph->id>(i+1)) {
+ pdf_printf("] %i [", glyph->id);
+ j = glyph->wd;
+ }
+ if (glyph->id==(i+1))
+ pdf_puts(" ");
+ pdf_printf("%i", (j/10));
+ if ((j % 10) != 0)
+ pdf_printf(".%i", (j % 10));
+ i = glyph->id;
+ }
+ pdf_puts("]]\n");
+ pdf_end_obj();
+}
+
+
+void create_cid_fontdictionary(fm_entry * fm, integer font_objnum,
+ internalfontnumber f)
+{
+ fo_entry *fo = new_fo_entry();
+ get_char_range(fo, f); /* set fo->first_char and fo->last_char from f */
+ assert(fo->last_char >= fo->first_char);
+ fo->fm = fm;
+ fo->fo_objnum = font_objnum;
+ fo->tex_font = f;
+ create_cid_fontdescriptor (fo, f);
+ mark_cid_subset_glyphs (fo,f);
+ if (is_subsetted(fo->fm)) {
+ /*
+ this is a bit sneaky. |make_subset_tag()| actually expects the glyph tree
+ to contain strings instead of |glw_entry| items. However, all calculations
+ are done using explicit typecasts, so it works out ok.
+ */
+ make_subset_tag(fo->fd);
+ }
+ write_cid_charwidth_array(fo);
+ write_fontdescriptor(fo->fd);
+
+ write_cid_fontdictionary(fo,f);
+}
+
+void write_cid_fontdictionary(fo_entry * fo, internalfontnumber f)
+{
+ int i;
+
+ fo->tounicode_objnum = write_cid_tounicode(fo,f);
+
+ pdf_begin_dict(fo->fo_objnum, 1);
+ pdf_puts("/Type /Font\n");
+ pdf_puts("/Subtype /Type0\n");
+ pdf_puts("/Encoding /Identity-H\n");
+ write_fontname(fo->fd, "BaseFont");
+ i = pdf_new_objnum();
+ pdf_printf("/DescendantFonts [%i 0 R]\n", i);
+ /* todo: the ToUnicode CMap */
+ if (fo->tounicode_objnum != 0)
+ pdf_printf("/ToUnicode %i 0 R\n", (int) fo->tounicode_objnum);
+
+ pdf_end_dict();
+
+ pdf_begin_dict(i, 1);
+ pdf_puts("/Type /Font\n");
+ if (is_opentype(fo->fm) || is_type1(fo->fm)) {
+ pdf_puts("/Subtype /CIDFontType0\n");
+ } else {
+ pdf_puts("/Subtype /CIDFontType2\n");
+ pdf_printf("/CIDToGIDMap /Identity\n");
+ }
+ write_fontname(fo->fd, "BaseFont");
+ pdf_printf("/FontDescriptor %i 0 R\n", (int) fo->fd->fd_objnum);
+ pdf_printf("/W %i 0 R\n",(int) fo->cw_objnum);
+ pdf_printf("/CIDSystemInfo <<\n");
+ pdf_printf("/Registry (%s)\n", (font_cidregistry(f)? font_cidregistry(f): "Adobe"));
+ pdf_printf("/Ordering (%s)\n",(font_cidordering(f)? font_cidordering(f) : "Identity")) ;
+ pdf_printf("/Supplement %u\n",(unsigned int)font_cidsupplement(f));
+ pdf_printf(">>\n");
+
+ /* I doubt there is anything useful that could be written here */
+ /*
+ if (pdf_font_attr(fo->tex_font) != get_nullstr()) {
+ pdf_print(pdf_font_attr(fo->tex_font));
+ pdf_puts("\n");
+ }
+ */
+ pdf_end_dict();
+
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/font/writet1.c b/Build/source/texk/web2c/luatexdir/font/writet1.c
new file mode 100644
index 00000000000..376135dc8be
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writet1.c
@@ -0,0 +1,1768 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id $
+
+*/
+
+# include "ptexlib.h"
+# include <kpathsea/c-vararg.h>
+# include <kpathsea/c-proto.h>
+# include <string.h>
+# include "luatex-api.h"
+
+# define t1_log(s) if(tracefilenames) tex_printf(s)
+# define get_length1() t1_length1 = t1_offset() - t1_save_offset
+# define get_length2() t1_length2 = t1_offset() - t1_save_offset
+# define get_length3() t1_length3 = fixedcontent? t1_offset() - t1_save_offset : 0
+# define save_offset() t1_save_offset = t1_offset()
+
+# define t1_putchar fb_putchar
+# define t1_offset fb_offset
+# define out_eexec_char t1_putchar
+
+# define end_last_eexec_line() \
+ t1_eexec_encrypt = false
+# define t1_char(c) c
+# define embed_all_glyphs(tex_font) fm_cur->all_glyphs
+# define extra_charset() fm_cur->charset
+# define update_subset_tag() \
+ strncpy(fb_array + t1_fontname_offset, fm_cur->subset_tag, 6)
+# define fixedcontent false
+
+integer t1_length1, t1_length2, t1_length3;
+static integer t1_save_offset;
+static integer t1_fontname_offset;
+extern char *fb_array;
+
+static unsigned char *t1_buffer = NULL;
+static integer t1_size = 0;
+static integer t1_curbyte = 0;
+
+#define t1_read_file() \
+ readbinfile(t1_file,&t1_buffer,&t1_size)
+#define t1_close() xfclose(t1_file,cur_file_name)
+#define t1_getchar() t1_buffer[t1_curbyte++]
+#define t1_ungetchar(c) t1_curbyte--
+#define t1_eof() (t1_curbyte>t1_size)
+
+#define t1_prefix(s) str_prefix(t1_line_array, s)
+#define t1_buf_prefix(s) str_prefix(t1_buf_array, s)
+#define t1_suffix(s) str_suffix(t1_line_array, t1_line_ptr, s)
+#define t1_buf_suffix(s) str_suffix(t1_buf_array, t1_buf_ptr, s)
+#define t1_charstrings() strstr(t1_line_array, charstringname)
+#define t1_subrs() t1_prefix("/Subrs")
+#define t1_end_eexec() t1_suffix("mark currentfile closefile")
+#define t1_cleartomark() t1_prefix("cleartomark")
+
+static unsigned char *enc_buffer = NULL;
+static integer enc_size = 0;
+static integer enc_curbyte = 0;
+
+#define enc_open() \
+ open_input(&enc_file, kpse_enc_format, FOPEN_RBIN_MODE)
+#define enc_read_file() \
+ readbinfile(enc_file,&enc_buffer,&enc_size)
+#define enc_close() xfclose(enc_file,cur_file_name)
+#define enc_getchar() enc_buffer[enc_curbyte++]
+#define enc_eof() (enc_curbyte>enc_size)
+
+#define valid_code(c) (c >= 0 && c < 256)
+#define fixedcontent false
+
+static const char *standard_glyph_names[256] = {
+ /* 0x00 */
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ /* 0x10 */
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ /* 0x20 */
+ "space", "exclam", "quotedbl", "numbersign", "dollar", "percent",
+ "ampersand", "quoteright", "parenleft", "parenright", "asterisk",
+ "plus", "comma", "hyphen", "period", "slash",
+ /* 0x30 */
+ "zero", "one", "two", "three", "four", "five", "six", "seven", "eight",
+ "nine", "colon", "semicolon", "less", "equal", "greater", "question",
+ /* 0x40 */
+ "at", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N",
+ "O",
+ /* 0x50 */
+ "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "bracketleft",
+ "backslash", "bracketright", "asciicircum", "underscore",
+ /* 0x60 */
+ "quoteleft", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l",
+ "m", "n", "o",
+ /* 0x70 */
+ "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "braceleft", "bar",
+ "braceright", "asciitilde", notdef,
+ /* 0x80 */
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ /* 0x90 */
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ /* 0xa0 */
+ notdef, "exclamdown", "cent", "sterling", "fraction", "yen", "florin",
+ "section", "currency", "quotesingle", "quotedblleft", "guillemotleft",
+ "guilsinglleft", "guilsinglright", "fi", "fl",
+ /* 0xb0 */
+ notdef, "endash", "dagger", "daggerdbl", "periodcentered", notdef,
+ "paragraph", "bullet", "quotesinglbase", "quotedblbase",
+ "quotedblright", "guillemotright", "ellipsis", "perthousand", notdef,
+ "questiondown",
+ /* 0xc0 */
+ notdef, "grave", "acute", "circumflex", "tilde", "macron", "breve",
+ "dotaccent", "dieresis", notdef,
+ "ring", "cedilla", notdef, "hungarumlaut", "ogonek", "caron",
+ /* 0xd0 */
+ "emdash", notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ /* 0xe0 */
+ notdef, "AE", notdef, "ordfeminine", notdef, notdef, notdef, notdef,
+ "Lslash", "Oslash", "OE", "ordmasculine", notdef, notdef, notdef,
+ notdef,
+ /* 0xf0 */
+ notdef, "ae", notdef, notdef, notdef, "dotlessi", notdef, notdef, "lslash",
+ "oslash", "oe", "germandbls", notdef, notdef, notdef, notdef
+};
+
+
+integer t1_length1, t1_length2, t1_length3;
+static integer t1_save_offset;
+static integer t1_fontname_offset;
+extern char *fb_array;
+static fd_entry *fd_cur;
+
+static char charstringname[] = "/CharStrings";
+
+enum { ENC_STANDARD, ENC_BUILTIN } t1_encoding;
+
+#define T1_BUF_SIZE 0x10
+#define ENC_BUF_SIZE 0x1000
+
+#define CS_HSTEM 1
+#define CS_VSTEM 3
+#define CS_VMOVETO 4
+#define CS_RLINETO 5
+#define CS_HLINETO 6
+#define CS_VLINETO 7
+#define CS_RRCURVETO 8
+#define CS_CLOSEPATH 9
+#define CS_CALLSUBR 10
+#define CS_RETURN 11
+#define CS_ESCAPE 12
+#define CS_HSBW 13
+#define CS_ENDCHAR 14
+#define CS_RMOVETO 21
+#define CS_HMOVETO 22
+#define CS_VHCURVETO 30
+#define CS_HVCURVETO 31
+#define CS_1BYTE_MAX (CS_HVCURVETO + 1)
+
+#define CS_DOTSECTION CS_1BYTE_MAX + 0
+#define CS_VSTEM3 CS_1BYTE_MAX + 1
+#define CS_HSTEM3 CS_1BYTE_MAX + 2
+#define CS_SEAC CS_1BYTE_MAX + 6
+#define CS_SBW CS_1BYTE_MAX + 7
+#define CS_DIV CS_1BYTE_MAX + 12
+#define CS_CALLOTHERSUBR CS_1BYTE_MAX + 16
+#define CS_POP CS_1BYTE_MAX + 17
+#define CS_SETCURRENTPOINT CS_1BYTE_MAX + 33
+#define CS_2BYTE_MAX (CS_SETCURRENTPOINT + 1)
+#define CS_MAX CS_2BYTE_MAX
+
+typedef unsigned char byte;
+
+typedef struct {
+ byte nargs; /* number of arguments */
+ boolean bottom; /* take arguments from bottom of stack? */
+ boolean clear; /* clear stack? */
+ boolean valid;
+} cc_entry; /* CharString Command */
+
+typedef struct {
+ char *name; /* glyph name (or notdef for Subrs entry) */
+ byte *data;
+ unsigned short len; /* length of the whole string */
+ unsigned short cslen; /* length of the encoded part of the string */
+ boolean used;
+ boolean valid;
+} cs_entry;
+
+static unsigned short t1_dr, t1_er;
+static const unsigned short t1_c1 = 52845, t1_c2 = 22719;
+static unsigned short t1_cslen;
+static short t1_lenIV;
+static char enc_line[ENC_BUF_SIZE];
+
+/* define t1_line_ptr, t1_line_array & t1_line_limit */
+typedef char t1_line_entry;
+define_array (t1_line);
+
+/* define t1_buf_ptr, t1_buf_array & t1_buf_limit */
+typedef char t1_buf_entry;
+define_array (t1_buf);
+
+static int cs_start;
+
+static cs_entry *cs_tab, *cs_ptr, *cs_notdef;
+static char *cs_dict_start, *cs_dict_end;
+static int cs_counter, cs_size, cs_size_pos;
+
+static cs_entry *subr_tab;
+static char *subr_array_start, *subr_array_end;
+static int subr_max, subr_size, subr_size_pos;
+
+/* This list contains the begin/end tokens commonly used in the */
+/* /Subrs array of a Type 1 font. */
+
+static const char *cs_token_pairs_list[][2] = {
+ {" RD", "NP"},
+ {" -|", "|"},
+ {" RD", "noaccess put"},
+ {" -|", "noaccess put"},
+ {NULL, NULL}
+};
+static const char **cs_token_pair;
+
+static boolean t1_pfa, t1_cs, t1_scan, t1_eexec_encrypt, t1_synthetic;
+static int t1_in_eexec; /* 0 before eexec-encrypted, 1 during, 2 after */
+static long t1_block_length;
+static int last_hexbyte;
+static FILE *t1_file;
+static FILE *enc_file;
+
+static void enc_getline (void)
+{
+ char *p;
+ int c;
+ restart:
+ if (enc_eof ())
+ pdftex_fail ("unexpected end of file");
+ p = enc_line;
+ do {
+ c = enc_getchar ();
+ append_char_to_buf (c, p, enc_line, ENC_BUF_SIZE);
+ }
+ while (c != 10 && !enc_eof());
+ append_eol (p, enc_line, ENC_BUF_SIZE);
+ if (p - enc_line < 2 || *enc_line == '%')
+ goto restart;
+}
+
+/* read encoding from .enc file, return glyph_names array, or pdffail() */
+
+char **load_enc_file(char *enc_name)
+{
+ int callback_id = 0;
+ int file_opened = 0;
+ char *ftemp = NULL;
+ char buf[ENC_BUF_SIZE], *p, *r;
+ int i, names_count;
+ char **glyph_names;
+ char *tempname ;
+ set_cur_file_name (enc_name);
+ callback_id=callback_defined(find_enc_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",(char *)(nameoffile+1),&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(nameoffile);
+ namelength = strlen(ftemp);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),ftemp);
+ free(ftemp);
+ } else {
+ return NULL;
+ }
+ }
+ }
+ callback_id=callback_defined(read_enc_file_callback);
+ enc_curbyte=0;
+ enc_size=0;
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",(char *)(nameoffile+1),
+ &file_opened, &enc_buffer,&enc_size)) {
+ if((!file_opened) || enc_size==0) {
+ pdftex_warn ("cannot open encoding file for reading");
+ cur_file_name = NULL;
+ return NULL;
+ }
+ }
+ } else {
+ if (!enc_open ()) {
+ pdftex_warn ("cannot open encoding file for reading");
+ cur_file_name = NULL;
+ return NULL;
+ }
+ enc_read_file();
+ enc_close();
+ }
+ glyph_names = xtalloc(256, char *);
+ for (i = 0; i < 256; i++)
+ glyph_names[i] = (char *) notdef;
+ t1_log ("{");
+
+ tempname = xmalloc(namelength+2);
+ strcpy(tempname,(char *)(nameoffile+1));
+ set_cur_file_name (tempname);
+ t1_log (cur_file_name);
+ enc_getline ();
+ if (*enc_line != '/' || (r = strchr (enc_line, '[')) == NULL) {
+ remove_eol (r, enc_line);
+ pdftex_fail
+ ("invalid encoding vector (a name or `[' missing): `%s'", enc_line);
+ }
+ names_count = 0;
+ r++; /* skip '[' */
+ skip (r, ' ');
+ for (;;) {
+ while (*r == '/') {
+ for (p = buf, r++;
+ *r != ' ' && *r != 10 && *r != ']' && *r != '/'; *p++ = *r++);
+ *p = 0;
+ skip (r, ' ');
+ if (names_count > 256)
+ pdftex_fail ("encoding vector contains more than 256 names");
+ if (strcmp (buf, notdef) != 0)
+ glyph_names[names_count] = xstrdup (buf);
+ names_count++;
+ }
+ if (*r != 10 && *r != '%') {
+ if (strncmp (r, "] def", strlen ("] def")) == 0)
+ goto done;
+ else {
+ remove_eol (r, enc_line);
+ pdftex_fail
+ ("invalid encoding vector: a name or `] def' expected: `%s'",
+ enc_line);
+ }
+ }
+ enc_getline ();
+ r = enc_line;
+ }
+ done:
+ t1_log ("}");
+ cur_file_name = NULL;
+ return glyph_names;
+}
+
+void free_glyph_names(char **glyph_names)
+{
+ int i;
+ assert(glyph_names != NULL);
+ for (i = 0; i < 256; i++)
+ if (glyph_names[i] != notdef)
+ xfree(glyph_names[i]);
+ xfree(glyph_names);
+}
+
+
+static void t1_check_pfa (void)
+{
+ const int c = t1_getchar ();
+ t1_pfa = (c != 128) ? true : false;
+ t1_ungetchar (c);
+}
+
+static int t1_getbyte (void)
+{
+ int c = t1_getchar ();
+ if (t1_pfa)
+ return c;
+ if (t1_block_length == 0) {
+ if (c != 128)
+ pdftex_fail ("invalid marker");
+ c = t1_getchar ();
+ if (c == 3) {
+ while (!t1_eof ())
+ (void)t1_getchar ();
+ return EOF;
+ }
+ t1_block_length = t1_getchar () & 0xff;
+ t1_block_length |= (t1_getchar () & 0xff) << 8;
+ t1_block_length |= (t1_getchar () & 0xff) << 16;
+ t1_block_length |= (t1_getchar () & 0xff) << 24;
+ c = t1_getchar ();
+ }
+ t1_block_length--;
+ return c;
+}
+
+static int hexval (int c)
+{
+ if (c >= 'A' && c <= 'F')
+ return c - 'A' + 10;
+ else if (c >= 'a' && c <= 'f')
+ return c - 'a' + 10;
+ else if (c >= '0' && c <= '9')
+ return c - '0';
+ else
+ return -1;
+}
+
+static byte edecrypt (byte cipher)
+{
+ byte plain;
+ if (t1_pfa) {
+ while (cipher == 10 || cipher == 13)
+ cipher = t1_getbyte ();
+ last_hexbyte = cipher = (hexval (cipher) << 4) + hexval (t1_getbyte ());
+ }
+ plain = (cipher ^ (t1_dr >> 8));
+ t1_dr = (cipher + t1_dr) * t1_c1 + t1_c2;
+ return plain;
+}
+
+static byte cdecrypt (byte cipher, unsigned short *cr)
+{
+ const byte plain = (cipher ^ (*cr >> 8));
+ *cr = (cipher + *cr) * t1_c1 + t1_c2;
+ return plain;
+}
+
+static byte eencrypt (byte plain)
+{
+ const byte cipher = (plain ^ (t1_er >> 8));
+ t1_er = (cipher + t1_er) * t1_c1 + t1_c2;
+ return cipher;
+}
+
+static byte cencrypt (byte plain, unsigned short *cr)
+{
+ const byte cipher = (plain ^ (*cr >> 8));
+ *cr = (cipher + *cr) * t1_c1 + t1_c2;
+ return cipher;
+}
+
+static char *eol (char *s)
+{
+ char *p = strend (s);
+ if (p - s > 1 && p[-1] != 10) {
+ *p++ = 10;
+ *p = 0;
+ }
+ return p;
+}
+
+static float t1_scan_num (char *p, char **r)
+{
+ float f;
+ skip (p, ' ');
+ if (sscanf (p, "%g", &f) != 1) {
+ remove_eol (p, t1_line_array);
+ pdftex_fail ("a number expected: `%s'", t1_line_array);
+ }
+ if (r != NULL) {
+ for (; isdigit (*p) || *p == '.' ||
+ *p == 'e' || *p == 'E' || *p == '+' || *p == '-'; p++);
+ *r = p;
+ }
+ return f;
+}
+
+static boolean str_suffix (const char *begin_buf, const char *end_buf,
+ const char *s)
+{
+ const char *s1 = end_buf - 1, *s2 = strend (s) - 1;
+ if (*s1 == 10)
+ s1--;
+ while (s1 >= begin_buf && s2 >= s) {
+ if (*s1-- != *s2--)
+ return false;
+ }
+ return s2 < s;
+}
+
+static void t1_getline (void)
+{
+ int c, l, eexec_scan;
+ char *p;
+ static const char eexec_str[] = "currentfile eexec";
+ static int eexec_len = 17; /* strlen(eexec_str) */
+ restart:
+ if (t1_eof ())
+ pdftex_fail ("unexpected end of file");
+ t1_line_ptr = t1_line_array;
+ alloc_array (t1_line, 1, T1_BUF_SIZE);
+ t1_cslen = 0;
+ eexec_scan = 0;
+ c = t1_getbyte ();
+ if (c == EOF)
+ goto exit;
+ while (!t1_eof ()) {
+ if (t1_in_eexec == 1)
+ c = edecrypt (c);
+ alloc_array (t1_line, 1, T1_BUF_SIZE);
+ append_char_to_buf (c, t1_line_ptr, t1_line_array, t1_line_limit);
+ if (t1_in_eexec == 0 && eexec_scan >= 0 && eexec_scan < eexec_len) {
+ if (t1_line_array[eexec_scan] == eexec_str[eexec_scan])
+ eexec_scan++;
+ else
+ eexec_scan = -1;
+ }
+ if (c == 10 || (t1_pfa && eexec_scan == eexec_len && c == 32))
+ break;
+ if (t1_cs && t1_cslen == 0 && (t1_line_ptr - t1_line_array > 4) &&
+ (t1_suffix (" RD ") || t1_suffix (" -| "))) {
+ p = t1_line_ptr - 5;
+ while (*p != ' ')
+ p--;
+ t1_cslen = l = t1_scan_num (p + 1, 0);
+ cs_start = t1_line_ptr - t1_line_array; /* cs_start is an index now */
+ alloc_array (t1_line, l, T1_BUF_SIZE);
+ while (l-- > 0)
+ *t1_line_ptr++ = edecrypt (t1_getbyte ());
+ }
+ c = t1_getbyte ();
+ }
+ alloc_array (t1_line, 2, T1_BUF_SIZE); /* append_eol can append 2 chars */
+ append_eol (t1_line_ptr, t1_line_array, t1_line_limit);
+ if (t1_line_ptr - t1_line_array < 2)
+ goto restart;
+ if (eexec_scan == eexec_len)
+ t1_in_eexec = 1;
+ exit:
+ /* ensure that t1_buf_array has as much room as t1_line_array */
+ t1_buf_ptr = t1_buf_array;
+ alloc_array (t1_buf, t1_line_limit, t1_line_limit);
+}
+
+static void t1_putline (void)
+{
+ char *p = t1_line_array;
+ if (t1_line_ptr - t1_line_array <= 1)
+ return;
+ if (t1_eexec_encrypt) {
+ while (p < t1_line_ptr)
+ t1_putchar (eencrypt (*p++));
+ } else
+ while (p < t1_line_ptr)
+ t1_putchar (*p++);
+}
+
+static void t1_puts (const char *s)
+{
+ if (s != t1_line_array)
+ strcpy (t1_line_array, s);
+ t1_line_ptr = strend (t1_line_array);
+ t1_putline ();
+}
+
+__attribute__ ((format (printf, 1, 2)))
+static void t1_printf (const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+ vsprintf (t1_line_array, fmt, args);
+ t1_puts (t1_line_array);
+ va_end (args);
+}
+
+static void t1_init_params (const char *open_name_prefix)
+{
+ t1_log (open_name_prefix);
+ t1_log (cur_file_name);
+ t1_lenIV = 4;
+ t1_dr = 55665;
+ t1_er = 55665;
+ t1_in_eexec = 0;
+ t1_cs = false;
+ t1_scan = true;
+ t1_synthetic = false;
+ t1_eexec_encrypt = false;
+ t1_block_length = 0;
+ t1_check_pfa ();
+}
+
+static void t1_close_font_file (const char *close_name_suffix)
+{
+ t1_log (close_name_suffix);
+ cur_file_name = NULL;
+}
+
+static void t1_check_block_len (boolean decrypt)
+{
+ int l, c;
+ if (t1_block_length == 0)
+ return;
+ c = t1_getbyte ();
+ if (decrypt)
+ c = edecrypt (c);
+ l = t1_block_length;
+ if (!(l == 0 && (c == 10 || c == 13))) {
+ pdftex_warn ("%i bytes more than expected were ignored", l + 1);
+ while (l-- > 0)
+ t1_getbyte ();
+ }
+}
+
+static void t1_start_eexec (void)
+{
+ int i;
+ assert(is_included(fd_cur->fm));
+ get_length1 ();
+ save_offset ();
+
+ if (!t1_pfa)
+ t1_check_block_len (false);
+ for (t1_line_ptr = t1_line_array, i = 0; i < 4; i++) {
+ edecrypt (t1_getbyte ());
+ *t1_line_ptr++ = 0;
+ }
+ t1_eexec_encrypt = true;
+ t1_putline (); /* to put the first four bytes */
+}
+
+static void t1_stop_eexec (void)
+{
+ int c;
+ assert(is_included(fd_cur->fm));
+ get_length2 ();
+ save_offset ();
+ t1_eexec_encrypt = false;
+ if (!t1_pfa)
+ t1_check_block_len (true);
+ else {
+ c = edecrypt (t1_getbyte ());
+ if (!(c == 10 || c == 13)) {
+ if (last_hexbyte == 0)
+ t1_puts ("00");
+ else
+ pdftex_warn ("unexpected data after eexec");
+ }
+ }
+ t1_cs = false;
+ t1_in_eexec = 2;
+}
+
+/* macros for various transforms; currently only slant and extend are used */
+
+# define do_xshift(x,a) {x[4]+=a;}
+# define do_yshift(x,a) {x[5]+=a;}
+# define do_xscale(x,a) {x[0]*=a; x[2]*=a; x[4]*=a;}
+# define do_yscale(x,a) {x[1]*=a; x[3]*=a; x[5]*=a;}
+# define do_extend(x,a) {do_xscale(x,a);}
+# define do_scale(x,a) {do_xscale(x,a); do_yscale(x,a);}
+# define do_slant(x,a) {x[0]+=x[1]*(a); x[2]+=x[3]*(a); x[4]+=x[5]*(a);}
+# define do_shear(x,a) {x[1]+=x[0]*(a); x[3]+=x[2]*(a); x[5]+=x[4]*(a);}
+# define do_rotate(x,a) \
+ {float t, u=cos(a), v=sin(a); \
+ t =x[0]*u+x[1]*-v; \
+ x[1] =x[0]*v+x[1]* u; x[0]=t; \
+ t =x[2]*u+x[3]*-v; \
+ x[3] =x[2]*v+x[3]* u; x[2]=t; \
+ t =x[4]*u+x[5]*-v; \
+ x[5] =x[4]*v+x[5]* u; x[4]=t;}
+
+static void t1_modify_fm (void)
+{
+ /*
+ * font matrix is given as six numbers a0..a5, which stands for the matrix
+ *
+ * a0 a1 0
+ * M = a2 a3 0
+ * a4 a5 1
+ *
+ * ExtendFont is given as
+ *
+ * e 0 0
+ * E = 0 1 0
+ * 0 0 1
+ *
+ * SlantFont is given as
+ *
+ * 1 0 0
+ * S = s 1 0
+ * 0 0 1
+ *
+ * The slant transform must be done _before_ the extend transform
+ * for compatibility!
+ */
+ float a[6];
+ int i, c;
+ char *p, *q, *r;
+ if ((p = strchr (t1_line_array, '[')) == 0)
+ if ((p = strchr (t1_line_array, '{')) == 0) {
+ remove_eol (p, t1_line_array);
+ pdftex_fail ("FontMatrix: an array expected: `%s'", t1_line_array);
+ }
+ c = *p++; /* save the character '[' resp. '{' */
+ strncpy (t1_buf_array, t1_line_array, (size_t) (p - t1_line_array));
+ r = t1_buf_array + (p - t1_line_array);
+ for (i = 0; i < 6; i++) {
+ a[i] = t1_scan_num (p, &q);
+ p = q;
+ }
+ if (fm_slant(fd_cur->fm) != 0)
+ do_slant(a, fm_slant(fd_cur->fm) * 1E-3);
+ if (fm_extend(fd_cur->fm) != 0)
+ do_extend(a, fm_extend(fd_cur->fm) * 1E-3);
+ for (i = 0; i < 6; i++) {
+ sprintf (r, "%g ", a[i]);
+ r = strend (r);
+ }
+ if (c == '[') {
+ while (*p != ']' && *p != 0)
+ p++;
+ } else {
+ while (*p != '}' && *p != 0)
+ p++;
+ }
+ if (*p == 0) {
+ remove_eol (p, t1_line_array);
+ pdftex_fail
+ ("FontMatrix: cannot find the corresponding character to '%c': `%s'",
+ c, t1_line_array);
+ }
+ strcpy (r, p);
+ strcpy (t1_line_array, t1_buf_array);
+ t1_line_ptr = eol (t1_line_array);
+}
+
+static void t1_modify_italic (void)
+{
+ float a;
+ char *p, *r;
+ if (fm_slant(fd_cur->fm) == 0)
+ return;
+ p = strchr (t1_line_array, ' ');
+ strncpy (t1_buf_array, t1_line_array, (size_t) (p - t1_line_array + 1));
+ a = t1_scan_num (p + 1, &r);
+ a -= atan (fm_slant(fd_cur->fm) * 1E-3) * (180 / M_PI);
+ sprintf (t1_buf_array + (p - t1_line_array + 1), "%g", a);
+ strcpy (strend (t1_buf_array), r);
+ strcpy (t1_line_array, t1_buf_array);
+ t1_line_ptr = eol (t1_line_array);
+ fd_cur->font_dim[ITALIC_ANGLE_CODE].val = round(a);
+ fd_cur->font_dim[ITALIC_ANGLE_CODE].set = true;
+}
+
+static void t1_scan_keys (void)
+{
+ int i, k;
+ char *p, *q, *r;
+ key_entry *key;
+ if (fm_extend(fd_cur->fm) != 0 || fm_slant(fd_cur->fm) != 0) {
+ if (t1_prefix ("/FontMatrix")) {
+ t1_modify_fm ();
+ return;
+ }
+ if (t1_prefix ("/ItalicAngle")) {
+ t1_modify_italic ();
+ return;
+ }
+ }
+ if (t1_prefix ("/FontType")) {
+ p = t1_line_array + strlen ("FontType") + 1;
+ if ((i = t1_scan_num (p, 0)) != 1)
+ pdftex_fail ("Type%d fonts unsupported by pdfTeX", i);
+ return;
+ }
+ for (key = (key_entry *) font_key; key - font_key < FONT_KEYS_NUM; key++) {
+ if (key->t1name[0] != '\0' &&
+ str_prefix(t1_line_array + 1, key->t1name))
+ break;
+ }
+ if (key - font_key == FONT_KEYS_NUM)
+ return;
+ p = t1_line_array + strlen (key->t1name) + 1;
+ skip (p, ' ');
+ if ((k = key - font_key) == FONTNAME_CODE) {
+ if (*p != '/') {
+ remove_eol (p, t1_line_array);
+ pdftex_fail ("a name expected: `%s'", t1_line_array);
+ }
+ r = ++p; /* skip the slash */
+ for (q = t1_buf_array; *p != ' ' && *p != 10; *q++ = *p++);
+ *q = 0;
+ if (fm_slant(fd_cur->fm) != 0) {
+ sprintf(q, "-Slant_%i", (int) fm_slant(fd_cur->fm));
+ q = strend (q);
+ }
+ if (fm_extend(fd_cur->fm) != 0) {
+ sprintf(q, "-Extend_%i", (int) fm_extend(fd_cur->fm));
+ }
+ xfree(fd_cur->fontname);
+ fd_cur->fontname = xstrdup(t1_buf_array);
+ /* at this moment we cannot call make_subset_tag() yet, as the encoding
+ * is not read; thus we mark the offset of the subset tag and write it
+ * later */
+ if (is_subsetted(fd_cur->fm)) {
+ assert(is_included(fd_cur->fm));
+ t1_fontname_offset = t1_offset () + (r - t1_line_array);
+ strcpy (t1_buf_array, p);
+ sprintf(r, "ABCDEF+%s%s", fd_cur->fontname, t1_buf_array);
+ t1_line_ptr = eol (r);
+ }
+ return;
+ }
+ if ((k == STEMV_CODE || k == FONTBBOX1_CODE)
+ && (*p == '[' || *p == '{'))
+ p++;
+ if (k == FONTBBOX1_CODE) {
+ for (i = 0; i < 4; i++, k++) {
+ fd_cur->font_dim[k].val = t1_scan_num(p, &r);
+ fd_cur->font_dim[k].set = true;
+ p = r;
+ }
+ return;
+ }
+ fd_cur->font_dim[k].val = t1_scan_num(p, 0);
+ fd_cur->font_dim[k].set = true;
+}
+
+static void t1_scan_param (void)
+{
+ static const char *lenIV = "/lenIV";
+ if (!t1_scan || *t1_line_array != '/')
+ return;
+ if (t1_prefix (lenIV)) {
+ t1_lenIV = t1_scan_num (t1_line_array + strlen (lenIV), 0);
+ return;
+ }
+ t1_scan_keys ();
+}
+
+static void copy_glyph_names (char **glyph_names, int a, int b)
+{
+ if (glyph_names[b] != notdef) {
+ xfree (glyph_names[b]);
+ glyph_names[b] = (char *) notdef;
+ }
+ if (glyph_names[a] != notdef) {
+ glyph_names[b] = xstrdup (glyph_names[a]);
+ }
+}
+
+/* read encoding from Type1 font file, return glyph_names array, or pdffail() */
+
+char **t1_builtin_enc(void)
+{
+ int i, a, b, c, counter = 0;
+ char *r, *p, **glyph_names;
+ /* At this moment "/Encoding" is the prefix of t1_line_array */
+ glyph_names = xtalloc(256, char *);
+ for (i = 0; i < 256; i++)
+ glyph_names[i] = (char *) notdef;
+ if (t1_suffix("def")) { /* predefined encoding */
+ sscanf(t1_line_array + strlen("/Encoding"), "%256s", t1_buf_array);
+ if (strcmp(t1_buf_array, "StandardEncoding") == 0) {
+ t1_encoding = ENC_STANDARD;
+ for (i = 0; i < 256; i++) {
+ if (standard_glyph_names[i] != notdef)
+ glyph_names[i] = xstrdup(standard_glyph_names[i]);
+ }
+ return glyph_names;
+ } else
+ pdftex_fail
+ ("cannot subset font (unknown predefined encoding `%s')",
+ t1_buf_array);
+ }
+ /* At this moment "/Encoding" is the prefix of t1_line_array, and the encoding is
+ * not a predefined encoding.
+ *
+ * We have two possible forms of Encoding vector. The first case is
+ *
+ * /Encoding [/a /b /c...] readonly def
+ *
+ * and the second case can look like
+ *
+ * /Encoding 256 array 0 1 255 {1 index exch /.notdef put} for
+ * dup 0 /x put
+ * dup 1 /y put
+ * ...
+ * readonly def
+ */
+ t1_encoding = ENC_BUILTIN;
+ if (t1_prefix("/Encoding [") || t1_prefix("/Encoding[")) { /* the first case */
+ r = strchr(t1_line_array, '[') + 1;
+ skip(r, ' ');
+ for (;;) {
+ while (*r == '/') {
+ for (p = t1_buf_array, r++;
+ *r != 32 && *r != 10 && *r != ']' && *r != '/';
+ *p++ = *r++);
+ *p = 0;
+ skip(r, ' ');
+ if (counter > 255)
+ pdftex_fail("encoding vector contains more than 256 names");
+ if (strcmp(t1_buf_array, notdef) != 0)
+ glyph_names[counter] = xstrdup(t1_buf_array);
+ counter++;
+ }
+ if (*r != 10 && *r != '%') {
+ if (str_prefix(r, "] def")
+ || str_prefix(r, "] readonly def"))
+ break;
+ else {
+ remove_eol(r, t1_line_array);
+ pdftex_fail
+ ("a name or `] def' or `] readonly def' expected: `%s'",
+ t1_line_array);
+ }
+ }
+ t1_getline();
+ r = t1_line_array;
+ }
+ } else { /* the second case */
+ p = strchr(t1_line_array, 10);
+ for (;;) {
+ if (*p == 10) {
+ t1_getline();
+ p = t1_line_array;
+ }
+ /*
+ check for `dup <index> <glyph> put'
+ */
+ if (sscanf(p, "dup %i%256s put", &i, t1_buf_array) == 2 &&
+ *t1_buf_array == '/' && valid_code(i)) {
+ if (strcmp(t1_buf_array + 1, notdef) != 0)
+ glyph_names[i] = xstrdup(t1_buf_array + 1);
+ p = strstr(p, " put") + strlen(" put");
+ skip(p, ' ');
+ }
+ /*
+ check for `dup dup <to> exch <from> get put'
+ */
+ else if (sscanf(p, "dup dup %i exch %i get put", &b, &a) == 2
+ && valid_code(a) && valid_code(b)) {
+ copy_glyph_names(glyph_names, a, b);
+ p = strstr(p, " get put") + strlen(" get put");
+ skip(p, ' ');
+ }
+ /*
+ check for `dup dup <from> <size> getinterval <to> exch putinterval'
+ */
+ else if (sscanf
+ (p, "dup dup %i %i getinterval %i exch putinterval",
+ &a, &c, &b) == 3 && valid_code(a) && valid_code(b)
+ && valid_code(c)) {
+ for (i = 0; i < c; i++)
+ copy_glyph_names(glyph_names, a + i, b + i);
+ p = strstr(p, " putinterval") + strlen(" putinterval");
+ skip(p, ' ');
+ }
+ /*
+ check for `def' or `readonly def'
+ */
+ else if ((p == t1_line_array || (p > t1_line_array && p[-1] == ' '))
+ && strcmp(p, "def\n") == 0)
+ return glyph_names;
+ /*
+ skip an unrecognizable word
+ */
+ else {
+ while (*p != ' ' && *p != 10)
+ p++;
+ skip(p, ' ');
+ }
+ }
+ }
+ return glyph_names;
+}
+
+
+static void t1_check_end (void)
+{
+ if (t1_eof ())
+ return;
+ t1_getline ();
+ if (t1_prefix ("{restore}"))
+ t1_putline ();
+}
+
+static boolean t1_open_fontfile (const char *open_name_prefix)
+{
+ int callback_id = 0;
+ int file_opened = 0;
+ char *ftemp = NULL;
+ ff_entry *ff;
+ ff = check_ff_exist(fd_cur->fm->ff_name, is_truetype(fd_cur->fm));
+ t1_curbyte = 0;
+ t1_size = 0;
+ if (ff->ff_path != NULL) {
+ callback_id=callback_defined(find_type1_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",ff->ff_path,&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ strcpy(ff->ff_path,ftemp);
+ }
+ }
+ }
+ callback_id=callback_defined(read_type1_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",ff->ff_path,
+ &file_opened, &t1_buffer,&t1_size)
+ && file_opened && t1_size>0) {
+ cur_file_name = ff->ff_path;
+ } else {
+ set_cur_file_name (fd_cur->fm->ff_name);
+ pdftex_warn ("cannot open Type 1 font file for reading");
+ return false;
+ }
+ } else {
+ t1_file = xfopen (cur_file_name = ff->ff_path, FOPEN_RBIN_MODE);
+ t1_read_file();
+ t1_close();
+ }
+ }
+ else {
+ set_cur_file_name (fd_cur->fm->ff_name);
+ pdftex_warn ("cannot open Type 1 font file for reading");
+ return false;
+ }
+ t1_init_params (open_name_prefix);
+ return true;
+}
+
+static void t1_include (void)
+{
+ do {
+ t1_getline ();
+ t1_scan_param ();
+ t1_putline ();
+ }
+ while (t1_in_eexec == 0);
+ t1_start_eexec ();
+ do {
+ t1_getline ();
+ t1_scan_param ();
+ t1_putline ();
+ }
+ while (!(t1_charstrings () || t1_subrs ()));
+ t1_cs = true;
+ do {
+ t1_getline ();
+ t1_putline ();
+ }
+ while (!t1_end_eexec ());
+ t1_stop_eexec ();
+ if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
+ do {
+ t1_getline ();
+ t1_putline ();
+ }
+ while (!t1_cleartomark ());
+ t1_check_end (); /* write "{restore}if" if found */
+ }
+ get_length3 ();
+}
+
+#define check_subr(subr) \
+ if (subr >= subr_size || subr < 0) \
+ pdftex_fail("Subrs array: entry index out of range (%i)", subr);
+
+static const char **check_cs_token_pair ()
+{
+ const char **p = (const char **) cs_token_pairs_list;
+ for (; p[0] != NULL; ++p)
+ if (t1_buf_prefix (p[0]) && t1_buf_suffix (p[1]))
+ return p;
+ return NULL;
+}
+
+static void cs_store (boolean is_subr)
+{
+ char *p;
+ cs_entry *ptr;
+ int subr;
+ for (p = t1_line_array, t1_buf_ptr = t1_buf_array; *p != ' ';
+ *t1_buf_ptr++ = *p++);
+ *t1_buf_ptr = 0;
+ if (is_subr) {
+ subr = t1_scan_num (p + 1, 0);
+ check_subr (subr);
+ ptr = subr_tab + subr;
+ } else {
+ ptr = cs_ptr++;
+ if (cs_ptr - cs_tab > cs_size)
+ pdftex_fail
+ ("CharStrings dict: more entries than dict size (%i)", cs_size);
+ if (strcmp (t1_buf_array + 1, notdef) == 0) /* skip the slash */
+ ptr->name = (char *) notdef;
+ else
+ ptr->name = xstrdup (t1_buf_array + 1);
+ }
+ /* copy " RD " + cs data to t1_buf_array */
+ memcpy (t1_buf_array, t1_line_array + cs_start - 4,
+ (unsigned) (t1_cslen + 4));
+ /* copy the end of cs data to t1_buf_array */
+ for (p = t1_line_array + cs_start + t1_cslen, t1_buf_ptr =
+ t1_buf_array + t1_cslen + 4; *p != 10; *t1_buf_ptr++ = *p++);
+ *t1_buf_ptr++ = 10;
+ if (is_subr && cs_token_pair == NULL)
+ cs_token_pair = check_cs_token_pair ();
+ ptr->len = t1_buf_ptr - t1_buf_array;
+ ptr->cslen = t1_cslen;
+ ptr->data = xtalloc (ptr->len, byte);
+ memcpy (ptr->data, t1_buf_array, ptr->len);
+ ptr->valid = true;
+}
+
+#define store_subr() cs_store(true)
+#define store_cs() cs_store(false)
+
+#define CC_STACK_SIZE 24
+
+static integer cc_stack[CC_STACK_SIZE], *stack_ptr = cc_stack;
+static cc_entry cc_tab[CS_MAX];
+static boolean is_cc_init = false;
+
+
+#define cc_pop(N) \
+ if (stack_ptr - cc_stack < (N)) \
+ stack_error(N); \
+ stack_ptr -= N
+
+#define stack_error(N) { \
+ pdftex_warn("CharString: invalid access (%i) to stack (%i entries)", \
+ (int) N, (int)(stack_ptr - cc_stack)); \
+ goto cs_error; \
+}
+
+/*
+static integer cc_get(integer index)
+{
+ if (index < 0) {
+ if (stack_ptr + index < cc_stack )
+ stack_error(stack_ptr - cc_stack + index);
+ return *(stack_ptr + index);
+ }
+ else {
+ if (cc_stack + index >= stack_ptr)
+ stack_error(index);
+ return cc_stack[index];
+ }
+}
+*/
+
+#define cc_get(N) ((N) < 0 ? *(stack_ptr + (N)) : *(cc_stack + (N)))
+
+#define cc_push(V) *stack_ptr++ = V
+#define cc_clear() stack_ptr = cc_stack
+
+#define set_cc(N, B, A, C) \
+ cc_tab[N].nargs = A; \
+ cc_tab[N].bottom = B; \
+ cc_tab[N].clear = C; \
+ cc_tab[N].valid = true
+
+static void cc_init (void)
+{
+ int i;
+ if (is_cc_init)
+ return;
+ for (i = 0; i < CS_MAX; i++)
+ cc_tab[i].valid = false;
+ set_cc (CS_HSTEM, true, 2, true);
+ set_cc (CS_VSTEM, true, 2, true);
+ set_cc (CS_VMOVETO, true, 1, true);
+ set_cc (CS_RLINETO, true, 2, true);
+ set_cc (CS_HLINETO, true, 1, true);
+ set_cc (CS_VLINETO, true, 1, true);
+ set_cc (CS_RRCURVETO, true, 6, true);
+ set_cc (CS_CLOSEPATH, false, 0, true);
+ set_cc (CS_CALLSUBR, false, 1, false);
+ set_cc (CS_RETURN, false, 0, false);
+ /*
+ set_cc(CS_ESCAPE, false, 0, false);
+ */
+ set_cc (CS_HSBW, true, 2, true);
+ set_cc (CS_ENDCHAR, false, 0, true);
+ set_cc (CS_RMOVETO, true, 2, true);
+ set_cc (CS_HMOVETO, true, 1, true);
+ set_cc (CS_VHCURVETO, true, 4, true);
+ set_cc (CS_HVCURVETO, true, 4, true);
+ set_cc (CS_DOTSECTION, false, 0, true);
+ set_cc (CS_VSTEM3, true, 6, true);
+ set_cc (CS_HSTEM3, true, 6, true);
+ set_cc (CS_SEAC, true, 5, true);
+ set_cc (CS_SBW, true, 4, true);
+ set_cc (CS_DIV, false, 2, false);
+ set_cc (CS_CALLOTHERSUBR, false, 0, false);
+ set_cc (CS_POP, false, 0, false);
+ set_cc (CS_SETCURRENTPOINT, true, 2, true);
+ is_cc_init = true;
+}
+
+#define cs_getchar() cdecrypt(*data++, &cr)
+
+#define mark_subr(n) cs_mark(0, n)
+#define mark_cs(s) cs_mark(s, 0)
+
+__attribute__ ((format (printf, 3, 4)))
+static void cs_warn (const char *cs_name, int subr, const char *fmt, ...)
+{
+ char buf[SMALL_BUF_SIZE];
+ va_list args;
+ va_start (args, fmt);
+ vsprintf (buf, fmt, args);
+ va_end (args);
+ if (cs_name == NULL)
+ pdftex_warn ("Subr (%i): %s", (int) subr, buf);
+ else
+ pdftex_warn ("CharString (/%s): %s", cs_name, buf);
+}
+
+static void cs_mark (const char *cs_name, int subr)
+{
+ byte *data;
+ int i, b, cs_len;
+ integer a, a1, a2;
+ unsigned short cr;
+ static integer lastargOtherSubr3 = 3; /* the argument of last call to
+ OtherSubrs[3] */
+ cs_entry *ptr;
+ cc_entry *cc;
+ if (cs_name == NULL) {
+ check_subr (subr);
+ ptr = subr_tab + subr;
+ if (!ptr->valid)
+ return;
+ } else {
+ if (cs_notdef != NULL &&
+ (cs_name == notdef || strcmp (cs_name, notdef) == 0))
+ ptr = cs_notdef;
+ else {
+ for (ptr = cs_tab; ptr < cs_ptr; ptr++)
+ if (strcmp (ptr->name, cs_name) == 0)
+ break;
+ if (ptr == cs_ptr) {
+ pdftex_warn ("glyph `%s' undefined", cs_name);
+ return;
+ }
+ if (ptr->name == notdef)
+ cs_notdef = ptr;
+ }
+ }
+ /* only marked CharString entries and invalid entries can be skipped;
+ valid marked subrs must be parsed to keep the stack in sync */
+ if (!ptr->valid || (ptr->used && cs_name != NULL))
+ return;
+ ptr->used = true;
+ cr = 4330;
+ cs_len = ptr->cslen;
+ data = ptr->data + 4;
+ for (i = 0; i < t1_lenIV; i++, cs_len--)
+ cs_getchar ();
+ while (cs_len > 0) {
+ --cs_len;
+ b = cs_getchar ();
+ if (b >= 32) {
+ if (b <= 246)
+ a = b - 139;
+ else if (b <= 250) {
+ --cs_len;
+ a = ((b - 247) << 8) + 108 + cs_getchar ();
+ } else if (b <= 254) {
+ --cs_len;
+ a = -((b - 251) << 8) - 108 - cs_getchar ();
+ } else {
+ cs_len -= 4;
+ a = (cs_getchar () & 0xff) << 24;
+ a |= (cs_getchar () & 0xff) << 16;
+ a |= (cs_getchar () & 0xff) << 8;
+ a |= (cs_getchar () & 0xff) << 0;
+ if (sizeof (integer) > 4 && (a & 0x80000000))
+ a |= ~0x7FFFFFFF;
+ }
+ cc_push (a);
+ } else {
+ if (b == CS_ESCAPE) {
+ b = cs_getchar () + CS_1BYTE_MAX;
+ cs_len--;
+ }
+ if (b >= CS_MAX) {
+ cs_warn (cs_name, subr, "command value out of range: %i",
+ (int) b);
+ goto cs_error;
+ }
+ cc = cc_tab + b;
+ if (!cc->valid) {
+ cs_warn (cs_name, subr, "command not valid: %i", (int) b);
+ goto cs_error;
+ }
+ if (cc->bottom) {
+ if (stack_ptr - cc_stack < cc->nargs)
+ cs_warn (cs_name, subr,
+ "less arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ else if (stack_ptr - cc_stack > cc->nargs)
+ cs_warn (cs_name, subr,
+ "more arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ }
+ switch (cc - cc_tab) {
+ case CS_CALLSUBR:
+ a1 = cc_get (-1);
+ cc_pop (1);
+ mark_subr (a1);
+ if (!subr_tab[a1].valid) {
+ cs_warn (cs_name, subr, "cannot call subr (%i)", (int) a1);
+ goto cs_error;
+ }
+ break;
+ case CS_DIV:
+ cc_pop (2);
+ cc_push (0);
+ break;
+ case CS_CALLOTHERSUBR:
+ if (cc_get (-1) == 3)
+ lastargOtherSubr3 = cc_get (-3);
+ a1 = cc_get (-2) + 2;
+ cc_pop (a1);
+ break;
+ case CS_POP:
+ cc_push (lastargOtherSubr3);
+ /* the only case when we care about the value being pushed onto
+ stack is when POP follows CALLOTHERSUBR (changing hints by
+ OtherSubrs[3])
+ */
+ break;
+ case CS_SEAC:
+ a1 = cc_get (3);
+ a2 = cc_get (4);
+ cc_clear ();
+ mark_cs (standard_glyph_names[a1]);
+ mark_cs (standard_glyph_names[a2]);
+ break;
+ default:
+ if (cc->clear)
+ cc_clear ();
+ }
+ }
+ }
+ return;
+ cs_error: /* an error occured during parsing */
+ cc_clear ();
+ ptr->valid = false;
+ ptr->used = false;
+}
+
+/**********************************************************************/
+/* AVL search tree for glyph code by glyph name */
+
+static int comp_t1_glyphs(const void *pa, const void *pb, void *p)
+{
+ return strcmp(*((const char **) pa), *((const char **) pb));
+}
+
+struct avl_table *create_t1_glyph_tree(char **glyph_names)
+{
+ int i;
+ void **aa;
+ static struct avl_table *gl_tree;
+ gl_tree = avl_create(comp_t1_glyphs, NULL, &avl_xallocator);
+ assert(gl_tree != NULL);
+ for (i = 0; i < 256; i++) {
+ if (glyph_names[i] != notdef &&
+ (char **) avl_find(gl_tree, &glyph_names[i]) == NULL) {
+ /* no strdup here, just point to the glyph_names array members */
+ aa = avl_probe(gl_tree, &glyph_names[i]);
+ assert(aa != NULL);
+ }
+ }
+ return gl_tree;
+}
+
+void destroy_t1_glyph_tree(struct avl_table *gl_tree)
+{
+ assert(gl_tree != NULL);
+ avl_destroy(gl_tree, NULL);
+}
+
+/**********************************************************************/
+
+static void t1_subset_ascii_part(void)
+{
+ int j, *p;
+ char *glyph, **gg, **glyph_names;
+ struct avl_table *gl_tree;
+ struct avl_traverser t;
+ void **aa;
+ assert(fd_cur != NULL);
+ assert(fd_cur->gl_tree != NULL);
+ t1_getline();
+ while (!t1_prefix("/Encoding")) {
+ t1_scan_param();
+ t1_putline();
+ t1_getline();
+ }
+ glyph_names = t1_builtin_enc();
+ fd_cur->builtin_glyph_names = glyph_names;
+ if (is_subsetted(fd_cur->fm)) {
+ assert(is_included(fd_cur->fm));
+ if (fd_cur->tx_tree != NULL) {
+ /* take over collected non-reencoded characters from TeX */
+ avl_t_init(&t, fd_cur->tx_tree);
+ for (p = (int *) avl_t_first(&t, fd_cur->tx_tree); p != NULL;
+ p = (int *) avl_t_next(&t)) {
+ if ((char *) avl_find(fd_cur->gl_tree, glyph_names[*p]) == NULL) {
+ glyph = xstrdup(glyph_names[*p]);
+ aa = avl_probe(fd_cur->gl_tree, glyph);
+ assert(aa != NULL);
+ }
+ }
+ }
+ make_subset_tag(fd_cur);
+ assert(t1_fontname_offset != 0);
+ strncpy(fb_array + t1_fontname_offset, fd_cur->subset_tag, 6);
+ }
+ /* now really all glyphs needed from this font are in the fd_cur->gl_tree */
+ if (t1_encoding == ENC_STANDARD)
+ t1_puts("/Encoding StandardEncoding def\n");
+ else {
+ t1_puts
+ ("/Encoding 256 array\n0 1 255 {1 index exch /.notdef put} for\n");
+ gl_tree = create_t1_glyph_tree(glyph_names);
+ avl_t_init(&t, fd_cur->gl_tree);
+ j = 0;
+ for (glyph = (char *) avl_t_first(&t, fd_cur->gl_tree); glyph != NULL;
+ glyph = (char *) avl_t_next(&t)) {
+ if ((gg = (char **) avl_find(gl_tree, &glyph)) != NULL) {
+ t1_printf("dup %i /%s put\n", (int) (gg - glyph_names), *gg);
+ j++;
+ }
+ }
+ destroy_t1_glyph_tree(gl_tree);
+ if (j == 0)
+ /* We didn't mark anything for the Encoding array. */
+ /* We add "dup 0 /.notdef put" for compatibility */
+ /* with Acrobat 5.0. */
+ t1_puts("dup 0 /.notdef put\n");
+ t1_puts("readonly def\n");
+ }
+ do {
+ t1_getline();
+ t1_scan_param();
+ if (!t1_prefix("/UniqueID")) /* ignore UniqueID for subsetted fonts */
+ t1_putline();
+ }
+ while (t1_in_eexec == 0);
+}
+
+
+static void cs_init (void)
+{
+ cs_ptr = cs_tab = NULL;
+ cs_dict_start = cs_dict_end = NULL;
+ cs_counter = cs_size = cs_size_pos = 0;
+ cs_token_pair = NULL;
+ subr_tab = NULL;
+ subr_array_start = subr_array_end = NULL;
+ subr_max = subr_size = subr_size_pos = 0;
+}
+
+static void init_cs_entry (cs_entry * cs)
+{
+ cs->data = NULL;
+ cs->name = NULL;
+ cs->len = 0;
+ cs->cslen = 0;
+ cs->used = false;
+ cs->valid = false;
+}
+
+static void t1_read_subrs (void)
+{
+ int i, s;
+ cs_entry *ptr;
+ t1_getline ();
+ while (!(t1_charstrings () || t1_subrs ())) {
+ t1_scan_param ();
+ t1_putline ();
+ t1_getline ();
+ }
+ found:
+ t1_cs = true;
+ t1_scan = false;
+ if (!t1_subrs ())
+ return;
+ subr_size_pos = strlen ("/Subrs") + 1;
+ /* subr_size_pos points to the number indicating dict size after "/Subrs" */
+ subr_size = t1_scan_num (t1_line_array + subr_size_pos, 0);
+ if (subr_size == 0) {
+ while (!t1_charstrings ())
+ t1_getline ();
+ return;
+ }
+ subr_tab = xtalloc (subr_size, cs_entry);
+ for (ptr = subr_tab; ptr - subr_tab < subr_size; ptr++)
+ init_cs_entry (ptr);
+ subr_array_start = xstrdup (t1_line_array);
+ t1_getline ();
+ while (t1_cslen) {
+ store_subr ();
+ t1_getline ();
+ }
+ /* mark the first four entries without parsing */
+ for (i = 0; i < subr_size && i < 4; i++)
+ subr_tab[i].used = true;
+ /* the end of the Subrs array might have more than one line so we need to
+ concatnate them to subr_array_end. Unfortunately some fonts don't have
+ the Subrs array followed by the CharStrings dict immediately (synthetic
+ fonts). If we cannot find CharStrings in next POST_SUBRS_SCAN lines then
+ we will treat the font as synthetic and ignore everything until next
+ Subrs is found
+ */
+#define POST_SUBRS_SCAN 5
+ s = 0;
+ *t1_buf_array = 0;
+ for (i = 0; i < POST_SUBRS_SCAN; i++) {
+ if (t1_charstrings ())
+ break;
+ s += t1_line_ptr - t1_line_array;
+ alloc_array (t1_buf, s, T1_BUF_SIZE);
+ strcat (t1_buf_array, t1_line_array);
+ t1_getline ();
+ }
+ subr_array_end = xstrdup (t1_buf_array);
+ if (i == POST_SUBRS_SCAN) { /* CharStrings not found;
+ suppose synthetic font */
+ for (ptr = subr_tab; ptr - subr_tab < subr_size; ptr++)
+ if (ptr->valid)
+ xfree (ptr->data);
+ xfree (subr_tab);
+ xfree (subr_array_start);
+ xfree (subr_array_end);
+ cs_init ();
+ t1_cs = false;
+ t1_synthetic = true;
+ while (!(t1_charstrings () || t1_subrs ()))
+ t1_getline ();
+ goto found;
+ }
+}
+
+#define t1_subr_flush() t1_flush_cs(true)
+#define t1_cs_flush() t1_flush_cs(false)
+
+static void t1_flush_cs (boolean is_subr)
+{
+ char *p;
+ byte *r, *return_cs = NULL;
+ cs_entry *tab, *end_tab, *ptr;
+ char *start_line, *line_end;
+ int count, size_pos;
+ unsigned short cr, cs_len;
+ if (is_subr) {
+ start_line = subr_array_start;
+ line_end = subr_array_end;
+ size_pos = subr_size_pos;
+ tab = subr_tab;
+ count = subr_max + 1;
+ end_tab = subr_tab + count;
+ } else {
+ start_line = cs_dict_start;
+ line_end = cs_dict_end;
+ size_pos = cs_size_pos;
+ tab = cs_tab;
+ end_tab = cs_ptr;
+ count = cs_counter;
+ }
+ t1_line_ptr = t1_line_array;
+ for (p = start_line; p - start_line < size_pos;)
+ *t1_line_ptr++ = *p++;
+ while (isdigit (*p))
+ p++;
+ sprintf (t1_line_ptr, "%u", count);
+ strcat (t1_line_ptr, p);
+ t1_line_ptr = eol (t1_line_array);
+ t1_putline ();
+
+ cs_len = 0; /* for -Wall */
+ /* create return_cs to replace unsused subr's */
+ if (is_subr) {
+ cr = 4330;
+ cs_len = 0;
+ return_cs = xtalloc (t1_lenIV + 1, byte);
+ if (t1_lenIV > 0) {
+ for (cs_len = 0, r = return_cs; cs_len < t1_lenIV; cs_len++, r++)
+ *r = cencrypt (0x00, &cr);
+ *r = cencrypt (CS_RETURN, &cr);
+ } else {
+ *return_cs = CS_RETURN;
+ }
+ cs_len++;
+ }
+
+ for (ptr = tab; ptr < end_tab; ptr++) {
+ if (ptr->used) {
+ if (is_subr)
+ sprintf (t1_line_array, "dup %li %u", (long int)(ptr - tab), ptr->cslen);
+ else
+ sprintf (t1_line_array, "/%s %u", ptr->name, ptr->cslen);
+ p = strend (t1_line_array);
+ memcpy (p, ptr->data, ptr->len);
+ t1_line_ptr = p + ptr->len;
+ t1_putline ();
+ } else {
+ /* replace unsused subr's by return_cs */
+ if (is_subr) {
+ sprintf (t1_line_array, "dup %li %u%s ", (long int)(ptr - tab), cs_len,
+ cs_token_pair[0]);
+ p = strend (t1_line_array);
+ memcpy (p, return_cs, cs_len);
+ t1_line_ptr = p + cs_len;
+ t1_putline ();
+ sprintf (t1_line_array, " %s", cs_token_pair[1]);
+ t1_line_ptr = eol (t1_line_array);
+ t1_putline ();
+ }
+ }
+ xfree (ptr->data);
+ if (ptr->name != notdef)
+ xfree (ptr->name);
+ }
+ sprintf (t1_line_array, "%s", line_end);
+ t1_line_ptr = eol (t1_line_array);
+ t1_putline ();
+ if (is_subr)
+ xfree (return_cs);
+ xfree (tab);
+ xfree (start_line);
+ xfree (line_end);
+}
+
+static void t1_mark_glyphs(void)
+{
+ char *glyph;
+ struct avl_traverser t;
+ cs_entry *ptr;
+ if (t1_synthetic || fd_cur->all_glyphs) { /* mark everything */
+ if (cs_tab != NULL)
+ for (ptr = cs_tab; ptr < cs_ptr; ptr++)
+ if (ptr->valid)
+ ptr->used = true;
+ if (subr_tab != NULL) {
+ for (ptr = subr_tab; ptr - subr_tab < subr_size; ptr++)
+ if (ptr->valid)
+ ptr->used = true;
+ subr_max = subr_size - 1;
+ }
+ return;
+ }
+ mark_cs(notdef);
+ avl_t_init(&t, fd_cur->gl_tree);
+ for (glyph = (char *) avl_t_first(&t, fd_cur->gl_tree); glyph != NULL;
+ glyph = (char *) avl_t_next(&t)) {
+ mark_cs(glyph);
+ }
+ if (subr_tab != NULL)
+ for (subr_max = -1, ptr = subr_tab; ptr - subr_tab < subr_size; ptr++)
+ if (ptr->used && ptr - subr_tab > subr_max)
+ subr_max = ptr - subr_tab;
+}
+
+
+static void t1_subset_charstrings (void)
+{
+ cs_entry *ptr;
+ cs_size_pos =
+ strstr (t1_line_array, charstringname) + strlen (charstringname)
+ - t1_line_array + 1;
+ /* cs_size_pos points to the number indicating
+ dict size after "/CharStrings" */
+ cs_size = t1_scan_num (t1_line_array + cs_size_pos, 0);
+ cs_ptr = cs_tab = xtalloc (cs_size, cs_entry);
+ for (ptr = cs_tab; ptr - cs_tab < cs_size; ptr++)
+ init_cs_entry (ptr);
+ cs_notdef = NULL;
+ cs_dict_start = xstrdup (t1_line_array);
+ t1_getline ();
+ while (t1_cslen) {
+ store_cs ();
+ t1_getline ();
+ }
+ cs_dict_end = xstrdup (t1_line_array);
+ t1_mark_glyphs ();
+ if (subr_tab != NULL) {
+ if (cs_token_pair == NULL)
+ pdftex_fail
+ ("This Type 1 font uses mismatched subroutine begin/end token pairs.");
+ t1_subr_flush ();
+ }
+ for (cs_counter = 0, ptr = cs_tab; ptr < cs_ptr; ptr++)
+ if (ptr->used)
+ cs_counter++;
+ t1_cs_flush ();
+}
+
+static void t1_subset_end (void)
+{
+ if (t1_synthetic) { /* copy to "dup /FontName get exch definefont pop" */
+ while (!strstr (t1_line_array, "definefont")) {
+ t1_getline ();
+ t1_putline ();
+ }
+ while (!t1_end_eexec ())
+ t1_getline (); /* ignore the rest */
+ t1_putline (); /* write "mark currentfile closefile" */
+ } else
+ while (!t1_end_eexec ()) { /* copy to "mark currentfile closefile" */
+ t1_getline ();
+ t1_putline ();
+ }
+ t1_stop_eexec ();
+ if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
+ while (!t1_cleartomark ()) {
+ t1_getline ();
+ t1_putline ();
+ }
+ if (!t1_synthetic) /* don't check "{restore}if" for synthetic fonts */
+ t1_check_end (); /* write "{restore}if" if found */
+ }
+ get_length3 ();
+}
+
+void writet1(fd_entry * fd)
+{
+ fd_cur = fd; /* fd_cur is global inside writet1.c */
+ assert(fd_cur->fm != NULL);
+ assert(is_type1(fd->fm));
+ assert(is_included(fd->fm));
+
+ t1_save_offset = 0;
+ if (!is_subsetted(fd_cur->fm)) { /* include entire font */
+ if (!(fd->ff_found = t1_open_fontfile("<<")))
+ return;
+ t1_include ();
+ t1_close_font_file (">>");
+ return;
+ }
+ /* partial downloading */
+ if (!(fd->ff_found = t1_open_fontfile("<")))
+ return;
+ t1_subset_ascii_part ();
+ t1_start_eexec ();
+ cc_init ();
+ cs_init ();
+ t1_read_subrs ();
+ t1_subset_charstrings ();
+ t1_subset_end ();
+ t1_close_font_file (">");
+}
+
+void t1_free ()
+{
+ xfree (t1_line_array);
+ xfree (t1_buf_array);
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/font/writet3.c b/Build/source/texk/web2c/luatexdir/font/writet3.c
new file mode 100644
index 00000000000..42827d1b124
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writet3.c
@@ -0,0 +1,348 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writet3.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+#include <kpathsea/tex-glyph.h>
+#include <kpathsea/magstep.h>
+#include <string.h>
+
+#define T3_BUF_SIZE 1024
+
+typedef char t3_line_entry;
+define_array (t3_line);
+
+FILE *t3_file;
+static boolean t3_image_used;
+
+static integer t3_char_procs[256];
+static float t3_char_widths[256];
+static int t3_glyph_num;
+static float t3_font_scale;
+static integer t3_b0, t3_b1, t3_b2, t3_b3;
+static boolean is_pk_font;
+
+static unsigned char *t3_buffer = NULL;
+static integer t3_size = 0;
+static integer t3_curbyte = 0;
+
+
+#define t3_open() \
+ open_input(&t3_file, kpse_miscfonts_format, FOPEN_RBIN_MODE)
+#define t3_read_file() readbinfile(t3_file,&t3_buffer,&t3_size)
+#define t3_close() xfclose(t3_file, cur_file_name)
+#define t3_getchar() t3_buffer[t3_curbyte++]
+#define t3_eof() (t3_curbyte>t3_size)
+
+#define t3_prefix(s) (!strncmp(t3_line_array, s, strlen(s)))
+#define t3_putchar(c) pdfout(c)
+
+
+
+#define t3_check_eof() \
+ if (t3_eof()) \
+ pdftex_fail("unexpected end of file");
+
+
+static void update_bbox (integer llx, integer lly, integer urx, integer ury,
+ boolean is_first_glyph)
+{
+ if (is_first_glyph) {
+ t3_b0 = llx;
+ t3_b1 = lly;
+ t3_b2 = urx;
+ t3_b3 = ury;
+ } else {
+ if (llx < t3_b0)
+ t3_b0 = llx;
+ if (lly < t3_b1)
+ t3_b1 = lly;
+ if (urx > t3_b2)
+ t3_b2 = urx;
+ if (ury > t3_b3)
+ t3_b3 = ury;
+ }
+}
+
+static integer get_pk_font_scale (internalfontnumber f)
+{
+ return
+ divide_scaled (pk_scale_factor,
+ divide_scaled (pdf_font_size(f), one_hundred_bp,
+ fixed_decimal_digits + 2), 0);
+}
+
+static integer pk_char_width (internalfontnumber f, scaled w)
+{
+ return
+ divide_scaled (divide_scaled (w, pdf_font_size(f), 7),
+ get_pk_font_scale (f), 0);
+}
+
+scaled get_pk_char_width (internalfontnumber f, scaled w)
+{
+ return (get_pk_font_scale (f) / 100000.0) *
+ (pk_char_width (f, w) / 100.0) * pdf_font_size(f);
+}
+
+static boolean writepk (internalfontnumber f)
+{
+ kpse_glyph_file_type font_ret;
+ integer llx, lly, urx, ury;
+ integer cw, rw, i, j;
+ halfword *row;
+ char *name;
+ char *ftemp = NULL;
+ chardesc cd;
+ boolean is_null_glyph, check_preamble;
+ integer dpi;
+ int callback_id=0;
+ int file_opened=0;
+ int mallocsize=0;
+ if (t3_buffer!=NULL) {
+ xfree(t3_buffer);
+ t3_buffer=NULL;
+ }
+ t3_curbyte=0;
+ t3_size=0;
+
+ callback_id=callback_defined(find_pk_file_callback);
+
+ if (callback_id>0) {
+ dpi = round (fixed_pk_resolution *
+ (((float) pdf_font_size(f)) / font_dsize(f)));
+ /* <base>.dpi/<fontname>.<tdpi>pk */
+ cur_file_name = font_name(f);
+ mallocsize = strlen(cur_file_name)+24+9;
+ name = xmalloc(mallocsize);
+ snprintf(name,mallocsize,"%ddpi/%s.%dpk",(int)fixed_pk_resolution,cur_file_name,(int)dpi);
+ if(run_callback(callback_id,"S->S",name,&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(name);
+ name = xstrdup(ftemp);
+ free(ftemp);
+ }
+ }
+ } else {
+ dpi =
+ kpse_magstep_fix (round
+ (fixed_pk_resolution *
+ (((float) pdf_font_size(f)) / font_dsize(f))),
+ fixed_pk_resolution, NULL);
+ cur_file_name = font_name(f);
+ name = kpse_find_pk (cur_file_name, (unsigned) dpi, &font_ret);
+ if (name == NULL ||
+ !FILESTRCASEEQ (cur_file_name, font_ret.name) ||
+ !kpse_bitmap_tolerance ((float) font_ret.dpi, (float) dpi)) {
+ pdftex_warn ("Font %s at %i not found", cur_file_name, (int) dpi);
+ cur_file_name = NULL;
+ return false;
+ }
+ }
+ callback_id=callback_defined(read_pk_file_callback);
+ if (callback_id>0) {
+ if(! ( run_callback(callback_id,"S->bSd",name, &file_opened, &t3_buffer,&t3_size) &&
+ file_opened &&
+ t3_size>0 ) ) {
+ pdftex_warn ("Font %s at %i not found", cur_file_name, (int)dpi);
+ cur_file_name = NULL;
+ return false;
+ }
+ } else {
+ t3_file = xfopen (name, FOPEN_RBIN_MODE);
+ t3_read_file();
+ t3_close();
+ }
+ t3_image_used = true;
+ is_pk_font = true;
+ if (tracefilenames)
+ tex_printf (" <%s", (char *) name);
+ cd.rastersize = 256;
+ cd.raster = xtalloc (cd.rastersize, halfword);
+ check_preamble = true;
+ while (readchar (check_preamble, &cd) != 0) {
+ check_preamble = false;
+ if (!pdf_char_marked (f, cd.charcode))
+ continue;
+ t3_char_widths[cd.charcode] =
+ pk_char_width (f, get_charwidth (f, cd.charcode));
+ if (cd.cwidth < 1 || cd.cheight < 1) {
+ cd.xescape = cd.cwidth =
+ round (t3_char_widths[cd.charcode] / 100.0);
+ cd.cheight = 1;
+ cd.xoff = 0;
+ cd.yoff = 0;
+ is_null_glyph = true;
+ } else
+ is_null_glyph = false;
+ llx = -cd.xoff;
+ lly = cd.yoff - cd.cheight + 1;
+ urx = cd.cwidth + llx + 1;
+ ury = cd.cheight + lly;
+ update_bbox (llx, lly, urx, ury, t3_glyph_num == 0);
+ t3_glyph_num++;
+ pdf_new_dict (0, 0, 0);
+ t3_char_procs[cd.charcode] = obj_ptr;
+ pdf_begin_stream ();
+ pdf_print_real (t3_char_widths[cd.charcode], 2);
+ pdf_printf (" 0 %i %i %i %i d1\n",
+ (int) llx, (int) lly, (int) urx, (int) ury);
+ if (is_null_glyph)
+ goto end_stream;
+ pdf_printf ("q\n%i 0 0 %i %i %i cm\nBI\n", (int) cd.cwidth,
+ (int) cd.cheight, (int) llx, (int) lly);
+ pdf_printf ("/W %i\n/H %i\n", (int) cd.cwidth, (int) cd.cheight);
+ pdf_puts ("/IM true\n/BPC 1\n/D [1 0]\nID ");
+ cw = (cd.cwidth + 7) / 8;
+ rw = (cd.cwidth + 15) / 16;
+ row = cd.raster;
+ for (i = 0; i < cd.cheight; i++) {
+ for (j = 0; j < rw - 1; j++) {
+ pdfout (*row / 256);
+ pdfout (*row % 256);
+ row++;
+ }
+ pdfout (*row / 256);
+ if (2 * rw == cw)
+ pdfout (*row % 256);
+ row++;
+ }
+ pdf_puts ("\nEI\nQ\n");
+ end_stream:
+ pdf_end_stream ();
+ }
+ xfree (cd.raster);
+ cur_file_name = NULL;
+ return true;
+}
+
+void writet3 (int objnum, internalfontnumber f)
+{
+
+ int i;
+ integer wptr, eptr, cptr;
+ int first_char, last_char;
+ integer pk_font_scale;
+ boolean is_notdef;
+
+
+ t3_glyph_num = 0;
+ t3_image_used = false;
+ for (i = 0; i < 256; i++) {
+ t3_char_procs[i] = 0;
+ t3_char_widths[i] = 0;
+ }
+ pack_file_name (tex_font_name(f), get_nullstr (), maketexlstring (".pgc",4));
+ cur_file_name = makecstring (make_name_string ());
+ is_pk_font = false;
+
+ if (t3_buffer!=NULL) {
+ xfree(t3_buffer);
+ t3_buffer=NULL;
+ }
+ t3_curbyte=0;
+ t3_size=0;
+ if (!writepk (f)) {
+ cur_file_name = NULL;
+ return;
+ }
+ for (i = font_bc(f); i <= font_ec(f); i++)
+ if (pdf_char_marked (f, i))
+ break;
+ first_char = i;
+ for (i = font_ec(f); i > first_char; i--)
+ if (pdf_char_marked (f, i))
+ break;
+ last_char = i;
+ pdf_begin_dict (objnum, 1); /* Type 3 font dictionary */
+ pdf_puts ("/Type /Font\n/Subtype /Type3\n");
+ pdf_printf ("/Name /F%i\n", (int) f);
+ if (pdf_font_attr(f) != get_nullstr ()) {
+ pdf_print (pdf_font_attr(f));
+ pdf_puts ("\n");
+ }
+ if (is_pk_font) {
+ pk_font_scale = get_pk_font_scale (f);
+ pdf_puts ("/FontMatrix [");
+ pdf_print_real (pk_font_scale, 5);
+ pdf_puts (" 0 0 ");
+ pdf_print_real (pk_font_scale, 5);
+ pdf_puts (" 0 0]\n");
+ } else
+ pdf_printf ("/FontMatrix [%g 0 0 %g 0 0]\n",
+ (double) t3_font_scale, (double) t3_font_scale);
+ pdf_printf ("/%s [ %i %i %i %i ]\n",
+ font_key[FONTBBOX1_CODE].pdfname,
+ (int) t3_b0, (int) t3_b1, (int) t3_b2, (int) t3_b3);
+ pdf_printf ("/Resources << /ProcSet [ /PDF %s] >>\n",
+ t3_image_used ? "/ImageB " : "");
+ pdf_printf ("/FirstChar %i\n/LastChar %i\n", first_char, last_char);
+ wptr = pdf_new_objnum ();
+ eptr = pdf_new_objnum ();
+ cptr = pdf_new_objnum ();
+ pdf_printf ("/Widths %i 0 R\n/Encoding %i 0 R\n/CharProcs %i 0 R\n",
+ (int)wptr, (int)eptr, (int)cptr);
+ pdf_end_dict ();
+ pdf_begin_obj (wptr, 1); /* chars width array */
+ pdf_puts ("[");
+ if (is_pk_font)
+ for (i = first_char; i <= last_char; i++) {
+ pdf_print_real (t3_char_widths[i], 2);
+ pdf_puts (" ");
+ } else
+ for (i = first_char; i <= last_char; i++)
+ pdf_printf ("%i ", (int) t3_char_widths[i]);
+ pdf_puts ("]\n");
+ pdf_end_obj ();
+ pdf_begin_dict (eptr, 1); /* encoding dictionary */
+ pdf_printf ("/Type /Encoding\n/Differences [%i", first_char);
+ if (t3_char_procs[first_char] == 0) {
+ pdf_printf ("/%s", notdef);
+ is_notdef = true;
+ } else {
+ pdf_printf ("/a%i", first_char);
+ is_notdef = false;
+ }
+ for (i = first_char + 1; i <= last_char; i++) {
+ if (t3_char_procs[i] == 0) {
+ if (!is_notdef) {
+ pdf_printf (" %i/%s", i, notdef);
+ is_notdef = true;
+ }
+ } else {
+ if (is_notdef) {
+ pdf_printf (" %i", i);
+ is_notdef = false;
+ }
+ pdf_printf ("/a%i", i);
+ }
+ }
+ pdf_puts ("]\n");
+ pdf_end_dict ();
+ pdf_begin_dict (cptr, 1); /* CharProcs dictionary */
+ for (i = first_char; i <= last_char; i++)
+ if (t3_char_procs[i] != 0)
+ pdf_printf ("/a%i %i 0 R\n", (int) i, (int) t3_char_procs[i]);
+ pdf_end_dict ();
+ if (tracefilenames)
+ tex_printf (">");
+ cur_file_name = NULL;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/writettf.c b/Build/source/texk/web2c/luatexdir/font/writettf.c
new file mode 100644
index 00000000000..2a92706a0de
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writettf.c
@@ -0,0 +1,1509 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writettf.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+#include "writettf.h"
+#include <string.h>
+
+#define DEFAULT_NTABS 14
+#define NEW_CMAP_SIZE 2
+
+#define ttf_putchar fb_putchar
+#define ttf_offset fb_offset
+#define ttf_seek_outbuf fb_seek
+
+ /* #define INFILE ttf_file*/
+
+unsigned char *ttf_buffer = NULL;
+integer ttf_size = 0;
+integer ttf_curbyte = 0;
+
+typedef struct {
+ char *name; /* name of glyph */
+ long code; /* charcode in case of subfonts */
+ short newindex; /* new index of glyph in output file */
+
+} ttfenc_entry;
+
+typedef struct {
+ TTF_USHORT platform_id;
+ TTF_USHORT encoding_id;
+ TTF_USHORT language_id;
+ TTF_USHORT name_id;
+ TTF_USHORT length;
+ TTF_USHORT offset;
+ TTF_USHORT new_offset;
+ TTF_USHORT new_length;
+} name_record;
+
+typedef struct {
+ char *ttf_name;
+ TTF_USHORT pid;
+ TTF_USHORT eid;
+ short *table;
+} ttf_cmap_entry;
+
+static TTF_USHORT ntabs;
+static TTF_USHORT upem;
+static TTF_FIXED post_format;
+static TTF_SHORT loca_format;
+static TTF_ULONG last_glyf_offset;
+static TTF_USHORT glyphs_count;
+static TTF_USHORT new_glyphs_count;
+static TTF_USHORT nhmtxs;
+static TTF_USHORT new_ntabs;
+
+glyph_entry *glyph_tab;
+dirtab_entry *dir_tab;
+
+static long *glyph_index;
+static cmap_entry *cmap_tab, new_cmap_tab[NEW_CMAP_SIZE];
+static name_record *name_tab;
+static int name_record_num;
+static char *name_buf;
+static int name_buf_size;
+static char *glyph_name_buf;
+static TTF_ULONG checksum;
+static TTF_ULONG tab_length;
+static TTF_ULONG tmp_ulong;
+static TTF_ULONG checkSumAdjustment_offset;
+FILE *ttf_file;
+static ttfenc_entry ttfenc_tab[256];
+
+fd_entry *fd_cur; /* pointer to the current font descriptor */
+
+static struct avl_table *ttf_cmap_tree = NULL;
+
+integer ttf_length;
+
+#include "macnames.c"
+
+extern char *fb_array;
+extern char charsetstr[];
+
+static const char *newtabnames[] = {
+ "OS/2",
+ "PCLT",
+ "cmap",
+ "cvt ",
+ "fpgm",
+ "glyf",
+ "head",
+ "hhea",
+ "hmtx",
+ "loca",
+ "maxp",
+ "name",
+ "post",
+ "prep"
+};
+
+ttf_cmap_entry *new_ttf_cmap_entry (void)
+{
+ ttf_cmap_entry *e;
+ e = xtalloc (1, ttf_cmap_entry);
+ e->ttf_name = NULL;
+ e->table = NULL;
+ return e;
+}
+
+static void destroy_ttf_cmap_entry (void *pa, void *pb)
+{
+ ttf_cmap_entry *p;
+ p = (ttf_cmap_entry *) pa;
+ xfree (p->ttf_name);
+ xfree (p->table);
+ xfree (p);
+}
+
+void ttf_free (void)
+{
+ if (ttf_cmap_tree != NULL)
+ avl_destroy (ttf_cmap_tree, destroy_ttf_cmap_entry);
+}
+
+static int comp_ttf_cmap_entry (const void *pa, const void *pb, void *p)
+{
+ const ttf_cmap_entry *p1 = (const ttf_cmap_entry *) pa,
+ *p2 = (const ttf_cmap_entry *) pb;
+ int i;
+ assert (p1->ttf_name != NULL && p2->ttf_name != NULL);
+ if ((i = strcmp (p1->ttf_name, p2->ttf_name)) != 0)
+ return i;
+ cmp_return (p1->pid, p2->pid);
+ cmp_return (p1->eid, p2->eid);
+ return 0;
+}
+
+static unsigned char ttf_addchksm (unsigned char b)
+{
+ tmp_ulong = (tmp_ulong << 8) + b;
+ tab_length++;
+ if (tab_length % 4 == 0) {
+ checksum += tmp_ulong;
+ tmp_ulong = 0;
+ }
+ return b;
+}
+
+static TTF_ULONG ttf_getchksm (void)
+{
+ while (tab_length % 4 != 0)
+ ttf_putchar (ttf_addchksm (0)); /* ttf_addchksm updates tab_length */
+ return checksum;
+}
+
+long ttf_putnum (int s, long n)
+{
+ long i = n;
+ char buf[TTF_LONG_SIZE + 1], *p = buf;
+ while (s-- > 0) {
+ *p++ = i & 0xFF;
+ i >>= 8;
+ }
+ p--;
+ while (p >= buf)
+ ttf_putchar (ttf_addchksm (*p--));
+ return n;
+}
+
+long ttf_getnum (int s)
+{
+ long i = 0;
+ int c;
+ while (s > 0) {
+ if (ttf_eof())
+ pdftex_fail ("unexpected EOF");
+ c = ttf_getchar ();
+ i = (i << 8) + c;
+ s--;
+ }
+ return i;
+}
+
+static long ttf_funit (long n)
+{
+ if (n < 0)
+ return -((-n / upem) * 1000 + ((-n % upem) * 1000) / upem);
+ else
+ return (n / upem) * 1000 + ((n % upem) * 1000) / upem;
+}
+
+static void ttf_ncopy (int n)
+{
+ while (n-- > 0)
+ copy_byte ();
+}
+
+dirtab_entry *ttf_name_lookup (const char *s, boolean required)
+{
+ dirtab_entry *tab;
+ for (tab = dir_tab; tab - dir_tab < ntabs; tab++)
+ if (strncmp (tab->tag, s, 4) == 0)
+ break;
+ if (tab - dir_tab == ntabs) {
+ if (required)
+ pdftex_fail ("can't find table `%s'", s);
+ else
+ tab = NULL;
+ }
+ return tab;
+}
+
+dirtab_entry *ttf_seek_tab (const char *name, TTF_LONG offset)
+{
+ dirtab_entry *tab = ttf_name_lookup (name, true);
+ /*xfseek (INFILE, tab->offset + offset, SEEK_SET, cur_file_name);*/
+ ttf_curbyte = tab->offset + offset;
+ return tab;
+}
+
+static void ttf_seek_off (TTF_LONG offset)
+{
+ ttf_curbyte = offset;
+ //xfseek (INFILE, offset, SEEK_SET, cur_file_name);
+}
+
+static void ttf_copy_encoding(void)
+{
+ int i, *q;
+ void **aa;
+ char **glyph_names;
+ long *charcodes;
+ static char buf[SMALL_BUF_SIZE];
+ struct avl_traverser t;
+ ttfenc_entry *e = ttfenc_tab;
+
+ assert(fd_cur->tx_tree != NULL); /* this must be set in create_fontdictionary */
+
+ if (fd_cur->fe != NULL) {
+ glyph_names = fd_cur->fe->glyph_names;
+ assert(glyph_names != NULL);
+
+ for (i = 0; i < 256; i++)
+ ttfenc_tab[i].name = (char *) notdef;
+
+ /* a workaround for a bug of AcroReader 4.0 */
+ if (strcmp(glyph_names[97], "a") == 0) {
+ q = xtalloc(1, int);
+ *q = 'a';
+ aa = avl_probe(fd_cur->tx_tree, q);
+ assert(aa != NULL);
+ }
+ /* end of workaround */
+
+ /* take over collected characters from TeX, reencode them */
+ avl_t_init(&t, fd_cur->tx_tree);
+ for (q = (int *) avl_t_first(&t, fd_cur->tx_tree); q != NULL;
+ q = (int *) avl_t_next(&t)) {
+ assert(*q >= 0 && *q < 256);
+ ttfenc_tab[*q].name = glyph_names[*q];
+ }
+ make_subset_tag(fd_cur);
+ } else if (is_subfont(fd_cur->fm)) {
+ charcodes = fd_cur->fm->subfont->charcodes;
+ assert(charcodes != NULL);
+
+ for (i = 0; i < 256; i++)
+ ttfenc_tab[i].code = -1;
+
+ /* take over collected characters from TeX */
+ avl_t_init(&t, fd_cur->tx_tree);
+ for (q = (int *) avl_t_first(&t, fd_cur->tx_tree); q != NULL;
+ q = (int *) avl_t_next(&t)) {
+ assert(*q >= 0 && *q < 256);
+ e = ttfenc_tab + *q;
+ e->code = charcodes[*q];
+ if (e->code == -1)
+ pdftex_warn("character %i is not mapped to any charcode", *q);
+ else {
+ assert(e->code < 0x10000);
+ sprintf(buf, "/c%4.4X", (int) e->code);
+ aa = avl_probe(fd_cur->gl_tree, xstrdup(buf));
+ assert(aa != NULL);
+ }
+ }
+ make_subset_tag(fd_cur);
+ } else
+ assert(0);
+}
+
+#define ttf_append_byte(B)\
+do {\
+ if (name_tab[i].platform_id == 3)\
+ *q++ = 0;\
+ *q++ = B;\
+} while (0)
+
+static char *strip_spaces_and_delims(char *s, int l)
+{
+ static char buf[SMALL_BUF_SIZE];
+ char *p = buf;
+ int i;
+
+ assert(l >= 0 && l < (int) sizeof(buf));
+
+ for (i = 0; i < l; s++, i++) {
+ if (*s == '(' || *s == ')' || *s == '<' || *s == '>' ||
+ *s == '[' || *s == ']' || *s == '{' || *s == '}' ||
+ *s == '/' || *s == '%' || isspace(*s))
+ continue;
+ *p++ = *s;
+ }
+ *p = 0;
+ return buf;
+}
+
+static void ttf_read_name (void)
+{
+ int i, j;
+ dirtab_entry *tab = ttf_seek_tab ("name", TTF_USHORT_SIZE);
+ char *p;
+ name_record_num = get_ushort ();
+ name_tab = xtalloc (name_record_num, name_record);
+ name_buf_size = tab->length -
+ (3 * TTF_USHORT_SIZE + name_record_num * 6 * TTF_USHORT_SIZE);
+ name_buf = xtalloc (name_buf_size, char);
+ ttf_skip (TTF_USHORT_SIZE);
+ for (i = 0; i < name_record_num; i++) {
+ name_tab[i].platform_id = get_ushort ();
+ name_tab[i].encoding_id = get_ushort ();
+ name_tab[i].language_id = get_ushort ();
+ name_tab[i].name_id = get_ushort ();
+ name_tab[i].length = get_ushort ();
+ name_tab[i].offset = get_ushort ();
+ }
+ for (p = name_buf; p - name_buf < name_buf_size; p++)
+ *p = get_char ();
+ /* look for PS font name */
+ for (i = 0; i < name_record_num; i++) {
+ if (name_tab[i].platform_id == 1 &&
+ name_tab[i].encoding_id == 0 && name_tab[i].name_id == 6) {
+ xfree(fd_cur->fontname);
+ fd_cur->fontname =
+ xstrdup(strip_spaces_and_delims(name_buf + name_tab[i].offset,
+ name_tab[i].length));
+ fd_cur->font_dim[FONTNAME_CODE].set = true;
+ break;
+ }
+ }
+ if (!fd_cur->font_dim[FONTNAME_CODE].set) {
+ for (i = 0; i < name_record_num; i++) {
+ if (name_tab[i].platform_id == 3 &&
+ (name_tab[i].encoding_id == 0 ||
+ name_tab[i].encoding_id == 1) && name_tab[i].name_id == 6) {
+ for (j = 0, p = fd_cur->fontname; j < name_tab[i].length;
+ j += 2)
+ *p++ = name_buf[name_tab[i].offset + j + 1];
+ *p = 0;
+ fd_cur->font_dim[FONTNAME_CODE].set = true;
+ break;
+ }
+ }
+ }
+}
+
+static void ttf_read_mapx (void)
+{
+ glyph_entry *glyph;
+ ttf_seek_tab ("maxp", TTF_FIXED_SIZE);
+ glyph_tab = xtalloc (1 + (glyphs_count = get_ushort ()), glyph_entry);
+ for (glyph = glyph_tab; glyph - glyph_tab < glyphs_count; glyph++) {
+ glyph->newindex = -1;
+ glyph->newoffset = 0;
+ glyph->name_index = 0;
+ glyph->name = (char *) notdef;
+ }
+ glyph_index = xtalloc (glyphs_count, long);
+ glyph_index[0] = 0; /* index of ".notdef" glyph */
+ glyph_index[1] = 1; /* index of ".null" glyph */
+}
+
+void ttf_read_head (void)
+{
+ ttf_seek_tab ("head",
+ 2 * TTF_FIXED_SIZE + 2 * TTF_ULONG_SIZE + TTF_USHORT_SIZE);
+ upem = get_ushort ();
+ ttf_skip (16);
+ fd_cur->font_dim[FONTBBOX1_CODE].val = ttf_funit(get_fword());
+ fd_cur->font_dim[FONTBBOX2_CODE].val = ttf_funit(get_fword());
+ fd_cur->font_dim[FONTBBOX3_CODE].val = ttf_funit(get_fword());
+ fd_cur->font_dim[FONTBBOX4_CODE].val = ttf_funit(get_fword());
+ fd_cur->font_dim[FONTBBOX1_CODE].set = true;
+ fd_cur->font_dim[FONTBBOX2_CODE].set = true;
+ fd_cur->font_dim[FONTBBOX3_CODE].set = true;
+ fd_cur->font_dim[FONTBBOX4_CODE].set = true;
+ ttf_skip (2 * TTF_USHORT_SIZE + TTF_SHORT_SIZE);
+ loca_format = get_short ();
+}
+
+void ttf_read_hhea (void)
+{
+ ttf_seek_tab ("hhea", TTF_FIXED_SIZE);
+ fd_cur->font_dim[ASCENT_CODE].val = ttf_funit(get_fword());
+ fd_cur->font_dim[DESCENT_CODE].val = ttf_funit(get_fword());
+ fd_cur->font_dim[ASCENT_CODE].set = true;
+ fd_cur->font_dim[DESCENT_CODE].set = true;
+ ttf_skip (TTF_FWORD_SIZE + TTF_UFWORD_SIZE + 3 * TTF_FWORD_SIZE +
+ 8 * TTF_SHORT_SIZE);
+ nhmtxs = get_ushort ();
+}
+
+void ttf_read_pclt (void)
+{
+ if (ttf_name_lookup ("PCLT", false) == NULL)
+ return;
+ ttf_seek_tab ("PCLT", TTF_FIXED_SIZE + TTF_ULONG_SIZE + TTF_USHORT_SIZE);
+ fd_cur->font_dim[XHEIGHT_CODE].val = ttf_funit(get_ushort());
+ ttf_skip(2 * TTF_USHORT_SIZE);
+ fd_cur->font_dim[CAPHEIGHT_CODE].val = ttf_funit(get_ushort());
+ fd_cur->font_dim[XHEIGHT_CODE].set = true;
+ fd_cur->font_dim[CAPHEIGHT_CODE].set = true;
+}
+
+static void ttf_read_hmtx (void)
+{
+ glyph_entry *glyph;
+ TTF_UFWORD last_advWidth;
+ ttf_seek_tab ("hmtx", 0);
+ for (glyph = glyph_tab; glyph - glyph_tab < nhmtxs; glyph++) {
+ glyph->advWidth = get_ufword ();
+ glyph->lsb = get_ufword ();
+ }
+ if (nhmtxs < glyphs_count) {
+ last_advWidth = glyph[-1].advWidth;
+ for (; glyph - glyph_tab < glyphs_count; glyph++) {
+ glyph->advWidth = last_advWidth;
+ glyph->lsb = get_ufword ();
+ }
+ }
+}
+
+void ttf_read_post (void)
+{
+ int k, nnames;
+ long length;
+ long int_part, frac_part;
+ int sign = 1;
+ TTF_FIXED italic_angle;
+ char *p;
+ glyph_entry *glyph;
+ const dirtab_entry *tab = ttf_seek_tab ("post", 0);
+ post_format = get_fixed ();
+ italic_angle = get_fixed ();
+ int_part = italic_angle >> 16;
+ if (int_part > 0x7FFF) { /* a negative number */
+ int_part = 0x10000 - int_part;
+ sign = -1;
+ }
+ frac_part = italic_angle % 0x10000;
+ fd_cur->font_dim[ITALIC_ANGLE_CODE].val =
+ sign * (int_part + frac_part * 1.0 / 0x10000);
+ fd_cur->font_dim[ITALIC_ANGLE_CODE].set = true;
+ if (glyph_tab == NULL)
+ return; /* being called from writeotf() */
+ ttf_skip (2 * TTF_FWORD_SIZE + 5 * TTF_ULONG_SIZE);
+ switch (post_format) {
+ case 0x10000:
+ for (glyph = glyph_tab; glyph - glyph_tab < NMACGLYPHS; glyph++) {
+ glyph->name = (char *) mac_glyph_names[glyph - glyph_tab];
+ glyph->name_index = glyph - glyph_tab;
+ }
+ break;
+ case 0x20000:
+ nnames = get_ushort (); /* some fonts have this value different from nglyphs */
+ for (glyph = glyph_tab; glyph - glyph_tab < nnames; glyph++)
+ glyph->name_index = get_ushort ();
+ /*length = tab->length - (xftell (INFILE, cur_file_name) - tab->offset);*/
+ length = tab->length - (ttf_curbyte - tab->offset);
+ glyph_name_buf = xtalloc (length, char);
+ for (p = glyph_name_buf; p - glyph_name_buf < length;) {
+ for (k = get_byte (); k > 0; k--)
+ *p++ = get_char ();
+ *p++ = 0;
+ }
+ for (glyph = glyph_tab; glyph - glyph_tab < nnames; glyph++) {
+ if (glyph->name_index < NMACGLYPHS)
+ glyph->name = (char *) mac_glyph_names[glyph->name_index];
+ else {
+ p = glyph_name_buf;
+ k = glyph->name_index - NMACGLYPHS;
+ for (; k > 0; k--)
+ p = strend (p) + 1;
+ glyph->name = p;
+ }
+ }
+ break;
+ case 0x00030000:
+ for (glyph = glyph_tab; glyph - glyph_tab < NMACGLYPHS; glyph++) {
+ glyph->name_index = glyph - glyph_tab;
+ }
+ break;
+ default:
+ pdftex_fail ("unsupported format (%.8X) of `post' table",
+ (unsigned int) post_format);
+ }
+}
+
+static void ttf_read_loca (void)
+{
+ glyph_entry *glyph;
+ ttf_seek_tab ("loca", 0);
+ if (loca_format != 0)
+ for (glyph = glyph_tab; glyph - glyph_tab < glyphs_count + 1; glyph++)
+ glyph->offset = get_ulong ();
+ else
+ for (glyph = glyph_tab; glyph - glyph_tab < glyphs_count + 1; glyph++)
+ glyph->offset = get_ushort () << 1;
+}
+
+void ttf_read_tabdir (void)
+{
+ int i;
+ dirtab_entry *tab;
+ ttf_skip (TTF_FIXED_SIZE); /* ignore the sfnt number */
+ dir_tab = xtalloc (ntabs = get_ushort (), dirtab_entry);
+ ttf_skip (3 * TTF_USHORT_SIZE);
+ for (tab = dir_tab; tab - dir_tab < ntabs; tab++) {
+ for (i = 0; i < 4; i++)
+ tab->tag[i] = get_char ();
+ tab->checksum = get_ulong ();
+ tab->offset = get_ulong ();
+ tab->length = get_ulong ();
+ }
+}
+
+static ttf_cmap_entry *ttf_read_cmap (char *ttf_name, int pid, int eid,
+ boolean warn)
+{
+ seg_entry *seg_tab, *s;
+ TTF_USHORT *glyphId, format, segCount;
+ TTF_USHORT ncmapsubtabs, tmp_pid, tmp_eid;
+ TTF_ULONG cmap_offset, tmp_offset;
+ long n, i, k, length, index;
+ ttf_cmap_entry tmp_e, *p;
+ void **aa;
+
+ /* loop up in ttf_cmap_tree first, return if found */
+ tmp_e.ttf_name = ttf_name;
+ tmp_e.pid = pid;
+ tmp_e.eid = eid;
+ if (ttf_cmap_tree == NULL) {
+ ttf_cmap_tree = avl_create (comp_ttf_cmap_entry, NULL, &avl_xallocator);
+ assert (ttf_cmap_tree != NULL);
+ }
+ p = (ttf_cmap_entry *) avl_find (ttf_cmap_tree, &tmp_e);
+ if (p != NULL)
+ return p;
+
+ /* not found, have to read it */
+ ttf_seek_tab ("cmap", TTF_USHORT_SIZE); /* skip the table vesrion number (=0) */
+ ncmapsubtabs = get_ushort ();
+ /* cmap_offset = xftell (INFILE, cur_file_name) - 2 * TTF_USHORT_SIZE;*/
+ cmap_offset = ttf_curbyte - 2 * TTF_USHORT_SIZE;
+ cmap_tab = xtalloc (ncmapsubtabs, cmap_entry);
+ for (i = 0; i < ncmapsubtabs; ++i) {
+ tmp_pid = get_ushort ();
+ tmp_eid = get_ushort ();
+ tmp_offset = get_ulong ();
+ if (tmp_pid == pid && tmp_eid == eid) {
+ ttf_seek_off (cmap_offset + tmp_offset);
+ format = get_ushort ();
+ if (format == 4)
+ goto read_cmap_format_4;
+ else {
+ if (warn)
+ pdftex_warn ("cmap format %i unsupported", format);
+ return NULL;
+ }
+ }
+ }
+ if (warn)
+ pdftex_warn ("cannot find cmap subtable for (pid,eid) = (%i, %i)",
+ pid, eid);
+ return NULL;
+ read_cmap_format_4:
+ /* initialize the new entry */
+ p = new_ttf_cmap_entry ();
+ p->ttf_name = xstrdup (ttf_name);
+ p->pid = pid;
+ p->eid = eid;
+ p->table = xtalloc (0x10000, short);
+ for (i = 0; i < 0x10000; ++i)
+ p->table[i] = -1; /* unassigned yet */
+
+ /* read the subtable */
+ length = get_ushort (); /* length of subtable */
+ (void) get_ushort (); /* skip the version number */
+ segCount = get_ushort () / 2;
+ (void) get_ushort (); /* skip searchRange */
+ (void) get_ushort (); /* skip entrySelector */
+ (void) get_ushort (); /* skip rangeShift */
+ seg_tab = xtalloc (segCount, seg_entry);
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->endCode = get_ushort ();
+ (void) get_ushort (); /* skip reversedPad */
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->startCode = get_ushort ();
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->idDelta = get_ushort ();
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->idRangeOffset = get_ushort ();
+ length -= 8 * TTF_USHORT_SIZE + 4 * segCount * TTF_USHORT_SIZE;
+ n = length / TTF_USHORT_SIZE; /* number of glyphID's */
+ glyphId = xtalloc (n, TTF_USHORT);
+ for (i = 0; i < n; i++)
+ glyphId[i] = get_ushort ();
+ for (s = seg_tab; s - seg_tab < segCount; s++) {
+ for (i = s->startCode; i <= s->endCode; i++) {
+ if (i == 0xFFFF)
+ break;
+ if (s->idRangeOffset != 0xFFFF) {
+ if (s->idRangeOffset == 0)
+ index = (s->idDelta + i) & 0xFFFF;
+ else {
+ k = (i - s->startCode) + s->idRangeOffset / 2 +
+ (s - seg_tab) - segCount;
+ assert (k >= 0 && k < n);
+ index = glyphId[k];
+ if (index != 0)
+ index = (index + s->idDelta) & 0xFFFF;
+ }
+ if (index >= glyphs_count)
+ pdftex_fail ("cmap: glyph index %li out of range [0..%i)",
+ index, glyphs_count);
+ if (p->table[i] != -1)
+ pdftex_warn
+ ("cmap: multiple glyphs are mapped to unicode %.4lX, "
+ "only %i will be used (glyph %li being ignored)", i,
+ p->table[i], index);
+ else
+ p->table[i] = index;
+ }
+ }
+ }
+ xfree (seg_tab);
+ xfree (glyphId);
+ aa = avl_probe (ttf_cmap_tree, p);
+ assert (aa != NULL);
+ return p;
+}
+
+static void ttf_read_font (void)
+{
+ ttf_read_tabdir ();
+ if (ttf_name_lookup ("PCLT", false) == NULL)
+ new_ntabs--;
+ if (ttf_name_lookup ("fpgm", false) == NULL)
+ new_ntabs--;
+ if (ttf_name_lookup ("cvt ", false) == NULL)
+ new_ntabs--;
+ if (ttf_name_lookup ("prep", false) == NULL)
+ new_ntabs--;
+ ttf_read_mapx ();
+ ttf_read_head ();
+ ttf_read_hhea ();
+ ttf_read_pclt ();
+ ttf_read_hmtx ();
+ ttf_read_post ();
+ ttf_read_loca ();
+ ttf_read_name ();
+}
+
+static void ttf_reset_chksm (dirtab_entry * tab)
+{
+ checksum = 0;
+ tab_length = 0;
+ tmp_ulong = 0;
+ tab->offset = ttf_offset ();
+ if (tab->offset % 4 != 0)
+ pdftex_warn ("offset of `%4.4s' is not a multiple of 4", tab->tag);
+}
+
+
+static void ttf_set_chksm (dirtab_entry * tab)
+{
+ tab->length = ttf_offset () - tab->offset;
+ tab->checksum = ttf_getchksm ();
+}
+
+static void ttf_copytab (const char *name)
+{
+ long i;
+ dirtab_entry *tab = ttf_seek_tab (name, 0);
+ ttf_reset_chksm (tab);
+ for (i = tab->length; i > 0; i--)
+ copy_char ();
+ ttf_set_chksm (tab);
+}
+
+#define BYTE_ENCODING_LENGTH \
+ ((256)*TTF_BYTE_SIZE + 3*TTF_USHORT_SIZE)
+
+static void ttf_byte_encoding (void)
+{
+ ttfenc_entry *e;
+ (void) put_ushort (0); /* format number (0: byte encoding table) */
+ (void) put_ushort (BYTE_ENCODING_LENGTH); /* length of table */
+ (void) put_ushort (0); /* version number */
+ for (e = ttfenc_tab; e - ttfenc_tab < 256; e++)
+ if (e->newindex < 256) {
+ put_byte (e->newindex);
+ } else {
+ if (e->name != notdef)
+ pdftex_warn
+ ("glyph `%s' has been mapped to `%s' in `ttf_byte_encoding' cmap table",
+ e->name, notdef);
+ put_byte (0); /* notdef */
+ }
+}
+
+#define TRIMMED_TABLE_MAP_LENGTH (TTF_USHORT_SIZE*(5 + (256)))
+
+static void ttf_trimmed_table_map (void)
+{
+ ttfenc_entry *e;
+ (void) put_ushort (6); /* format number (6): trimmed table mapping */
+ (void) put_ushort (TRIMMED_TABLE_MAP_LENGTH);
+ (void) put_ushort (0); /* version number (0) */
+ (void) put_ushort (0); /* first character code */
+ (void) put_ushort (256); /* number of character code in table */
+ for (e = ttfenc_tab; e - ttfenc_tab < 256; e++)
+ (void) put_ushort (e->newindex);
+}
+
+#define SEG_MAP_DELTA_LENGTH ((16 + (256))*TTF_USHORT_SIZE)
+
+static void ttf_seg_map_delta (void)
+{
+ ttfenc_entry *e;
+ (void) put_ushort (4); /* format number (4: segment mapping to delta values) */
+ (void) put_ushort (SEG_MAP_DELTA_LENGTH);
+ (void) put_ushort (0); /* version number */
+ (void) put_ushort (4); /* 2*segCount */
+ (void) put_ushort (4); /* searchRange */
+ (void) put_ushort (1); /* entrySelector */
+ (void) put_ushort (0); /* rangeShift */
+ (void) put_ushort (0xF0FF); /* endCount[0] */
+ (void) put_ushort (0xFFFF); /* endCount[1] */
+ (void) put_ushort (0); /* reversedPad */
+ (void) put_ushort (0xF000); /* startCount[0] */
+ (void) put_ushort (0xFFFF); /* startCount[1] */
+ (void) put_ushort (0); /* idDelta[0] */
+ (void) put_ushort (1); /* idDelta[1] */
+ (void) put_ushort (2 * TTF_USHORT_SIZE); /* idRangeOffset[0] */
+ (void) put_ushort (0); /* idRangeOffset[1] */
+ for (e = ttfenc_tab; e - ttfenc_tab < 256; e++)
+ (void) put_ushort (e->newindex);
+}
+
+#define CMAP_ENTRY_LENGTH (2*TTF_USHORT_SIZE + TTF_ULONG_SIZE)
+
+static void ttf_select_cmap (void)
+{
+ assert (sizeof (new_cmap_tab) <= NEW_CMAP_SIZE * sizeof (cmap_entry));
+ new_cmap_tab[0].platform_id = 1; /* Macintosh */
+ new_cmap_tab[0].encoding_id = 0; /* Symbol; ignore code page */
+ new_cmap_tab[0].format = new_glyphs_count < 256 ? 0 /* byte encoding */
+ : 6; /* trimmed table mapping */
+ new_cmap_tab[1].platform_id = 3; /* Microsoft */
+ new_cmap_tab[1].encoding_id = 0; /* Symbol; ignore code page */
+ new_cmap_tab[1].format = 4; /* segment mapping to delta */
+}
+
+static void ttf_write_cmap (void)
+{
+ cmap_entry *ce;
+ long offset;
+ dirtab_entry *tab = ttf_name_lookup ("cmap", true);
+ ttf_select_cmap ();
+ ttf_reset_chksm (tab);
+ (void) put_ushort (0); /* table version number (0) */
+ (void) put_ushort (NEW_CMAP_SIZE); /* number of encoding tables */
+ offset = 2 * TTF_USHORT_SIZE + NEW_CMAP_SIZE * CMAP_ENTRY_LENGTH;
+ for (ce = new_cmap_tab; ce - new_cmap_tab < NEW_CMAP_SIZE; ce++) {
+ ce->offset = offset;
+ switch (ce->format) {
+ case 0:
+ offset += BYTE_ENCODING_LENGTH;
+ break;
+ case 4:
+ offset += SEG_MAP_DELTA_LENGTH;
+ break;
+ case 6:
+ offset += TRIMMED_TABLE_MAP_LENGTH;
+ break;
+ default:
+ pdftex_fail ("invalid format (it should not have happened)");
+ }
+ (void) put_ushort (ce->platform_id);
+ (void) put_ushort (ce->encoding_id);
+ put_ulong (ce->offset);
+ }
+ for (ce = new_cmap_tab; ce - new_cmap_tab < NEW_CMAP_SIZE; ce++) {
+ switch (ce->format) {
+ case 0:
+ ttf_byte_encoding ();
+ break;
+ case 4:
+ ttf_seg_map_delta ();
+ break;
+ case 6:
+ ttf_trimmed_table_map ();
+ break;
+ }
+ }
+ ttf_set_chksm (tab);
+}
+
+static int prepend_subset_tags (int index, char *p)
+{
+ const boolean is_unicode = (name_tab[index].platform_id == 3);
+ int i;
+ assert (index > 0 && index < name_record_num && fd_cur->subset_tag != NULL);
+ if (is_unicode) {
+ for (i = 0; i < 6; ++i) {
+ *p++ = 0;
+ *p++ = fd_cur->subset_tag[i];
+ }
+ *p++ = 0;
+ *p++ = '+';
+ return 14;
+ } else {
+ strncpy (p, fd_cur->subset_tag, 6);
+ p += 6;
+ *p++ = '+';
+ return 7;
+ }
+}
+
+
+static void ttf_write_name (void)
+{
+ int i, l;
+ char *p;
+ int new_name_buf_size;
+ char *new_name_buf;
+ name_record *n;
+ dirtab_entry *tab = ttf_name_lookup ("name", true);
+ if (is_subsetted (fd_cur->fm)) {
+ l = 0;
+ for (i = 0; i < name_record_num; i++)
+ l += name_tab[i].length + 14; /* maximum lengh of new stogare area */
+ new_name_buf = xtalloc (l, char);
+ /* additional space for subset tags */
+ p = new_name_buf;
+ for (i = 0; i < name_record_num; i++) {
+ n = name_tab + i;
+ n->new_offset = p - new_name_buf;
+ if ((n->name_id == 1 || n->name_id == 3 ||
+ n->name_id == 4 || n->name_id == 6) &&
+ ((n->platform_id == 1 && n->encoding_id == 0) ||
+ (n->platform_id == 3 && n->encoding_id == 0) ||
+ (n->platform_id == 3 && n->encoding_id == 1))) {
+ l = prepend_subset_tags (i, p);
+ p += l;
+ } else
+ l = 0;
+ memcpy (p, name_buf + n->offset, n->length);
+ p += n->length;
+ n->new_length = n->length + l;
+ }
+ new_name_buf_size = p - new_name_buf;
+ } else {
+ new_name_buf = name_buf;
+ new_name_buf_size = name_buf_size;
+ }
+ ttf_reset_chksm (tab);
+ (void) put_ushort (0); /* Format selector */
+ (void) put_ushort (name_record_num);
+ (void) put_ushort (3 * TTF_USHORT_SIZE +
+ name_record_num * 6 * TTF_USHORT_SIZE);
+ for (i = 0; i < name_record_num; i++) {
+ (void) put_ushort (name_tab[i].platform_id);
+ (void) put_ushort (name_tab[i].encoding_id);
+ (void) put_ushort (name_tab[i].language_id);
+ (void) put_ushort (name_tab[i].name_id);
+ (void) put_ushort (name_tab[i].new_length);
+ (void) put_ushort (name_tab[i].new_offset);
+ }
+ for (p = new_name_buf; p - new_name_buf < new_name_buf_size; p++)
+ put_char (*p);
+ ttf_set_chksm (tab);
+ if (new_name_buf != name_buf)
+ xfree (new_name_buf);
+}
+
+static void ttf_write_dirtab (void)
+{
+ dirtab_entry *tab;
+ TTF_ULONG i, k;
+ char *p;
+ const integer save_offset = ttf_offset ();
+ ttf_seek_outbuf (TABDIR_OFF);
+ if (is_subsetted (fd_cur->fm)) {
+ for (i = 0; i < DEFAULT_NTABS; i++) {
+ tab = ttf_name_lookup (newtabnames[i], false);
+ if (tab == NULL)
+ continue;
+ for (k = 0; k < 4; k++)
+ put_char (tab->tag[k]);
+ put_ulong (tab->checksum);
+ put_ulong (tab->offset);
+ put_ulong (tab->length);
+ }
+ } else {
+ for (tab = dir_tab; tab - dir_tab < ntabs; tab++) {
+ for (k = 0; k < 4; k++)
+ put_char (tab->tag[k]);
+ put_ulong (tab->checksum);
+ put_ulong (tab->offset);
+ put_ulong (tab->length);
+ }
+ }
+ /* adjust checkSumAdjustment */
+ tmp_ulong = 0;
+ checksum = 0;
+ for (p = fb_array, i = 0; i < (unsigned) save_offset;) {
+ tmp_ulong = (tmp_ulong << 8) + *p++;
+ i++;
+ if (i % 4 == 0) {
+ checksum += tmp_ulong;
+ tmp_ulong = 0;
+ }
+ }
+ if (i % 4 != 0) {
+ pdftex_warn ("font length is not a multiple of 4 (%li)", i);
+ checksum <<= 8 * (4 - i % 4);
+ }
+ k = 0xB1B0AFBA - checksum;
+ ttf_seek_outbuf (checkSumAdjustment_offset);
+ put_ulong (k);
+ ttf_seek_outbuf (save_offset);
+}
+
+static void ttf_write_glyf (void)
+{
+ long *id, k;
+ TTF_USHORT idx;
+ TTF_USHORT flags;
+ dirtab_entry *tab = ttf_name_lookup ("glyf", true);
+ const long glyf_offset = tab->offset;
+ const long new_glyf_offset = ttf_offset ();
+ ttf_reset_chksm (tab);
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++) {
+ glyph_tab[*id].newoffset = ttf_offset () - new_glyf_offset;
+ if (glyph_tab[*id].offset != glyph_tab[*id + 1].offset) {
+ ttf_seek_off (glyf_offset + glyph_tab[*id].offset);
+ k = copy_short ();
+ ttf_ncopy (4 * TTF_FWORD_SIZE);
+ if (k < 0) {
+ do {
+ flags = copy_ushort ();
+ idx = get_ushort ();
+ if (glyph_tab[idx].newindex < 0) {
+ glyph_tab[idx].newindex = new_glyphs_count;
+ glyph_index[new_glyphs_count++] = idx;
+ /*
+ N.B.: Here we change `new_glyphs_count',
+ which appears in the condition of the `for' loop
+ */
+ }
+ (void) put_ushort (glyph_tab[idx].newindex);
+ if (flags & ARG_1_AND_2_ARE_WORDS)
+ ttf_ncopy (2 * TTF_SHORT_SIZE);
+ else
+ ttf_ncopy (TTF_USHORT_SIZE);
+ if (flags & WE_HAVE_A_SCALE)
+ ttf_ncopy (TTF_F2DOT14_SIZE);
+ else if (flags & WE_HAVE_AN_X_AND_Y_SCALE)
+ ttf_ncopy (2 * TTF_F2DOT14_SIZE);
+ else if (flags & WE_HAVE_A_TWO_BY_TWO)
+ ttf_ncopy (4 * TTF_F2DOT14_SIZE);
+ } while (flags & MORE_COMPONENTS);
+ if (flags & WE_HAVE_INSTRUCTIONS)
+ ttf_ncopy (copy_ushort ());
+ } else
+ ttf_ncopy (glyph_tab[*id + 1].offset - glyph_tab[*id].offset -
+ TTF_USHORT_SIZE - 4 * TTF_FWORD_SIZE);
+ }
+ }
+ last_glyf_offset = ttf_offset () - new_glyf_offset;
+ ttf_set_chksm (tab);
+}
+
+static void ttf_reindex_glyphs(void)
+{
+ ttfenc_entry *e;
+ glyph_entry *glyph;
+ int index;
+ short *t;
+ ttf_cmap_entry *cmap = NULL;
+ boolean cmap_not_found = false;
+
+ /*
+ * reindexing glyphs: we append index of used glyphs to `glyph_index'
+ * while going through `ttfenc_tab'. After appending a new entry to
+ * `glyph_index' we set field `newindex' of corresponding entries in both
+ * `glyph_tab' and `ttfenc_tab' to the newly created index
+ */
+ for (e = ttfenc_tab; e - ttfenc_tab < 256; e++) {
+ e->newindex = 0; /* index of ".notdef" glyph */
+
+ /* handle case of subfonts first */
+ if (is_subfont(fd_cur->fm)) {
+ if (e->code == -1)
+ continue;
+ assert(fd_cur->fm->pid != -1 && fd_cur->fm->eid != -1);
+ if (cmap == NULL && !cmap_not_found) {
+ cmap =
+ ttf_read_cmap(fd_cur->fm->ff_name, fd_cur->fm->pid,
+ fd_cur->fm->eid, true);
+ if (cmap == NULL)
+ cmap_not_found = true;
+ }
+ if (cmap == NULL)
+ continue;
+ t = cmap->table;
+ assert(t != NULL && e->code < 0x10000);
+ if (t[e->code] < 0) {
+ pdftex_warn
+ ("subfont %s: wrong mapping: character %li --> 0x%4.4lX --> .notdef",
+ fd_cur->fm->tfm_name, (long) (e - ttfenc_tab), e->code);
+ continue;
+ }
+ assert(t[e->code] >= 0 && t[e->code] < glyphs_count); /* t has been read from ttf */
+ glyph = glyph_tab + t[e->code];
+ goto append_new_glyph;
+ }
+
+ /* handle case of reencoded fonts */
+ if (e->name == notdef)
+ continue;
+ /* scan form `index123' */
+ if (sscanf(e->name, GLYPH_PREFIX_INDEX "%i", &index) == 1) {
+ if (index >= glyphs_count) {
+ pdftex_warn("`%s' out of valid range [0..%i)",
+ e->name, glyphs_count);
+ continue;
+ }
+ glyph = glyph_tab + index;
+ goto append_new_glyph;
+ }
+ /* scan form `uniABCD' */
+ if (sscanf(e->name, GLYPH_PREFIX_UNICODE "%X", &index) == 1) {
+ if (cmap == NULL && !cmap_not_found) {
+ /* need to read the unicode mapping, ie (pid,eid) = (3,1) or (0,3) */
+ cmap = ttf_read_cmap(fd_cur->fm->ff_name, 3, 1, false);
+ if (cmap == NULL)
+ cmap = ttf_read_cmap(fd_cur->fm->ff_name, 0, 3, false);
+ if (cmap == NULL) {
+ pdftex_warn
+ ("no unicode mapping found, all `uniXXXX' names will be ignored");
+ cmap_not_found = true; /* once only */
+ }
+ }
+ if (cmap == NULL)
+ continue;
+ t = cmap->table;
+ assert(t != NULL);
+ if (t[index] != -1) {
+ if (t[index] >= glyphs_count) {
+ pdftex_warn
+ ("`%s' is mapped to index %i which is out of valid range [0..%i)",
+ e->name, t[index], glyphs_count);
+ continue;
+ }
+ glyph = glyph_tab + t[index];
+ goto append_new_glyph;
+ } else {
+ pdftex_warn("`unicode %s%.4X' is not mapped to any glyph",
+ GLYPH_PREFIX_UNICODE, index);
+ continue;
+ }
+ }
+ /* look up by name */
+ for (glyph = glyph_tab; glyph - glyph_tab < glyphs_count; glyph++)
+ if (glyph->name != notdef && strcmp(glyph->name, e->name) == 0)
+ break;
+ if (!(glyph - glyph_tab < glyphs_count)) {
+ pdftex_warn("glyph `%s' not found", e->name);
+ continue;
+ }
+ append_new_glyph:
+ assert(glyph > glyph_tab && glyph - glyph_tab < glyphs_count);
+ if (glyph->newindex < 0) {
+ glyph_index[new_glyphs_count] = (short) (glyph - glyph_tab);
+ glyph->newindex = new_glyphs_count;
+ new_glyphs_count++;
+ }
+ e->newindex = glyph->newindex;
+ }
+}
+
+static void ttf_write_head ()
+{
+ dirtab_entry *tab;
+ tab = ttf_seek_tab ("head", 0);
+ ttf_reset_chksm (tab);
+ ttf_ncopy (2 * TTF_FIXED_SIZE);
+ checkSumAdjustment_offset = ttf_offset ();
+ put_ulong (0);
+ ttf_skip (TTF_ULONG_SIZE); /* skip checkSumAdjustment */
+ ttf_ncopy (TTF_ULONG_SIZE + 2 * TTF_USHORT_SIZE + 16 +
+ 4 * TTF_FWORD_SIZE + 2 * TTF_USHORT_SIZE + TTF_SHORT_SIZE);
+ if (is_subsetted(fd_cur->fm)) {
+ (void) put_short (loca_format);
+ (void) put_short (0);
+ } else
+ ttf_ncopy (2 * TTF_SHORT_SIZE);
+ ttf_set_chksm (tab);
+}
+
+static void ttf_write_hhea (void)
+{
+ dirtab_entry *tab;
+ tab = ttf_seek_tab ("hhea", 0);
+ ttf_reset_chksm (tab);
+ ttf_ncopy (TTF_FIXED_SIZE + 3 * TTF_FWORD_SIZE + TTF_UFWORD_SIZE +
+ 3 * TTF_FWORD_SIZE + 8 * TTF_SHORT_SIZE);
+ (void) put_ushort (new_glyphs_count);
+ ttf_set_chksm (tab);
+}
+
+static void ttf_write_htmx (void)
+{
+ long *id;
+ dirtab_entry *tab = ttf_seek_tab ("hmtx", 0);
+ ttf_reset_chksm (tab);
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++) {
+ put_ufword (glyph_tab[*id].advWidth);
+ put_ufword (glyph_tab[*id].lsb);
+ }
+ ttf_set_chksm (tab);
+}
+
+static void ttf_write_loca (void)
+{
+ long *id;
+ dirtab_entry *tab = ttf_seek_tab ("loca", 0);
+ ttf_reset_chksm (tab);
+ loca_format = 0;
+ if (last_glyf_offset >= 0x00020000 || (last_glyf_offset & 1))
+ loca_format = 1;
+ else
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++)
+ if (glyph_tab[*id].newoffset & 1) {
+ loca_format = 1;
+ break;
+ }
+ if (loca_format != 0) {
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++)
+ put_ulong (glyph_tab[*id].newoffset);
+ put_ulong (last_glyf_offset);
+ } else {
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++)
+ (void) put_ushort (glyph_tab[*id].newoffset / 2);
+ (void) put_ushort (last_glyf_offset / 2);
+ }
+ ttf_set_chksm (tab);
+}
+
+static void ttf_write_mapx (void)
+{
+ dirtab_entry *tab = ttf_seek_tab ("maxp", TTF_FIXED_SIZE + TTF_USHORT_SIZE);
+ ttf_reset_chksm (tab);
+ put_fixed (0x00010000);
+ (void) put_ushort (new_glyphs_count);
+ ttf_ncopy (13 * TTF_USHORT_SIZE);
+ ttf_set_chksm (tab);
+}
+
+static void ttf_write_OS2 (void)
+{
+ dirtab_entry *tab = ttf_seek_tab ("OS/2", 0);
+ TTF_USHORT version;
+ ttf_reset_chksm (tab);
+ version = get_ushort ();
+ if (version > 3)
+ pdftex_fail ("unknown version of OS/2 table (%.4X)", version);
+ (void) put_ushort (0x0001); /* fix version to 1 */
+ ttf_ncopy (2 * TTF_USHORT_SIZE + 13 * TTF_SHORT_SIZE + 10 * TTF_BYTE_SIZE);
+ ttf_skip (4 * TTF_ULONG_SIZE); /* ulUnicodeRange 1--4 */
+ put_ulong (0x00000003); /* Basic Latin + Latin-1 Supplement (0x0000--0x00FF) */
+ put_ulong (0x10000000); /* Private Use (0xE000--0xF8FF) */
+ put_ulong (0x00000000);
+ put_ulong (0x00000000);
+ ttf_ncopy (4 * TTF_CHAR_SIZE + TTF_USHORT_SIZE); /* achVendID + fsSelection */
+ ttf_skip (2 * TTF_USHORT_SIZE);
+ (void) put_ushort (0x0000); /* usFirstCharIndex */
+ (void) put_ushort (0xF0FF); /* usLastCharIndex */
+ ttf_ncopy (5 * TTF_USHORT_SIZE);
+ /* for version 0 the OS/2 table ends here, the rest is for version 1 */
+ put_ulong (0x80000000); /* Symbol Character Set---don't use any code page */
+ put_ulong (0x00000000);
+ ttf_set_chksm (tab);
+}
+
+static boolean unsafe_name (char *s)
+{
+ const char **p;
+ for (p = ambiguous_names; *p != NULL; p++)
+ if (strcmp (s, *p) == 0)
+ return true;
+ return false;
+}
+
+static void ttf_write_post (void)
+{
+ dirtab_entry *tab = ttf_seek_tab ("post", TTF_FIXED_SIZE);
+ glyph_entry *glyph;
+ char *s;
+ long *id;
+ int l;
+ ttf_reset_chksm (tab);
+ if (!fd_cur->write_ttf_glyph_names || post_format == 0x00030000) {
+ put_fixed (0x00030000);
+ ttf_ncopy (TTF_FIXED_SIZE + 2 * TTF_FWORD_SIZE + 5 * TTF_ULONG_SIZE);
+ } else {
+ put_fixed (0x00020000);
+ ttf_ncopy (TTF_FIXED_SIZE + 2 * TTF_FWORD_SIZE + 5 * TTF_ULONG_SIZE);
+ (void) put_ushort (new_glyphs_count);
+ k = 0;
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++) {
+ glyph = glyph_tab + *id;
+ if (glyph->name_index >= NMACGLYPHS || unsafe_name (glyph->name))
+ glyph->name_index = NMACGLYPHS + k++;
+ (void) put_ushort (glyph->name_index);
+ }
+ for (id = glyph_index; id - glyph_index < new_glyphs_count; id++) {
+ glyph = glyph_tab + *id;
+ if (glyph->name_index >= NMACGLYPHS) {
+ s = glyph->name;
+ l = strlen (s);
+ put_byte (l);
+ while (l-- > 0)
+ put_char (*s++);
+ }
+ }
+ }
+ ttf_set_chksm (tab);
+}
+
+static void ttf_init_font (int n)
+{
+ int i, k;
+ for (i = 1, k = 0; i <= n; i <<= 1, k++);
+ put_fixed (0x00010000); /* font version */
+ (void) put_ushort (n); /* number of tables */
+ (void) put_ushort (i << 3); /* search range */
+ (void) put_ushort (k - 1); /* entry selector */
+ (void) put_ushort ((n << 4) - (i << 3)); /* range shift */
+ ttf_seek_outbuf (TABDIR_OFF + n * 4 * TTF_ULONG_SIZE);
+}
+
+static void ttf_subset_font (void)
+{
+ ttf_init_font (new_ntabs);
+ if (ttf_name_lookup ("PCLT", false) != NULL)
+ ttf_copytab ("PCLT");
+ if (ttf_name_lookup ("fpgm", false) != NULL)
+ ttf_copytab ("fpgm");
+ if (ttf_name_lookup ("cvt ", false) != NULL)
+ ttf_copytab ("cvt ");
+ if (ttf_name_lookup ("prep", false) != NULL)
+ ttf_copytab ("prep");
+ ttf_reindex_glyphs ();
+ ttf_write_glyf ();
+ ttf_write_loca ();
+ ttf_write_OS2 ();
+ ttf_write_head ();
+ ttf_write_hhea ();
+ ttf_write_htmx ();
+ ttf_write_mapx ();
+ ttf_write_name ();
+ ttf_write_post ();
+ ttf_write_cmap ();
+ ttf_write_dirtab ();
+}
+
+static void ttf_copy_font (void)
+{
+ dirtab_entry *tab;
+ ttf_init_font (ntabs);
+ for (tab = dir_tab; tab - dir_tab < ntabs; tab++) {
+ if (strncmp (tab->tag, "head", 4) == 0)
+ ttf_write_head ();
+ else
+ ttf_copytab (tab->tag);
+ }
+ ttf_write_dirtab ();
+}
+
+void writettf(fd_entry * fd)
+{
+ int callback_id;
+ int file_opened = 0;
+ char *ftemp = NULL;
+ fd_cur = fd; /* fd_cur is global inside writettf.c */
+ assert(fd_cur->fm != NULL);
+ assert(is_truetype(fd_cur->fm));
+ assert(is_included(fd_cur->fm));
+
+ set_cur_file_name(fd_cur->fm->ff_name);
+
+ if (is_subsetted(fd_cur->fm) && (fd_cur->fe == NULL)
+ && !is_subfont(fd_cur->fm)) {
+ pdftex_warn ("Subset TrueType must be a reencoded or a subfont");
+ cur_file_name = NULL;
+ return;
+ }
+ ttf_curbyte=0;
+ ttf_size=0;
+ callback_id=callback_defined(find_truetype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",(char *)(nameoffile+1),&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(nameoffile);
+ namelength = strlen(ftemp);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),ftemp);
+ free(ftemp);
+ }
+ }
+ }
+
+ callback_id=callback_defined(read_truetype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",(char *)(nameoffile+1),
+ &file_opened, &ttf_buffer,&ttf_size) &&
+ file_opened && ttf_size>0) {
+ } else {
+ pdftex_fail ("cannot open TrueType font file for reading");
+ }
+ } else {
+ if (!ttf_open ()) {
+ pdftex_fail ("cannot open TrueType font file for reading");
+ }
+ ttf_read_file();
+ ttf_close();
+ }
+ cur_file_name = (char *) nameoffile + 1;
+ if (tracefilenames) {
+ if (is_subsetted(fd_cur->fm))
+ tex_printf ("<%s", cur_file_name);
+ else
+ tex_printf ("<<%s", cur_file_name);
+ }
+ fd_cur->ff_found = true;
+ new_glyphs_count = 2;
+ new_ntabs = DEFAULT_NTABS;
+ dir_tab = NULL;
+ glyph_tab = NULL;
+ glyph_index = NULL;
+ glyph_name_buf = NULL;
+ name_tab = NULL;
+ name_buf = NULL;
+ ttf_read_font ();
+
+ pdf_save_offset = pdfoffset ();
+ pdf_flush ();
+
+ if (is_subsetted(fd_cur->fm)) {
+ ttf_copy_encoding ();
+ ttf_subset_font ();
+ } else
+ ttf_copy_font ();
+ ttf_length = ttf_offset ();
+
+ xfree (dir_tab);
+ xfree (glyph_tab);
+ xfree (glyph_index);
+ xfree (glyph_name_buf);
+ xfree (name_tab);
+ xfree (name_buf);
+ if (tracefilenames) {
+ if (is_subsetted (fd_cur->fm))
+ tex_printf (">");
+ else
+ tex_printf (">>");
+ }
+ cur_file_name = NULL;
+}
+
+void do_writeotf(fd_entry * fd)
+{
+ long i;
+ dirtab_entry *tab;
+ dir_tab = NULL;
+ glyph_tab = NULL;
+ if (tracefilenames)
+ tex_printf ("<<%s", cur_file_name);
+ ttf_read_tabdir ();
+ /* read font parameters */
+ if (ttf_name_lookup ("head", false) != NULL)
+ ttf_read_head ();
+ if (ttf_name_lookup ("hhea", false) != NULL)
+ ttf_read_hhea ();
+ if (ttf_name_lookup ("PCLT", false) != NULL)
+ ttf_read_pclt ();
+ if (ttf_name_lookup ("post", false) != NULL)
+ ttf_read_post ();
+ /* copy font file */
+ tab = ttf_seek_tab ("CFF ", 0);
+ for (i = tab->length; i > 0; i--)
+ copy_char ();
+ xfree (dir_tab);
+ /* ttf_close ();*/
+ if (tracefilenames)
+ tex_printf (">>");
+}
+
+void writeotf (fd_entry * fd) {
+ int callback_id;
+ int file_opened = 0;
+ char *ftemp = NULL;
+
+
+ fd_cur = fd; /* fd_cur is global inside writettf.c */
+ assert(fd_cur->fm != NULL);
+ assert(is_opentype(fd_cur->fm));
+ assert(is_included(fd_cur->fm));
+
+ set_cur_file_name(fd_cur->fm->ff_name);
+ ttf_curbyte=0;
+ ttf_size=0;
+ callback_id=callback_defined(find_opentype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",(char *)(nameoffile+1),&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(nameoffile);
+ namelength = strlen(ftemp);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),ftemp);
+ free(ftemp);
+ }
+ }
+ }
+ callback_id=callback_defined(read_opentype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",(char *)(nameoffile+1),
+ &file_opened, &ttf_buffer,&ttf_size) &&
+ file_opened && ttf_size>0) {
+ } else {
+ pdftex_fail ("cannot open OpenType font file for reading");
+ }
+ } else {
+ if (!otf_open ()) {
+ pdftex_fail ("cannot open OpenType font file for reading");
+ }
+ ttf_read_file();
+ ttf_close();
+ }
+
+ cur_file_name = (char *) nameoffile + 1;
+ fd_cur->ff_found = true;
+ do_writeotf(fd);
+ cur_file_name = NULL;
+}
+
+/*
+ To calculate the checkSum for the 'head' table which itself includes the
+ checkSumAdjustment entry for the entire font, do the following:
+
+ * Set the checkSumAdjustment to 0.
+ * Calculate the checksum for all the tables including the 'head' table
+ and enter that value into the table directory.
+ * Calculate the checksum for the entire font.
+ * Subtract that value from the hex value B1B0AFBA.
+ * Store the result in checkSumAdjustment.
+
+ The checkSum for the 'head table which includes the checkSumAdjustment
+ entry for the entire font is now incorrect. That is not a problem. Do not
+ change it. An application attempting to verify that the 'head' table has
+ not changed should calculate the checkSum for that table by not including
+ the checkSumAdjustment value, and compare the result with the entry in the
+ table directory.
+
+ The table directory also includes the offset of the associated tagged
+ table from the beginning of the font file and the length of that table.
+ */
diff --git a/Build/source/texk/web2c/luatexdir/font/writettf.h b/Build/source/texk/web2c/luatexdir/font/writettf.h
new file mode 100644
index 00000000000..ecfaa2c37e3
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writettf.h
@@ -0,0 +1,172 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writettf.h 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+typedef signed char TTF_CHAR;
+typedef unsigned char TTF_BYTE;
+typedef signed short TTF_SHORT;
+typedef unsigned short TTF_USHORT;
+typedef signed long TTF_LONG;
+typedef unsigned long TTF_ULONG;
+typedef unsigned long TTF_FIXED;
+typedef unsigned short TTF_FUNIT;
+typedef signed short TTF_FWORD;
+typedef unsigned short TTF_UFWORD;
+typedef unsigned short TTF_F2DOT14;
+
+#define TTF_CHAR_SIZE 1
+#define TTF_BYTE_SIZE 1
+#define TTF_SHORT_SIZE 2
+#define TTF_USHORT_SIZE 2
+#define TTF_LONG_SIZE 4
+#define TTF_ULONG_SIZE 4
+#define TTF_FIXED_SIZE 4
+#define TTF_FWORD_SIZE 2
+#define TTF_UFWORD_SIZE 2
+#define TTF_F2DOT14_SIZE 2
+
+#define ARG_1_AND_2_ARE_WORDS (1<<0)
+#define ARGS_ARE_XY_VALUES (1<<1)
+#define ROUND_XY_TO_GRID (1<<2)
+#define WE_HAVE_A_SCALE (1<<3)
+#define RESERVED (1<<4)
+#define MORE_COMPONENTS (1<<5)
+#define WE_HAVE_AN_X_AND_Y_SCALE (1<<6)
+#define WE_HAVE_A_TWO_BY_TWO (1<<7)
+#define WE_HAVE_INSTRUCTIONS (1<<8)
+#define USE_MY_METRICS (1<<9)
+
+#define get_type(t) ((t)ttf_getnum(t##_SIZE))
+#define ttf_skip(n) ttf_getnum(n)
+
+#define get_byte() get_type(TTF_BYTE)
+#define get_char() get_type(TTF_CHAR)
+#define get_ushort() get_type(TTF_USHORT)
+#define get_short() get_type(TTF_SHORT)
+#define get_ulong() get_type(TTF_ULONG)
+#define get_long() get_type(TTF_LONG)
+#define get_fixed() get_type(TTF_FIXED)
+#define get_funit() get_type(TTF_FUNIT)
+#define get_fword() get_type(TTF_FWORD)
+#define get_ufword() get_type(TTF_UFWORD)
+#define get_f2dot14() get_type(TTF_F2DOT14)
+
+#define put_num(t,n) ((t)ttf_putnum(t##_SIZE, n))
+
+#define put_char(n) (void)put_num(TTF_CHAR, n)
+#define put_byte(n) (void)put_num(TTF_BYTE, n)
+#define put_short(n) put_num(TTF_SHORT, n)
+#define put_ushort(n) put_num(TTF_USHORT, n)
+#define put_long(n) put_num(TTF_LONG, n)
+#define put_ulong(n) (void)put_num(TTF_ULONG, n)
+#define put_fixed(n) (void)put_num(TTF_FIXED, n)
+#define put_funit(n) put_num(TTF_FUNIT, n)
+#define put_fword(n) put_num(TTF_FWORD, n)
+#define put_ufword(n) (void)put_num(TTF_UFWORD, n)
+#define put_f2dot14(n) put_num(TTF_F2DOT14, n)
+
+#define copy_byte() put_byte(get_byte())
+#define copy_char() put_char(get_char())
+#define copy_ushort() put_ushort(get_ushort())
+#define copy_short() put_short(get_short())
+#define copy_ulong() put_ulong(get_ulong())
+#define copy_long() put_long(get_long())
+#define copy_fixed() put_fixed(get_fixed())
+#define copy_funit() put_funit(get_funit())
+#define copy_fword() put_fword(get_fword())
+#define copy_ufword() put_ufword(get_ufword())
+#define copy_f2dot14() put_f2dot14(get_f2dot14())
+
+#define is_unicode_mapping(e) \
+ (e->platform_id == 0 || (e->platform_id == 3 || e->encoding_id == 1))
+
+
+#define NMACGLYPHS 258
+#define TABDIR_OFF 12
+#define ENC_BUF_SIZE 1024
+
+#define GLYPH_PREFIX_INDEX "index"
+#define GLYPH_PREFIX_UNICODE "uni"
+
+typedef struct {
+ char tag[4];
+ TTF_ULONG checksum;
+ TTF_ULONG offset;
+ TTF_ULONG length;
+} dirtab_entry;
+
+typedef struct {
+ TTF_USHORT platform_id;
+ TTF_USHORT encoding_id;
+ TTF_ULONG offset;
+ TTF_USHORT format;
+} cmap_entry;
+
+typedef struct {
+ TTF_USHORT endCode;
+ TTF_USHORT startCode;
+ TTF_USHORT idDelta;
+ TTF_USHORT idRangeOffset;
+} seg_entry;
+
+typedef struct {
+ TTF_LONG offset;
+ TTF_LONG newoffset;
+ TTF_UFWORD advWidth;
+ TTF_FWORD lsb;
+ char *name; /* name of glyph */
+ TTF_SHORT newindex; /* new index of glyph in output file */
+ TTF_USHORT name_index; /* index of name as read from font file */
+} glyph_entry;
+
+/* some functions and variables are used by writetype0.c */
+
+extern fd_entry *fd_cur; /* pointer to the current font descriptor */
+extern unsigned char *ttf_buffer;
+extern integer ttf_size;
+extern integer ttf_curbyte;
+extern glyph_entry *glyph_tab;
+extern dirtab_entry *dir_tab;
+extern dirtab_entry *ttf_name_lookup (const char *s, boolean required);
+extern dirtab_entry *ttf_seek_tab (const char *name, TTF_LONG offset);
+
+extern void ttf_read_tabdir (void);
+extern void ttf_read_head (void);
+extern void ttf_read_hhea (void);
+extern void ttf_read_pclt (void);
+extern void ttf_read_post (void);
+
+extern FILE *ttf_file;
+
+#define ttf_open() \
+ open_input(&ttf_file, kpse_truetype_format, FOPEN_RBIN_MODE)
+#define otf_open() \
+ open_input(&ttf_file, kpse_opentype_format, FOPEN_RBIN_MODE)
+#define ttf_read_file() \
+ readbinfile(ttf_file,&ttf_buffer,&ttf_size)
+#define ttf_close() xfclose(ttf_file,cur_file_name)
+#define ttf_getchar() ttf_buffer[ttf_curbyte++]
+#define ttf_eof() (ttf_curbyte>ttf_size)
+
+extern long ttf_putnum (int s, long n);
+extern long ttf_getnum (int s);
+
+
diff --git a/Build/source/texk/web2c/luatexdir/font/writetype0.c b/Build/source/texk/web2c/luatexdir/font/writetype0.c
new file mode 100644
index 00000000000..0f9eecaac7c
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writetype0.c
@@ -0,0 +1,124 @@
+/*
+Copyright (c) 2007 Taco Hoekwater, taco@luatex.org
+
+This file is part of luaTeX.
+
+luaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+luaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with luaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writetype0.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+
+#include "writettf.h"
+
+#include "writecff.h"
+
+void writetype0 (fd_entry * fd) {
+ int callback_id;
+ int file_opened = 0;
+ char *ftemp = NULL;
+ long i;
+ dirtab_entry *tab;
+ cff_font *cff;
+
+ dir_tab = NULL;
+ glyph_tab = NULL;
+
+ fd_cur = fd; /* fd_cur is global inside writettf.c */
+ assert(fd_cur->fm != NULL);
+ assert(is_opentype(fd_cur->fm));
+ assert(is_included(fd_cur->fm));
+
+ set_cur_file_name(fd_cur->fm->ff_name);
+ ttf_curbyte=0;
+ ttf_size=0;
+ callback_id=callback_defined(find_opentype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",(char *)(nameoffile+1),&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(nameoffile);
+ namelength = strlen(ftemp);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),ftemp);
+ free(ftemp);
+ }
+ }
+ }
+ callback_id=callback_defined(read_opentype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",(char *)(nameoffile+1),
+ &file_opened, &ttf_buffer,&ttf_size) &&
+ file_opened && ttf_size>0) {
+ } else {
+ pdftex_fail ("cannot open OpenType font file for reading");
+ }
+ } else {
+ if (!otf_open ()) {
+ pdftex_fail ("cannot open OpenType font file for reading");
+ }
+ ttf_read_file();
+ ttf_close();
+ }
+
+ cur_file_name = (char *) nameoffile + 1;
+ fd_cur->ff_found = true;
+
+ if (tracefilenames) {
+ if (is_subsetted(fd_cur->fm))
+ tex_printf ("<%s", cur_file_name);
+ else
+ tex_printf ("<<%s", cur_file_name);
+ }
+ ttf_read_tabdir ();
+ /* read font parameters */
+ if (ttf_name_lookup ("head", false) != NULL)
+ ttf_read_head ();
+ if (ttf_name_lookup ("hhea", false) != NULL)
+ ttf_read_hhea ();
+ if (ttf_name_lookup ("PCLT", false) != NULL)
+ ttf_read_pclt ();
+ if (ttf_name_lookup ("post", false) != NULL)
+ ttf_read_post ();
+
+ /* copy font file */
+ tab = ttf_seek_tab ("CFF ", 0);
+
+ /* TODO the next 0 is a subfont index */
+ cff = read_cff(ttf_buffer+ttf_curbyte,tab->length,0);
+ if (cff != NULL) {
+ if (cff_is_cidfont(cff)) {
+ write_cid_cff(cff,fd_cur,0);
+ /*
+ for (i = tab->length; i > 0; i--)
+ fb_putchar (ttf_getnum(1));
+ */
+ } else {
+ write_cff(cff,fd_cur,0);
+ }
+ } else {
+ /* not understood, just do a copy */
+ for (i = tab->length; i > 0; i--)
+ fb_putchar (ttf_getnum(1));
+ }
+ xfree (dir_tab);
+ if (tracefilenames) {
+ if (is_subsetted (fd_cur->fm))
+ tex_printf (">");
+ else
+ tex_printf (">>");
+ }
+ cur_file_name = NULL;
+}
diff --git a/Build/source/texk/web2c/luatexdir/font/writetype2.c b/Build/source/texk/web2c/luatexdir/font/writetype2.c
new file mode 100644
index 00000000000..649c350b707
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/font/writetype2.c
@@ -0,0 +1,422 @@
+
+/*
+Copyright (c) 2007 Taco Hoekwater, taco@luatex.org
+
+This file is part of luaTeX.
+
+luaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+luaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with luaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writetype2.c 1013 2008-02-14 00:09:02Z oneiros $
+*/
+
+#include "ptexlib.h"
+#include "writettf.h"
+#include "writecff.h"
+
+#include "sfnt.h"
+#include "tt_glyf.h"
+
+/* forward*/
+void make_tt_subset (fd_entry * fd,unsigned char *buffer, integer buflen) ;
+
+unsigned long cidtogid_obj = 0;
+
+/* low-level helpers */
+
+#define test_loc(l) \
+ if ((f->loc+l)>f->buflen) { \
+ fprintf (stderr,"File ended prematurely\n"); \
+ uexit(1); \
+ }
+
+
+BYTE get_unsigned_byte(sfnt* f) {
+ test_loc(1);
+ return (BYTE)f->buffer[(f->loc++)];
+};
+
+ICHAR get_signed_byte(sfnt* f) {
+ test_loc(1);
+ return (ICHAR)f->buffer[(f->loc++)];
+};
+
+USHORT get_unsigned_pair(sfnt* f){
+ USHORT l;
+ test_loc(2);
+ l = f->buffer[(f->loc++)];
+ l = l*0x100 + f->buffer[(f->loc++)];
+ return l;
+};
+
+SHORT get_signed_pair(sfnt* f){
+ long l;
+ test_loc(2);
+ l = f->buffer[(f->loc++)];
+ if (l>0x80) l -= 0x100;
+ l = l*0x100 + f->buffer[(f->loc++)];
+ return l;
+};
+
+ULONG get_unsigned_quad(sfnt* f){
+ ULONG l;
+ test_loc(4);
+ l = f->buffer[(f->loc++)];
+ l = l*0x100 + f->buffer[(f->loc++)];
+ l = l*0x100 + f->buffer[(f->loc++)];
+ l = l*0x100 + f->buffer[(f->loc++)];
+ return l;
+};
+
+int do_sfnt_read (unsigned char *dest, int len, sfnt *f) {
+ int i;
+ test_loc(len);
+ for (i=0;i<len;i++) {
+ *(dest+i)=f->buffer[f->loc+i];
+ }
+ f->loc += len;
+ return len;
+};
+
+pdf_obj *pdf_new_stream(void) {
+ pdf_obj *stream = xmalloc(sizeof(pdf_obj)) ;
+ stream->length =0;
+ stream->data=NULL;
+ return stream;
+};
+
+void pdf_add_stream(pdf_obj *stream, unsigned char *buf, long len) {
+ int i;
+ assert (stream!=NULL);
+ if (stream->data==NULL) {
+ stream->data = xmalloc(len);
+ } else {
+ stream->data = xrealloc(stream->data,len+stream->length);
+ }
+ for (i=0;i<len;i++) {
+ *(stream->data+stream->length+i)=*(buf+i);
+ }
+ stream->length+=len;
+};
+
+void pdf_release_obj(pdf_obj *stream) {
+ if (stream!=NULL) {
+ if (stream->data!=NULL) {
+ xfree(stream->data);
+ }
+ xfree(stream);
+ }
+};
+
+
+void
+writetype2 (fd_entry * fd) {
+ int callback_id;
+ int file_opened = 0;
+ char *ftemp = NULL;
+
+ glyph_tab = NULL;
+
+ fd_cur = fd; /* fd_cur is global inside writettf.c */
+ assert(fd_cur->fm != NULL);
+ assert(is_truetype(fd_cur->fm));
+
+ if (!is_subsetted(fd_cur->fm)) {
+ writettf(fd);
+ return;
+ }
+
+ assert(is_included(fd_cur->fm));
+
+ set_cur_file_name(fd_cur->fm->ff_name);
+ ttf_curbyte=0;
+ ttf_size=0;
+ callback_id=callback_defined(find_opentype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->S",(char *)(nameoffile+1),&ftemp)) {
+ if(ftemp!=NULL&&strlen(ftemp)) {
+ free(nameoffile);
+ namelength = strlen(ftemp);
+ nameoffile = xmalloc(namelength+2);
+ strcpy((char *)(nameoffile+1),ftemp);
+ free(ftemp);
+ }
+ }
+ }
+ callback_id=callback_defined(read_opentype_file_callback);
+ if (callback_id>0) {
+ if(run_callback(callback_id,"S->bSd",(char *)(nameoffile+1),
+ &file_opened, &ttf_buffer,&ttf_size) &&
+ file_opened && ttf_size>0) {
+ } else {
+ pdftex_fail ("cannot open OpenType font file for reading");
+ }
+ } else {
+ if (!otf_open ()) {
+ pdftex_fail ("cannot open OpenType font file for reading");
+ }
+ ttf_read_file();
+ ttf_close();
+ }
+
+ cur_file_name = (char *) nameoffile + 1;
+ fd_cur->ff_found = true;
+
+ if (tracefilenames) {
+ if (is_subsetted(fd_cur->fm))
+ tex_printf ("<%s", cur_file_name);
+ else
+ tex_printf ("<<%s", cur_file_name);
+ }
+
+ /* here is the real work */
+
+ make_tt_subset(fd,ttf_buffer,ttf_size);
+
+ /*xfree (dir_tab);*/
+ if (tracefilenames) {
+ if (is_subsetted (fd_cur->fm))
+ tex_printf (">");
+ else
+ tex_printf (">>");
+ }
+ cur_file_name = NULL;
+}
+
+/*
+ * PDF viewer applications use following tables (CIDFontType 2)
+ *
+ * head, hhea, loca, maxp, glyf, hmtx, fpgm, cvt_, prep
+ *
+ * - from PDF Ref. v.1.3, 2nd ed.
+ *
+ * The fpgm, cvt_, and prep tables appears only when TrueType instructions
+ * requires them. Those tables must be preserved if they exist.
+ * We use must_exist flag to indicate `preserve it if present'
+ * and to make sure not to cause an error when it does not exist.
+ *
+ * post and name table must exist in ordinary TrueType font file,
+ * but when a TrueType font is converted to CIDFontType 2 font, those tables
+ * are no longer required.
+ *
+ * The OS/2 table (required for TrueType font for Windows and OS/2) contains
+ * liscencing information, but PDF viewers seems not using them.
+ *
+ * The 'name' table added. See comments in ttf.c.
+ */
+
+static struct
+{
+ const char *name;
+ int must_exist;
+} required_table[] = {
+ {"OS/2", 0}, {"head", 1}, {"hhea", 1}, {"loca", 1}, {"maxp", 1},
+ {"name", 1}, {"glyf", 1}, {"hmtx", 1}, {"fpgm", 0}, {"cvt ", 0},
+ {"prep", 0}, {NULL, 0}
+};
+
+
+unsigned long ttc_read_offset (sfnt *sfont, int ttc_idx)
+{
+ long version;
+ unsigned long offset = 0;
+ unsigned long num_dirs = 0;
+
+ sfnt_seek_set (sfont, 4); /* skip version tag */
+
+ version = sfnt_get_ulong(sfont);
+ num_dirs = sfnt_get_ulong(sfont);
+ if (ttc_idx < 0 || ttc_idx > num_dirs - 1) {
+ fprintf(stderr,"Invalid TTC index number\n");
+ uexit(1);
+ }
+
+ sfnt_seek_set (sfont, 12 + ttc_idx * 4);
+ offset = sfnt_get_ulong (sfont);
+
+ return offset;
+}
+
+extern int ff_get_ttc_index(char *ffname, char*psname);
+
+void make_tt_subset (fd_entry * fd,unsigned char *buffer, integer buflen) {
+
+ long i, cid;
+ unsigned int last_cid;
+ glw_entry *glyph, *found;
+ struct avl_traverser t;
+ unsigned char *cidtogidmap ;
+ unsigned short num_glyphs, gid;
+ struct tt_glyphs *glyphs;
+ char *used_chars;
+ sfnt *sfont;
+ pdf_obj *fontfile;
+ int verbose = 0, error = 0;
+
+ cidtogidmap = NULL;
+
+ sfont = sfnt_open(buffer, buflen);
+
+ if (sfont->type == SFNT_TYPE_TTC) {
+ i = ff_get_ttc_index(fd->fm->ff_name,fd->fm->ps_name);
+ error = sfnt_read_table_directory(sfont, ttc_read_offset(sfont, i));
+ } else {
+ error = sfnt_read_table_directory(sfont, 0);
+ }
+
+ if (error < 0) {
+ fprintf(stderr,"Could not parse the ttf directory.\n");
+ uexit(1);
+ }
+
+ glyphs = tt_build_init();
+
+ last_cid = 0;
+ num_glyphs = 1; /* .notdef */
+
+ glyph = xtalloc(1,glw_entry);
+
+ avl_t_init(&t, fd->gl_tree);
+ for (found = (glw_entry *) avl_t_first(&t, fd->gl_tree);
+ found != NULL;
+ found = (glw_entry *) avl_t_next(&t)) {
+ if (found->id > last_cid)
+ last_cid = found->id;
+ }
+
+#ifndef NO_GHOSTSCRIPT_BUG
+ cidtogidmap = NULL;
+#else
+ cidtogidmap = xmalloc(((last_cid + 1) * 2) * sizeof(unsigned char));
+ memset(cidtogidmap, 0, (last_cid + 1) * 2);
+#endif
+
+ /* fill used_chars */
+ used_chars = xmalloc((last_cid + 1) * sizeof(char));
+ memset(used_chars, 0, (last_cid + 1));
+ avl_t_init(&t, fd->gl_tree);
+ for (found = (glw_entry *) avl_t_first(&t, fd->gl_tree);
+ found != NULL;
+ found = (glw_entry *) avl_t_next(&t)) {
+ used_chars[found->id] = 1;
+ }
+
+ /*
+ * Map CIDs to GIDs.
+ */
+
+ num_glyphs = 1; /* .notdef */
+ for (cid = 1; cid <= last_cid; cid++) {
+ if (used_chars[cid]==0)
+ continue;
+ gid = cid;
+
+
+#ifndef NO_GHOSTSCRIPT_BUG
+ gid = tt_add_glyph(glyphs, gid, cid);
+#else
+ gid = tt_add_glyph(glyphs, gid, num_glyphs);
+ cidtogidmap[2*cid ] = gid >> 8;
+ cidtogidmap[2*cid+1] = gid & 0xff;
+#endif /* !NO_GHOSTSCRIPT_BUG */
+
+ num_glyphs++;
+ }
+
+ if (num_glyphs==1) {
+ fprintf(stderr,"No glyphs in subset?.\n");
+ uexit(1);
+ }
+
+ if (tt_build_tables(sfont, glyphs) < 0) {
+ fprintf(stderr,"Could not parse the ttf buffer.\n");
+ uexit(1);
+ }
+
+ if (verbose > 1) {
+ fprintf(stdout,"[%u glyphs (Max CID: %u)]", glyphs->num_glyphs, last_cid);
+ }
+
+ tt_build_finish(glyphs);
+
+ /* Create font file */
+
+ for (i = 0; required_table[i].name; i++) {
+ if (sfnt_require_table(sfont,
+ required_table[i].name,
+ required_table[i].must_exist) < 0) {
+ fprintf(stderr,"Some required TrueType table does not exist.");
+ uexit(1);
+ }
+ }
+
+ fontfile = sfnt_create_FontFile_stream(sfont);
+
+ if (verbose > 1) {
+ fprintf(stdout,"[%ld bytes]", fontfile->length);
+ }
+
+ /* squeeze in the cidgidmap */
+ if (cidtogidmap!=NULL) {
+ cidtogid_obj = pdf_new_objnum();
+ pdf_begin_dict(cidtogid_obj, 0);
+ pdf_printf("/Length %i\n",((last_cid + 1) * 2));
+ pdf_end_dict();
+ pdf_printf("stream\n");
+ pdfroom ((last_cid + 1) * 2);
+ for (i = 0; i<((last_cid + 1) * 2); i++ ) {
+ pdf_buf[pdf_ptr++] = cidtogidmap[i];
+ }
+ pdf_printf("\nendstream\n");
+ }
+
+ /* the tff subset */
+ for (i = 0; i<fontfile->length; i++ )
+ fb_putchar (fontfile->data[i]);
+
+
+ /* other stuff that needs fixing: */
+
+ /*
+ * DW, W, DW2, and W2
+ */
+ /*
+ if (opt_flags & CIDFONT_FORCE_FIXEDPITCH) {
+ pdf_add_dict(font->fontdict,
+ pdf_new_name("DW"), pdf_new_number(1000.0));
+ } else {
+ add_TTCIDHMetrics(font->fontdict, glyphs, used_chars, cidtogidmap, last_cid);
+ if (v_used_chars)
+ add_TTCIDVMetrics(font->fontdict, glyphs, used_chars, cidtogidmap, last_cid);
+ }
+ */
+
+ /*
+ * CIDSet
+ */
+ /*
+ {
+ pdf_obj *cidset;
+
+ cidset = pdf_new_stream(STREAM_COMPRESS);
+ pdf_add_stream(cidset, used_chars, last_cid/8 + 1);
+ pdf_add_dict(font->descriptor,
+ pdf_new_name("CIDSet"),
+ pdf_ref_obj(cidset));
+ pdf_release_obj(cidset);
+ }
+ */
+
+ return;
+}
diff --git a/Build/source/texk/web2c/luatexdir/hyphen.h b/Build/source/texk/web2c/luatexdir/hyphen.h
new file mode 100644
index 00000000000..f665c7605b9
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/hyphen.h
@@ -0,0 +1,60 @@
+/* LibHnj is dual licensed under LGPL and MPL. Boilerplate for both
+ * licenses follows.
+ */
+
+/* LibHnj - a library for high quality hyphenation and justification
+ * Copyright (C) 1998 Raph Levien, (C) 2001 ALTLinux, Moscow
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Library General Public License for more details.
+ *
+ * You should have received a copy of the GNU Library General Public
+ * License along with this library; if not, write to the
+ * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ * Boston, MA 02111-1307 USA.
+*/
+
+/*
+ * The contents of this file are subject to the Mozilla Public License
+ * Version 1.0 (the "MPL"); you may not use this file except in
+ * compliance with the MPL. You may obtain a copy of the MPL at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the MPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the MPL
+ * for the specific language governing rights and limitations under the
+ * MPL.
+ *
+ */
+#ifndef __HYPHEN_H__
+#define __HYPHEN_H__
+
+#ifdef __cplusplus
+extern "C" {
+#endif /* __cplusplus */
+
+typedef struct _HyphenDict HyphenDict;
+
+#include "ptexlib.h"
+#include "nodes.h"
+
+HyphenDict* hnj_hyphen_new();
+void hnj_hyphen_load(HyphenDict*dict, const unsigned char *fn);
+void hnj_hyphen_free (HyphenDict *dict);
+void hnj_hyphen_clear (HyphenDict *dict);
+void hnj_hyphen_hyphenate (HyphenDict *dict, halfword first, halfword last, int size, halfword left, halfword right, lang_variables*lan);
+unsigned char* hnj_serialize(HyphenDict*);
+void hnj_free_serialize(unsigned char*);
+
+#ifdef __cplusplus
+}
+#endif /* __cplusplus */
+
+#endif /* __HYPHEN_H__ */
diff --git a/Build/source/texk/web2c/luatexdir/image/.indent.pro b/Build/source/texk/web2c/luatexdir/image/.indent.pro
new file mode 100644
index 00000000000..e9e690f1ba8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/.indent.pro
@@ -0,0 +1,12 @@
+/* $Id$ */
+--k-and-r-style
+--blank-lines-after-procedures
+--line-length 80
+--procnames-start-lines
+--no-space-after-function-call-names
+--dont-break-procedure-type
+--space-after-cast
+/* this does not work in indent 2.2.6 :-( */
+--no-tabs
+/* this is new in indent 2.2.9 */
+--preprocessor-indentation 2
diff --git a/Build/source/texk/web2c/luatexdir/image/epdf.c b/Build/source/texk/web2c/luatexdir/image/epdf.c
new file mode 100644
index 00000000000..071181f17bd
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/epdf.c
@@ -0,0 +1,107 @@
+/*
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: epdf.c 1012 2008-02-14 00:00:57Z oneiros $
+*/
+
+#include "ptexlib.h"
+
+
+#include <kpathsea/c-vararg.h>
+#include <kpathsea/c-proto.h>
+#include <string.h>
+
+extern void epdf_check_mem(void);
+extern void register_fd_entry(fd_entry *);
+
+
+int is_subsetable(fm_entry * fm)
+{
+ assert(is_included(fm));
+ return is_subsetted(fm);
+}
+
+fd_entry *epdf_create_fontdescriptor(fm_entry * fm)
+{
+ fd_entry *fd;
+ if ((fd = lookup_fd_entry(fm->ff_name, fm->slant, fm->extend)) == NULL) {
+ fm->in_use = true;
+ fd = new_fd_entry();
+ fd->fm = fm;
+ register_fd_entry(fd);
+ fd->fd_objnum = pdf_new_objnum();
+ assert(fm->ps_name != NULL);
+ fd->fontname = xstrdup(fm->ps_name); /* just fallback */
+ /* preset_fontmetrics (fo->fd, f); */
+ fd->gl_tree = avl_create(comp_string_entry, NULL, &avl_xallocator);
+ assert(fd->gl_tree != NULL);
+ }
+ return fd;
+}
+
+integer get_fd_objnum(fd_entry * fd)
+{
+ assert(fd->fd_objnum != 0);
+ return fd->fd_objnum;
+}
+
+integer get_fn_objnum(fd_entry * fd)
+{
+ if (fd->fn_objnum == 0)
+ fd->fn_objnum = pdf_new_objnum();
+ return fd->fn_objnum;
+}
+
+/***********************************************************************
+ * Mark glyphs used by embedded PDF file:
+ * 1. build fontdescriptor, if not yet existing
+ * 2. mark glyphs directly there
+ *
+ * Input charset from xpdf is a string of glyph names including
+ * leading slashes, but without blanks between them, like: /a/b/c
+***********************************************************************/
+
+void epdf_mark_glyphs(fd_entry * fd, char *charset)
+{
+ char *p, *q, *s;
+ char *glyph;
+ void **aa;
+ if (charset == NULL)
+ return;
+ assert(fd != NULL);
+ for (s = charset + 1, q = charset + strlen(charset); s < q; s = p + 1) {
+ for (p = s; *p != '\0' && *p != '/'; p++);
+ *p = '\0';
+ if ((char *) avl_find(fd->gl_tree, s) == NULL) {
+ glyph = xstrdup(s);
+ aa = avl_probe(fd->gl_tree, glyph);
+ assert(aa != NULL);
+ }
+ }
+}
+
+void embed_whole_font(fd_entry * fd)
+{
+ fd->all_glyphs = true;
+}
+
+void epdf_free(void)
+{
+ epdf_check_mem();
+}
diff --git a/Build/source/texk/web2c/luatexdir/image/epdf.h b/Build/source/texk/web2c/luatexdir/image/epdf.h
new file mode 100644
index 00000000000..2359d53d3db
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/epdf.h
@@ -0,0 +1,125 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: epdf.h 1031 2008-02-14 23:03:20Z hhenkel $
+*/
+
+extern "C" {
+
+#include <kpathsea/c-auto.h>
+
+ extern char *xstrdup(const char *);
+
+/* the following code is extremly ugly but needed for including web2c/config.h */
+
+#include <kpathsea/c-proto.h> /* define P?H macros */
+
+ typedef const char *const_string; /* including kpathsea/types.h doesn't work on some systems */
+
+#define KPATHSEA_CONFIG_H /* avoid including other kpathsea header files */
+ /* from web2c/config.h */
+
+#ifdef CONFIG_H /* CONFIG_H has been defined by some xpdf */
+# undef CONFIG_H /* header file */
+#endif
+
+#include <web2c/c-auto.h> /* define SIZEOF_LONG */
+#include <web2c/config.h> /* define type integer */
+
+#include <web2c/luatexdir/ptexmac.h>
+#include "openbsd-compat.h"
+#include "image.h"
+
+/* #-define pdfbufsize pdfbufmax */
+
+ extern integer epdf_page_box;
+ extern void *epdf_xref;
+
+ extern integer pdf_box_spec_media;
+ extern integer pdf_box_spec_crop;
+ extern integer pdf_box_spec_bleed;
+ extern integer pdf_box_spec_trim;
+ extern integer pdf_box_spec_art;
+
+ extern integer pdf_stream_length;
+ extern integer pdf_ptr;
+ extern integer pool_ptr;
+ typedef unsigned char eight_bits;
+ extern eight_bits *pdf_buf;
+ extern integer pdf_buf_size;
+ extern integer pdf_os_mode;
+ extern eight_bits pdf_last_byte;
+
+ extern char notdef[];
+
+ extern integer fixed_replace_font;
+
+ extern int is_subsetable(struct fm_entry *);
+ extern struct fm_entry *lookup_fontmap(char *);
+ extern integer get_fontfile(struct fm_entry *);
+ extern integer get_fontname(struct fm_entry *);
+ extern integer pdf_new_objnum(void);
+ extern void read_pdf_info(image_dict *, integer, integer);
+ extern void embed_whole_font(struct fd_entry *);
+ extern void epdf_check_mem(void);
+ extern void epdf_delete(image_dict *);
+ extern void epdf_free(void);
+ __attribute__ ((format(printf, 1, 2)))
+ extern void pdf_printf(const char *fmt, ...);
+ extern void pdf_puts(const char *);
+ extern void pdf_begin_stream(void);
+ extern void pdf_end_obj(void);
+ extern void pdf_end_stream(void);
+ extern void pdf_flush(void);
+ __attribute__ ((noreturn, format(printf, 1, 2)))
+ extern void pdftex_fail(const char *fmt, ...);
+ __attribute__ ((format(printf, 1, 2)))
+ extern void pdftex_warn(const char *fmt, ...);
+ __attribute__ ((format(printf, 1, 2)))
+ extern void tex_printf(const char *, ...);
+ extern void write_epdf(image_dict *);
+ extern void zpdf_begin_dict(integer, bool);
+ extern void zpdf_begin_obj(integer, bool);
+ extern void zpdf_create_obj(integer, integer);
+ extern void zpdf_new_dict(integer, integer, bool);
+ extern void zpdf_os_get_os_buf(integer);
+
+/* epdf.c */
+ extern void epdf_mark_glyphs(struct fd_entry *, char *);
+ extern struct fd_entry *epdf_create_fontdescriptor(struct fm_entry *);
+ extern int get_fd_objnum(struct fd_entry *);
+ extern int get_fn_objnum(struct fd_entry *);
+
+/* write_enc.c */
+ extern void epdf_write_enc(char **, integer);
+
+/* write_enc.c */
+ extern pdf_img_struct *new_pdf_img_struct(void);
+
+/* utils.c */
+ extern char *convertStringToPDFString(char *in, int len);
+ extern char *stripzeros(char *a);
+
+/* config.c */
+ extern integer cfgpar(integer);
+
+/* avlstuff.c */
+ extern void avl_put_obj(integer, integer);
+ extern integer avl_find_obj(integer, integer, integer);
+}
diff --git a/Build/source/texk/web2c/luatexdir/image/image.h b/Build/source/texk/web2c/luatexdir/image/image.h
new file mode 100644
index 00000000000..cf7d4f0dd88
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/image.h
@@ -0,0 +1,223 @@
+/*
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: image.h 1100 2008-03-09 13:40:48Z hhenkel $
+*/
+
+#ifndef IMAGE_H
+# define IMAGE_H
+
+# include <../libpng/png.h>
+
+# define JPG_UINT16 unsigned int
+# define JPG_UINT32 unsigned long
+# define JPG_UINT8 unsigned char
+
+# define IMAGE_COLOR_B 1
+# define IMAGE_COLOR_C 2
+# define IMAGE_COLOR_I 4
+
+extern integer zround(double); /* from zround.c */
+# define bp2int(p) zround(p * (one_hundred_bp / 100.0))
+
+# define TYPE_IMG "image"
+# define TYPE_IMG_DICT "image-dict"
+
+# define scaled integer
+
+/**********************************************************************/
+
+typedef struct {
+ float width;
+ float height;
+ float orig_x;
+ float orig_y;
+ void *doc;
+} pdf_img_struct;
+
+typedef struct {
+ png_structp png_ptr;
+ png_infop info_ptr;
+} png_img_struct;
+
+typedef struct {
+ int color_space; /* used color space. See JPG_ constants */
+ JPG_UINT32 length; /* length of file/data */
+} jpg_img_struct;
+
+typedef struct { /* currently unused */
+} jb2_img_struct;
+
+typedef enum { DICT_NEW, /* fresh dictionary */
+ DICT_FILESCANNED, /* image file scanned */
+ DICT_REFERED, /* pdf_refximage_node in node list --> read-only dict */
+ DICT_OUTIMG, /* /Im* appears in pagestream */
+ DICT_SCHEDULED, /* image dict scheduled for writing */
+ DICT_WRITTEN /* image dict written to file */
+} dict_state;
+
+typedef enum { IMAGE_TYPE_NONE, IMAGE_TYPE_PDF, IMAGE_TYPE_PNG, IMAGE_TYPE_JPG,
+ IMAGE_TYPE_JBIG2, IMAGE_TYPE_SENTINEL
+} imgtype_e;
+
+typedef enum { IMG_KEEPOPEN, IMG_CLOSEINBETWEEN } img_readtype_e;
+
+typedef enum { PDF_BOX_SPEC_NONE, PDF_BOX_SPEC_MEDIA, PDF_BOX_SPEC_CROP,
+ PDF_BOX_SPEC_BLEED, PDF_BOX_SPEC_TRIM, PDF_BOX_SPEC_ART,
+ PDF_BOX_SPEC_SENTINEL
+} pdfboxspec_e;
+
+/**********************************************************************/
+
+typedef struct {
+ integer objnum;
+ integer index; /* /Im1, /Im2, ... */
+ integer x_size; /* dimensions in pixel counts as in JPG/PNG/JBIG2 file */
+ integer y_size;
+ integer x_res; /* pixel resolution as in JPG/PNG/JBIG2 file */
+ integer y_res;
+ integer colorspace; /* number of /ColorSpace object */
+ integer total_pages;
+ integer page_num; /* requested page (by number) */
+ char *pagename; /* requested page (by name) */
+ char *filename; /* requested raw file name */
+ char *filepath; /* full file path after kpathsea */
+ char *attr; /* additional image dict entries */
+ FILE *file;
+ imgtype_e image_type;
+ int color_space; /* used color space. See JPG_ constants */
+ int color_depth; /* color depth */
+ pdfboxspec_e page_box_spec; /* PDF page box spec.: media/crop/bleed/trim/art */
+ dict_state state;
+ union {
+ pdf_img_struct *pdf;
+ png_img_struct *png;
+ jpg_img_struct *jpg;
+ jb2_img_struct *jb2;
+ } img_struct;
+} image_dict;
+
+# define img_objnum(N) ((N)->objnum)
+# define img_index(N) ((N)->index)
+# define img_xsize(N) ((N)->x_size)
+# define img_ysize(N) ((N)->y_size)
+# define img_xres(N) ((N)->x_res)
+# define img_yres(N) ((N)->y_res)
+# define img_colorspace(N) ((N)->colorspace)
+# define img_totalpages(N) ((N)->total_pages)
+# define img_pagenum(N) ((N)->page_num)
+# define img_pagename(N) ((N)->pagename)
+# define img_filename(N) ((N)->filename)
+# define img_filepath(N) ((N)->filepath)
+# define img_attr(N) ((N)->attr)
+# define img_file(N) ((N)->file)
+# define img_type(N) ((N)->image_type)
+# define img_color(N) ((N)->color_space)
+# define img_colordepth(N) ((N)->color_depth)
+# define img_pagebox(N) ((N)->page_box_spec)
+# define img_state(N) ((N)->state)
+
+# define img_pdf_ptr(N) ((N)->img_struct.pdf)
+# define img_pdf_width(N) ((N)->img_struct.pdf->width)
+# define img_pdf_height(N) ((N)->img_struct.pdf->height)
+# define img_pdf_orig_x(N) ((N)->img_struct.pdf->orig_x)
+# define img_pdf_orig_y(N) ((N)->img_struct.pdf->orig_y)
+# define img_pdf_doc(N) ((N)->img_struct.pdf->doc)
+
+# define img_png_ptr(N) ((N)->img_struct.png)
+# define img_png_png_ptr(N) ((N)->img_struct.png->png_ptr)
+# define img_png_info_ptr(N) ((N)->img_struct.png->info_ptr)
+
+# define img_jpg_ptr(N) ((N)->img_struct.jpg)
+# define img_jpg_color(N) ((N)->img_struct.jpg->color_space)
+
+# define img_jb2_ptr(N) ((N)->img_struct.jb2)
+
+/**********************************************************************/
+
+typedef struct {
+ integer width; /* requested/actual TeX dimensions */
+ integer height;
+ integer depth;
+ integer transform;
+ integer flags;
+ image_dict *dict;
+ int dict_ref; /* luaL_ref() reference */
+} image;
+
+# define img_width(N) ((N)->width)
+# define img_height(N) ((N)->height)
+# define img_depth(N) ((N)->depth)
+# define img_transform(N) ((N)->transform)
+# define img_flags(N) ((N)->flags)
+# define img_dict(N) ((N)->dict)
+# define img_dictref(N) ((N)->dict_ref)
+
+# define F_FLAG_SCALED 0x01
+# define F_FLAG_REFERED 0x02
+
+# define img_flags(N) ((N)->flags)
+# define img_set_scaled(N) (img_flags(N) |= F_FLAG_SCALED)
+# define img_set_refered(N) (img_flags(N) |= F_FLAG_REFERED)
+# define img_unset_scaled(N) (img_flags(N) &= ~F_FLAG_SCALED)
+# define img_unset_refered(N) (img_flags(N) &= ~F_FLAG_REFERED)
+# define img_is_scaled(N) ((img_flags(N) & F_FLAG_SCALED) != 0)
+# define img_is_refered(N) ((img_flags(N) & F_FLAG_REFERED) != 0)
+
+# define set_wd_running(N) (img_width(N) = null_flag)
+# define set_ht_running(N) (img_height(N) = null_flag)
+# define set_dp_running(N) (img_depth(N) = null_flag)
+# define is_wd_running(N) (img_width(N) == null_flag)
+# define is_ht_running(N) (img_height(N) == null_flag)
+# define is_dp_running(N) (img_depth(N) == null_flag)
+
+/**********************************************************************/
+
+/* writeimg.c */
+
+image *new_image();
+image_dict *new_image_dict();
+void init_image(image *);
+void init_image_dict(image_dict *);
+void scale_img(image *);
+integer img_to_array(image *);
+void delete_image(image *);
+void free_image_dict(image_dict * p);
+void read_img(image_dict *, integer, integer);
+
+/* writepng.c */
+
+# ifndef boolean /* TODO: from where to get the original definition? */
+# define boolean int
+# endif
+
+void read_png_info(image_dict *, img_readtype_e);
+void read_jpg_info(image_dict *, img_readtype_e);
+void read_jbig2_info(image_dict *);
+void read_pdf_info(image_dict *, integer, integer);
+void write_img(image_dict *);
+void write_png(image_dict *);
+void write_jpg(image_dict *);
+void write_jbig2(image_dict *);
+void write_epdf(image_dict *);
+
+/* pdftoepdf.cc */
+
+void epdf_delete(image_dict * idict);
+
+#endif
diff --git a/Build/source/texk/web2c/luatexdir/image/pdftoepdf.cc b/Build/source/texk/web2c/luatexdir/image/pdftoepdf.cc
new file mode 100644
index 00000000000..c5270eb58bd
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/pdftoepdf.cc
@@ -0,0 +1,1008 @@
+/*
+Copyright 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: pdftoepdf.cc 1058 2008-02-19 21:13:58Z hhenkel $
+*/
+
+#include <stdlib.h>
+#include <math.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <aconf.h>
+#include <GString.h>
+#include <gmem.h>
+#include <gfile.h>
+#include <config.h>
+#include <assert.h>
+#include "Object.h"
+#include "Stream.h"
+#include "Array.h"
+#include "Dict.h"
+#include "XRef.h"
+#include "Catalog.h"
+#include "Link.h"
+#include "Page.h"
+#include "GfxFont.h"
+#include "PDFDoc.h"
+#include "GlobalParams.h"
+#include "Error.h"
+
+#include "epdf.h"
+
+#define one_hundred_bp 6578176 /* 7227 * 65536 / 72 */
+
+// This file is mostly C and not very much C++; it's just used to interface
+// the functions of xpdf, which happens to be written in C++.
+
+// Used flags below:
+// PDFTEX_COPY_PAGEGROUP
+// If pdfTeX should copy a page group (a new feature in PDF 1.4 for
+// transparency) of an included file. The current support for this is
+// most likely broken. pdfTeX will at least give a warning if this flag
+// is not set. Surprisingly Acrobat and Jaws display files without a
+// page group correctly, so it might be safe to not set the flag.
+// See also PDFTEX_COPY_PAGEGROUP_NOFAIL.
+// PDFTEX_COPY_PAGEGROUP_NOFAIL
+// If set to false, pdfTeX will treat a page group in an included file
+// as an error and abort gracefully. This is only evaluated if
+// PDFTEX_COPY_PAGEGROUP is set.
+
+// The prefix "PTEX" for the PDF keys is special to pdfTeX;
+// this has been registered with Adobe by Hans Hagen.
+
+#define pdfkeyprefix "PTEX"
+
+// PdfObject encapsulates the xpdf Object type,
+// and properly frees its resources on destruction.
+// Use obj-> to access members of the Object,
+// and &obj to get a pointer to the object.
+// It is no longer necessary to call Object::free explicitely.
+
+class PdfObject {
+ public:
+ PdfObject() { // nothing
+ } ~PdfObject() {
+ iObject.free();
+ }
+ Object *operator->() {
+ return &iObject;
+ }
+ Object *operator&() {
+ return &iObject;
+ }
+ private: // no copying or assigning
+ PdfObject(const PdfObject &);
+ void operator=(const PdfObject &);
+ public:
+ Object iObject;
+};
+
+// When copying the Resources of the selected page, all objects are copied
+// recusively top-down. Indirect objects however are not fetched during
+// copying, but get a new object number from pdfTeX and then will be
+// appended into a linked list. Duplicates are checked and removed from the
+// list of indirect objects during appending.
+
+enum InObjType {
+ objFont,
+ objFontDesc,
+ objOther
+};
+
+struct InObj {
+ Ref ref; // ref in original PDF
+ InObjType type; // object type
+ InObj *next; // next entry in list of indirect objects
+ integer num; // new object number in output PDF
+ fd_entry *fd; // pointer to /FontDescriptor object structure
+ integer enc_objnum; // Encoding for objFont
+ int written; // has it been written to output PDF?
+};
+
+struct UsedEncoding {
+ integer enc_objnum;
+ GfxFont *font;
+ UsedEncoding *next;
+};
+
+static InObj *inObjList;
+static UsedEncoding *encodingList;
+static GBool isInit = gFalse;
+
+// --------------------------------------------------------------------
+// Maintain list of open embedded PDF files
+// --------------------------------------------------------------------
+
+struct PdfDocument {
+ char *file_name;
+ PDFDoc *doc;
+ XRef *xref;
+ InObj *inObjList;
+ int occurences; // number of references to the document; the doc can be
+ // deleted when this is negative
+ PdfDocument *next;
+};
+
+static PdfDocument *pdfDocuments = 0;
+
+static XRef *xref = 0;
+
+// Returns pointer to PdfDocument record for PDF file.
+// Creates a new record if it doesn't exist yet.
+// xref is made current for the document.
+
+static PdfDocument *find_add_document(char *file_name)
+{
+ PdfDocument *p = pdfDocuments;
+ while (p && strcmp(p->file_name, file_name) != 0)
+ p = p->next;
+ if (p) {
+ xref = p->xref;
+ (p->occurences)++;
+#ifdef DEBUG
+ fprintf(stderr, "\npdfTeX Debug: Incrementing %s (%d)\n", p->file_name,
+ p->occurences);
+#endif
+ return p;
+ }
+ p = new PdfDocument;
+ p->file_name = xstrdup(file_name);
+ p->xref = xref = 0;
+ p->occurences = 0;
+#ifdef DEBUG
+ fprintf(stderr, "\npdfTeX Debug: Creating %s (%d)\n", p->file_name,
+ p->occurences);
+#endif
+ GString *docName = new GString(p->file_name);
+ p->doc = new PDFDoc(docName); // takes ownership of docName
+ if (!p->doc->isOk() || !p->doc->okToPrint()) {
+ pdftex_fail("xpdf: reading PDF image failed");
+ }
+ p->inObjList = 0;
+ p->next = pdfDocuments;
+ pdfDocuments = p;
+ return p;
+}
+
+// Deallocate a PdfDocument with all its resources
+
+static void delete_document(PdfDocument * pdf_doc)
+{
+ PdfDocument **p = &pdfDocuments;
+ while (*p && *p != pdf_doc)
+ p = &((*p)->next);
+ // should not happen:
+ if (!*p)
+ return;
+ // unlink from list
+ *p = pdf_doc->next;
+ // free pdf_doc's resources
+ InObj *r, *n;
+ for (r = pdf_doc->inObjList; r != 0; r = n) {
+ n = r->next;
+ delete r;
+ }
+ xref = pdf_doc->xref;
+ delete pdf_doc->doc;
+ xfree(pdf_doc->file_name);
+ delete pdf_doc;
+}
+
+// Replacement for
+// Object *initDict(Dict *dict1){ initObj(objDict); dict = dict1; return this; }
+
+static void initDictFromDict(PdfObject & obj, Dict * dict)
+{
+ obj->initDict(xref);
+ for (int i = 0, l = dict->getLength(); i < l; i++) {
+ Object obj1;
+ obj->dictAdd(copyString(dict->getKey(i)), dict->getValNF(i, &obj1));
+ }
+}
+
+// --------------------------------------------------------------------
+
+static int addEncoding(GfxFont * gfont)
+{
+ UsedEncoding *n;
+ n = new UsedEncoding;
+ n->next = encodingList;
+ encodingList = n;
+ n->font = gfont;
+ n->enc_objnum = pdf_new_objnum();
+ return n->enc_objnum;
+}
+
+#define addFont(ref, fd, enc_objnum) \
+ addInObj(objFont, ref, fd, enc_objnum)
+
+// addFontDesc is only used to avoid writing the original FontDescriptor
+// from the PDF file.
+
+#define addFontDesc(ref, fd) \
+ addInObj(objFontDesc, ref, fd, 0)
+
+#define addOther(ref) \
+ addInObj(objOther, ref, 0, 0)
+
+static int addInObj(InObjType type, Ref ref, fd_entry * fd, integer e)
+{
+ InObj *p, *q, *n = new InObj;
+ if (ref.num == 0)
+ pdftex_fail("PDF inclusion: invalid reference");
+ n->ref = ref;
+ n->type = type;
+ n->next = 0;
+ n->fd = fd;
+ n->enc_objnum = e;
+ n->written = 0;
+ if (inObjList == 0)
+ inObjList = n;
+ else {
+ for (p = inObjList; p != 0; p = p->next) {
+ if (p->ref.num == ref.num && p->ref.gen == ref.gen) {
+ delete n;
+ return p->num;
+ }
+ q = p;
+ }
+ // it is important to add new objects at the end of the list,
+ // because new objects are being added while the list is being
+ // written out.
+ q->next = n;
+ }
+ if (type == objFontDesc)
+ n->num = get_fd_objnum(fd);
+ else
+ n->num = pdf_new_objnum();
+ return n->num;
+}
+
+static void copyObject(Object *);
+
+static void copyName(char *s)
+{
+ pdf_puts("/");
+ for (; *s != 0; s++) {
+ if (isdigit(*s) || isupper(*s) || islower(*s) || *s == '_' ||
+ *s == '.' || *s == '-')
+ pdfout(*s);
+ else
+ pdf_printf("#%.2X", *s & 0xFF);
+ }
+}
+
+static void copyDictEntry(Object * obj, int i)
+{
+ PdfObject obj1;
+ copyName(obj->dictGetKey(i));
+ pdf_puts(" ");
+ obj->dictGetValNF(i, &obj1);
+ copyObject(&obj1);
+ pdf_puts("\n");
+}
+
+static void copyDict(Object * obj)
+{
+ int i, l;
+ if (!obj->isDict())
+ pdftex_fail("PDF inclusion: invalid dict type <%s>",
+ obj->getTypeName());
+ for (i = 0, l = obj->dictGetLength(); i < l; ++i)
+ copyDictEntry(obj, i);
+}
+
+static void copyFontDict(Object * obj, InObj * r)
+{
+ int i, l;
+ char *key;
+ if (!obj->isDict())
+ pdftex_fail("PDF inclusion: invalid dict type <%s>",
+ obj->getTypeName());
+ pdf_puts("<<\n");
+ assert(r->type == objFont); // FontDescriptor is in fd_tree
+ for (i = 0, l = obj->dictGetLength(); i < l; ++i) {
+ key = obj->dictGetKey(i);
+ if (strncmp("FontDescriptor", key, strlen("FontDescriptor")) == 0
+ || strncmp("BaseFont", key, strlen("BaseFont")) == 0
+ || strncmp("Encoding", key, strlen("Encoding")) == 0)
+ continue; // skip original values
+ copyDictEntry(obj, i);
+ }
+ // write new FontDescriptor, BaseFont, and Encoding
+ pdf_printf("/FontDescriptor %d 0 R\n", (int) get_fd_objnum(r->fd));
+ pdf_printf("/BaseFont %d 0 R\n", (int) get_fn_objnum(r->fd));
+ pdf_printf("/Encoding %d 0 R\n", (int) r->enc_objnum);
+ pdf_puts(">>");
+}
+
+static void copyStream(Stream * str)
+{
+ int c;
+ str->reset();
+ while ((c = str->getChar()) != EOF)
+ pdfout(c);
+ pdf_last_byte = pdf_buf[pdf_ptr - 1];
+}
+
+static void copyProcSet(Object * obj)
+{
+ int i, l;
+ PdfObject procset;
+ if (!obj->isArray())
+ pdftex_fail("PDF inclusion: invalid ProcSet array type <%s>",
+ obj->getTypeName());
+ pdf_puts("/ProcSet [ ");
+ for (i = 0, l = obj->arrayGetLength(); i < l; ++i) {
+ obj->arrayGetNF(i, &procset);
+ if (!procset->isName())
+ pdftex_fail("PDF inclusion: invalid ProcSet entry type <%s>",
+ procset->getTypeName());
+ copyName(procset->getName());
+ pdf_puts(" ");
+ }
+ pdf_puts("]\n");
+}
+
+#define REPLACE_TYPE1C true
+
+static void copyFont(char *tag, Object * fontRef)
+{
+ PdfObject fontdict, subtype, basefont, fontdescRef, fontdesc, charset,
+ fontfile, ffsubtype;
+ GfxFont *gfont;
+ fd_entry *fd;
+ fm_entry *fontmap;
+ // Check whether the font has already been embedded before analysing it.
+ InObj *p;
+ Ref ref = fontRef->getRef();
+ for (p = inObjList; p; p = p->next) {
+ if (p->ref.num == ref.num && p->ref.gen == ref.gen) {
+ copyName(tag);
+ pdf_printf(" %d 0 R ", (int) p->num);
+ return;
+ }
+ }
+ // Only handle included Type1 (and Type1C) fonts; anything else will be copied.
+ // Type1C fonts are replaced by Type1 fonts, if REPLACE_TYPE1C is true.
+ if (fixed_replace_font && fontRef->fetch(xref, &fontdict)->isDict()
+ && fontdict->dictLookup("Subtype", &subtype)->isName()
+ && !strcmp(subtype->getName(), "Type1")
+ && fontdict->dictLookup("BaseFont", &basefont)->isName()
+ && fontdict->dictLookupNF("FontDescriptor", &fontdescRef)->isRef()
+ && fontdescRef->fetch(xref, &fontdesc)->isDict()
+ && (fontdesc->dictLookup("FontFile", &fontfile)->isStream()
+ || (REPLACE_TYPE1C
+ && fontdesc->dictLookup("FontFile3", &fontfile)->isStream()
+ && fontfile->streamGetDict()->lookup("Subtype",
+ &ffsubtype)->isName()
+ && !strcmp(ffsubtype->getName(), "Type1C")))
+ && (fontmap = lookup_fontmap(basefont->getName())) != NULL) {
+ fd = epdf_create_fontdescriptor(fontmap);
+ if (fontdesc->dictLookup("CharSet", &charset) &&
+ charset->isString() && is_subsetable(fontmap))
+ epdf_mark_glyphs(fd, charset->getString()->getCString());
+ else
+ embed_whole_font(fd);
+ addFontDesc(fontdescRef->getRef(), fd);
+ copyName(tag);
+ gfont = GfxFont::makeFont(xref, tag, fontRef->getRef(),
+ fontdict->getDict());
+ pdf_printf(" %d 0 R ", addFont(fontRef->getRef(), fd,
+ addEncoding(gfont)));
+ } else {
+ copyName(tag);
+ pdf_puts(" ");
+ copyObject(fontRef);
+ }
+}
+
+static void copyFontResources(Object * obj)
+{
+ PdfObject fontRef;
+ int i, l;
+ if (!obj->isDict())
+ pdftex_fail("PDF inclusion: invalid font resources dict type <%s>",
+ obj->getTypeName());
+ pdf_puts("/Font << ");
+ for (i = 0, l = obj->dictGetLength(); i < l; ++i) {
+ obj->dictGetValNF(i, &fontRef);
+ if (fontRef->isRef())
+ copyFont(obj->dictGetKey(i), &fontRef);
+ else
+ pdftex_fail("PDF inclusion: invalid font in reference type <%s>",
+ fontRef->getTypeName());
+ }
+ pdf_puts(">>\n");
+}
+
+static void copyOtherResources(Object * obj, char *key)
+{
+ // copies all other resources (write_epdf handles Fonts and ProcSets),
+ // but gives a warning if an object is not a dictionary.
+
+ if (!obj->isDict())
+ //FIXME: Write the message only to the log file
+ pdftex_warn("PDF inclusion: invalid other resource which is no dict"
+ " (key '%s', type <%s>); copying it anyway.",
+ key, obj->getTypeName());
+ copyName(key);
+ pdf_puts(" ");
+ copyObject(obj);
+}
+
+// Function onverts double to string; very small and very large numbers
+// are NOT converted to scientific notation.
+// n must be a number or real conforming to the implementation limits
+// of PDF as specified in appendix C.1 of the PDF Ref.
+// These are:
+// maximum value of ints is +2^32
+// maximum value of reals is +2^15
+// smalles values of reals is 1/(2^16)
+
+static char *convertNumToPDF(double n)
+{
+ static const int precision = 6;
+ static const int fact = (int) 1E6; // must be 10^precision
+ static const double epsilon = 0.5E-6; // 2epsilon must be 10^-precision
+ static char buf[64];
+ // handle very small values: return 0
+ if (fabs(n) < epsilon) {
+ buf[0] = '0';
+ buf[1] = '\0';
+ } else {
+ char ints[64];
+ int bindex = 0, sindex = 0;
+ int ival, fval;
+ // handle the sign part if n is negative
+ if (n < 0) {
+ buf[bindex++] = '-';
+ n = -n;
+ }
+ n += epsilon; // for rounding
+ // handle the integer part, simply with sprintf
+ ival = (int) floor(n);
+ n -= ival;
+ sprintf(ints, "%d", ival);
+ while (ints[sindex] != 0)
+ buf[bindex++] = ints[sindex++];
+ // handle the fractional part up to 'precision' digits
+ fval = (int) floor(n * fact);
+ if (fval) {
+ // set a dot
+ buf[bindex++] = '.';
+ sindex = bindex + precision;
+ buf[sindex--] = '\0';
+ // fill up trailing zeros with the string terminator NULL
+ while (((fval % 10) == 0) && (sindex >= bindex)) {
+ buf[sindex--] = '\0';
+ fval /= 10;
+ }
+ // fill up the fractional part back to front
+ while (sindex >= bindex) {
+ buf[sindex--] = (fval % 10) + '0';
+ fval /= 10;
+ }
+ } else
+ buf[bindex++] = 0;
+ }
+ return (char *) buf;
+}
+
+static void copyObject(Object * obj)
+{
+ PdfObject obj1;
+ int i, l, c;
+ Ref ref;
+ char *p;
+ GString *s;
+ if (obj->isBool()) {
+ pdf_printf("%s", obj->getBool()? "true" : "false");
+ } else if (obj->isInt()) {
+ pdf_printf("%i", obj->getInt());
+ } else if (obj->isReal()) {
+ pdf_printf("%s", convertNumToPDF(obj->getReal()));
+ } else if (obj->isNum()) {
+ pdf_printf("%s", convertNumToPDF(obj->getNum()));
+ } else if (obj->isString()) {
+ s = obj->getString();
+ p = s->getCString();
+ l = s->getLength();
+ if (strlen(p) == (unsigned int) l) {
+ pdf_puts("(");
+ for (; *p != 0; p++) {
+ c = (unsigned char) *p;
+ if (c == '(' || c == ')' || c == '\\')
+ pdf_printf("\\%c", c);
+ else if (c < 0x20 || c > 0x7F)
+ pdf_printf("\\%03o", c);
+ else
+ pdfout(c);
+ }
+ pdf_puts(")");
+ } else {
+ pdf_puts("<");
+ for (i = 0; i < l; i++) {
+ c = s->getChar(i) & 0xFF;
+ pdf_printf("%.2x", c);
+ }
+ pdf_puts(">");
+ }
+ } else if (obj->isName()) {
+ copyName(obj->getName());
+ } else if (obj->isNull()) {
+ pdf_puts("null");
+ } else if (obj->isArray()) {
+ pdf_puts("[");
+ for (i = 0, l = obj->arrayGetLength(); i < l; ++i) {
+ obj->arrayGetNF(i, &obj1);
+ if (!obj1->isName())
+ pdf_puts(" ");
+ copyObject(&obj1);
+ }
+ pdf_puts("]");
+ } else if (obj->isDict()) {
+ pdf_puts("<<\n");
+ copyDict(obj);
+ pdf_puts(">>");
+ } else if (obj->isStream()) {
+ initDictFromDict(obj1, obj->streamGetDict());
+ obj->streamGetDict()->incRef();
+ pdf_puts("<<\n");
+ copyDict(&obj1);
+ pdf_puts(">>\n");
+ pdf_puts("stream\n");
+ copyStream(obj->getStream()->getBaseStream());
+ if (pdf_last_byte != '\n')
+ pdf_puts("\n");
+ pdf_puts("endstream"); // can't simply write pdf_end_stream()
+ } else if (obj->isRef()) {
+ ref = obj->getRef();
+ if (ref.num == 0) {
+ pdftex_warn
+ ("PDF inclusion: reference to invalid object was replaced by <null>");
+ pdf_puts("null");
+ } else
+ pdf_printf("%d 0 R", addOther(ref));
+ } else {
+ pdftex_fail("PDF inclusion: type <%s> cannot be copied",
+ obj->getTypeName());
+ }
+}
+
+static void writeRefs()
+{
+ InObj *r;
+ for (r = inObjList; r != 0; r = r->next) {
+ if (!r->written) {
+ Object obj1;
+ r->written = 1;
+ xref->fetch(r->ref.num, r->ref.gen, &obj1);
+ if (r->type == objFont) {
+ assert(!obj1.isStream());
+ zpdf_begin_obj(r->num, 2); // \pdfobjcompresslevel = 2 is for this
+ copyFontDict(&obj1, r);
+ pdf_puts("\n");
+ pdf_end_obj();
+ } else if (r->type != objFontDesc) { // /FontDescriptor is written via write_fontdescriptor()
+ if (obj1.isStream())
+ zpdf_begin_obj(r->num, 0);
+ else
+ zpdf_begin_obj(r->num, 2); // \pdfobjcompresslevel = 2 is for this
+ copyObject(&obj1);
+ pdf_puts("\n");
+ pdf_end_obj();
+ }
+ obj1.free();
+ }
+ }
+}
+
+static void writeEncodings()
+{
+ UsedEncoding *r, *n;
+ char *glyphNames[256], *s;
+ int i;
+ for (r = encodingList; r != 0; r = r->next) {
+ for (i = 0; i < 256; i++) {
+ if (r->font->isCIDFont()) {
+ pdftex_warn
+ ("PDF inclusion: CID font included, encoding maybe wrong");
+ }
+ if ((s = ((Gfx8BitFont *) r->font)->getCharName(i)) != 0)
+ glyphNames[i] = s;
+ else
+ glyphNames[i] = notdef;
+ }
+ epdf_write_enc(glyphNames, r->enc_objnum);
+ }
+ for (r = encodingList; r != 0; r = n) {
+ n = r->next;
+ delete r->font;
+ delete r;
+ }
+}
+
+// get the pagebox according to the pagebox_spec
+
+static PDFRectangle *get_pagebox(Page * page, integer pagebox_spec)
+{
+ if (pagebox_spec == pdf_box_spec_media)
+ return page->getMediaBox();
+ else if (pagebox_spec == pdf_box_spec_crop)
+ return page->getCropBox();
+ else if (pagebox_spec == pdf_box_spec_bleed)
+ return page->getBleedBox();
+ else if (pagebox_spec == pdf_box_spec_trim)
+ return page->getTrimBox();
+ else if (pagebox_spec == pdf_box_spec_art)
+ return page->getArtBox();
+ else
+ pdftex_fail("PDF inclusion: unknown value of pagebox spec (%i)",
+ (int) pagebox_spec);
+ return page->getMediaBox(); // to make the compiler happy
+}
+
+
+// Reads various information about the PDF and sets it up for later inclusion.
+// This will fail if the PDF version of the PDF is higher than
+// minor_pdf_version_wanted or page_name is given and can not be found.
+// It makes no sense to give page_name _and_ page_num.
+// Returns the page number.
+
+void
+read_pdf_info(image_dict * idict, integer minor_pdf_version_wanted,
+ integer pdf_inclusion_errorlevel)
+{
+ PdfDocument *pdf_doc;
+ Page *page;
+ int rotate;
+ PDFRectangle *pagebox;
+ float pdf_version_found, pdf_version_wanted;
+ assert(idict != NULL);
+ assert(img_type(idict) == IMAGE_TYPE_PDF);
+ assert(img_pdf_ptr(idict) == NULL);
+ img_pdf_ptr(idict) = new_pdf_img_struct();
+ // initialize
+ if (!isInit) {
+ globalParams = new GlobalParams();
+ globalParams->setErrQuiet(gFalse);
+ isInit = gTrue;
+ }
+ // open PDF file
+ pdf_doc = find_add_document(img_filepath(idict));
+ img_pdf_doc(idict) = pdf_doc;
+
+ // check PDF version
+ // this works only for PDF 1.x -- but since any versions of PDF newer
+ // than 1.x will not be backwards compatible to PDF 1.x, pdfTeX will
+ // then have to changed drastically anyway.
+ pdf_version_found = pdf_doc->doc->getPDFVersion();
+ pdf_version_wanted = 1 + (minor_pdf_version_wanted * 0.1);
+ if (pdf_version_found > pdf_version_wanted) {
+ char msg[] =
+ "PDF inclusion: found PDF version <%.1f>, but at most version <%.1f> allowed";
+ if (pdf_inclusion_errorlevel > 0) {
+ pdftex_fail(msg, pdf_version_found, pdf_version_wanted);
+ } else {
+ pdftex_warn(msg, pdf_version_found, pdf_version_wanted);
+ }
+ }
+ img_totalpages(idict) = pdf_doc->doc->getCatalog()->getNumPages();
+ if (img_pagename(idict)) {
+ // get page by name
+ GString name(img_pagename(idict));
+ LinkDest *link = pdf_doc->doc->findDest(&name);
+ if (link == 0 || !link->isOk())
+ pdftex_fail("PDF inclusion: invalid destination <%s>",
+ img_pagename(idict));
+ Ref ref = link->getPageRef();
+ img_pagenum(idict) =
+ pdf_doc->doc->getCatalog()->findPage(ref.num, ref.gen);
+ if (img_pagenum(idict) == 0)
+ pdftex_fail("PDF inclusion: destination is not a page <%s>",
+ img_pagename(idict));
+ delete link;
+ } else {
+ // get page by number
+ if (img_pagenum(idict) <= 0
+ || img_pagenum(idict) > img_totalpages(idict))
+ pdftex_fail("PDF inclusion: required page <%i> does not exist",
+ (int) img_pagenum(idict));
+ }
+ // get the required page
+ page = pdf_doc->doc->getCatalog()->getPage(img_pagenum(idict));
+
+ // get the pagebox (media, crop...) to use.
+ pagebox = get_pagebox(page, img_pagebox(idict));
+ if (pagebox->x2 > pagebox->x1) {
+ img_pdf_orig_x(idict) = pagebox->x1;
+ img_pdf_width(idict) = pagebox->x2 - pagebox->x1;
+ } else {
+ img_pdf_orig_x(idict) = pagebox->x2;
+ img_pdf_width(idict) = pagebox->x1 - pagebox->x2;
+ }
+ if (pagebox->y2 > pagebox->y1) {
+ img_pdf_orig_y(idict) = pagebox->y1;
+ img_pdf_height(idict) = pagebox->y2 - pagebox->y1;
+ } else {
+ img_pdf_orig_y(idict) = pagebox->y2;
+ img_pdf_height(idict) = pagebox->y1 - pagebox->y2;
+ }
+
+ rotate = page->getRotate();
+ // handle page rotation and adjust dimens as needed
+ if (rotate != 0) {
+ if (rotate % 90 == 0) {
+ // handle only the simple case: multiple of 90s.
+ // these are the only values allowed according to the
+ // reference (v1.3, p. 78).
+ // 180 needs no special treatment here
+ register float f;
+ switch (rotate) {
+ case 90:
+ f = img_pdf_height(idict);
+ img_pdf_height(idict) = img_pdf_width(idict);
+ img_pdf_width(idict) = f;
+ break;
+ case 270:
+ f = img_pdf_height(idict);
+ img_pdf_height(idict) = img_pdf_width(idict);
+ img_pdf_width(idict) = f;
+ break;
+ }
+ }
+ }
+ pdf_doc->xref = pdf_doc->doc->getXRef();
+ img_xsize(idict) = bp2int(img_pdf_width(idict));
+ img_ysize(idict) = bp2int(img_pdf_height(idict));
+}
+
+// writes the current epf_doc.
+// Here the included PDF is copied, so most errors that can happen during PDF
+// inclusion will arise here.
+
+void write_epdf(image_dict * idict)
+{
+ Page *page;
+ PdfObject contents, obj1, obj2;
+ PdfObject group, metadata, pieceinfo, separationInfo;
+ Object info;
+ char *key;
+ char s[256];
+ int i, l;
+ int rotate;
+ double scale[6] = { 0, 0, 0, 0, 0, 0 };
+ bool writematrix = false;
+ PdfDocument *pdf_doc = (PdfDocument *) img_pdf_doc(idict);
+ (pdf_doc->occurences)--;
+#ifdef DEBUG
+ fprintf(stderr, "\npdfTeX Debug: Decrementing %s (%d)\n",
+ pdf_doc->file_name, pdf_doc->occurences);
+#endif
+ xref = pdf_doc->xref;
+ inObjList = pdf_doc->inObjList;
+ encodingList = 0;
+ page = pdf_doc->doc->getCatalog()->getPage(img_pagenum(idict));
+ rotate = page->getRotate();
+ PDFRectangle *pagebox;
+ // write the Page header
+ pdf_puts("/Type /XObject\n/Subtype /Form\n");
+ if (img_attr(idict) != NULL && strlen(img_attr(idict)) > 0)
+ pdf_printf("%s\n", img_attr(idict));
+ pdf_puts("/FormType 1\n");
+
+ // write additional information
+ pdf_printf("/%s.FileName (%s)\n", pdfkeyprefix,
+ convertStringToPDFString(pdf_doc->file_name,
+ strlen(pdf_doc->file_name)));
+ pdf_printf("/%s.PageNumber %i\n", pdfkeyprefix, (int) img_pagenum(idict));
+ pdf_doc->doc->getDocInfoNF(&info);
+ if (info.isRef()) {
+ // the info dict must be indirect (PDF Ref p. 61)
+ pdf_printf("/%s.InfoDict ", pdfkeyprefix);
+ pdf_printf("%d 0 R\n", addOther(info.getRef()));
+ }
+ // get the pagebox (media, crop...) to use.
+ pagebox = get_pagebox(page, img_pagebox(idict));
+
+ // handle page rotation
+ if (rotate != 0) {
+ if (rotate % 90 == 0) {
+ // this handles only the simple case: multiple of 90s but these
+ // are the only values allowed according to the reference
+ // (v1.3, p. 78).
+ // the image is rotated around its center.
+ // the /Rotate key is clockwise while the matrix is
+ // counterclockwise :-%
+ tex_printf(", page is rotated %d degrees", rotate);
+ switch (rotate) {
+ case 90:
+ scale[1] = -1;
+ scale[2] = 1;
+ scale[4] = pagebox->x1 - pagebox->y1;
+ scale[5] = pagebox->y1 + pagebox->x2;
+ writematrix = true;
+ break;
+ case 180:
+ scale[0] = scale[3] = -1;
+ scale[4] = pagebox->x1 + pagebox->x2;
+ scale[5] = pagebox->y1 + pagebox->y2;
+ writematrix = true;
+ break; // width and height are exchanged
+ case 270:
+ scale[1] = 1;
+ scale[2] = -1;
+ scale[4] = pagebox->x1 + pagebox->y2;
+ scale[5] = pagebox->y1 - pagebox->x1;
+ writematrix = true;
+ break;
+ }
+ if (writematrix) { // The matrix is only written if the image is rotated.
+ sprintf(s, "/Matrix [%.8f %.8f %.8f %.8f %.8f %.8f]\n",
+ scale[0],
+ scale[1], scale[2], scale[3], scale[4], scale[5]);
+ pdf_printf(stripzeros(s));
+ }
+ }
+ }
+
+ sprintf(s, "/BBox [%.8f %.8f %.8f %.8f]\n",
+ pagebox->x1, pagebox->y1, pagebox->x2, pagebox->y2);
+ pdf_printf(stripzeros(s));
+
+ // write the page Group if it's there
+ if (page->getGroup() != NULL) {
+#if PDFTEX_COPY_PAGEGROUP
+# if PDFTEX_COPY_PAGEGROUP_NOFAIL
+ // FIXME: This will most likely produce incorrect PDFs :-(
+ initDictFromDict(group, page->getGroup());
+ if (group->dictGetLength() > 0) {
+ pdf_puts("/Group ");
+ copyObject(&group);
+ pdf_puts("\n");
+ }
+# else
+ // FIXME: currently we don't know how to handle Page Groups so we abort gracefully :-(
+ pdftex_fail
+ ("PDF inclusion: Page Group detected which pdfTeX can't handle. Sorry.");
+# endif
+#else
+ // FIXME: currently we don't know how to handle Page Groups so we at least give a warning :-(
+ pdftex_warn
+ ("PDF inclusion: Page Group detected which pdfTeX can't handle. Ignoring it.");
+#endif
+ }
+ // write the page Metadata if it's there
+ if (page->getMetadata() != NULL) {
+ metadata->initStream(page->getMetadata());
+ pdf_puts("/Metadata ");
+ copyObject(&metadata);
+ pdf_puts("\n");
+ }
+ // write the page PieceInfo if it's there
+ if (page->getPieceInfo() != NULL) {
+ initDictFromDict(pieceinfo, page->getPieceInfo());
+ if (pieceinfo->dictGetLength() > 0) {
+ pdf_puts("/PieceInfo ");
+ copyObject(&pieceinfo);
+ pdf_puts("\n");
+ }
+ }
+ // write the page SeparationInfo if it's there
+ if (page->getSeparationInfo() != NULL) {
+ initDictFromDict(separationInfo, page->getSeparationInfo());
+ if (separationInfo->dictGetLength() > 0) {
+ pdf_puts("/SeparationInfo ");
+ copyObject(&separationInfo);
+ pdf_puts("\n");
+ }
+ }
+ // write the Resources dictionary
+ if (page->getResourceDict() == NULL) {
+ // Resources can be missing (files without them have been spotted
+ // in the wild). This violates the PDF Ref., which claims they are
+ // required, but all RIPs accept them.
+ // We "replace" them with empty /Resources, although in form xobjects
+ // /Resources are not required.
+ pdftex_warn
+ ("PDF inclusion: no /Resources detected. Replacing with empty /Resources.");
+ pdf_puts("/Resources <<>>\n");
+ } else {
+ initDictFromDict(obj1, page->getResourceDict());
+ page->getResourceDict()->incRef();
+ if (!obj1->isDict())
+ pdftex_fail("PDF inclusion: invalid resources dict type <%s>",
+ obj1->getTypeName());
+ pdf_puts("/Resources <<\n");
+ for (i = 0, l = obj1->dictGetLength(); i < l; ++i) {
+ obj1->dictGetVal(i, &obj2);
+ key = obj1->dictGetKey(i);
+ if (strcmp("Font", key) == 0)
+ copyFontResources(&obj2);
+ else if (strcmp("ProcSet", key) == 0)
+ copyProcSet(&obj2);
+ else
+ copyOtherResources(&obj2, key);
+ }
+ pdf_puts(">>\n");
+ }
+ // write the page contents
+ page->getContents(&contents);
+ if (contents->isStream()) {
+ initDictFromDict(obj1, contents->streamGetDict());
+ contents->streamGetDict()->incRef();
+ copyDict(&obj1);
+ pdf_puts(">>\nstream\n");
+ copyStream(contents->getStream()->getBaseStream());
+ pdf_end_stream();
+ } else if (contents->isArray()) {
+ pdf_begin_stream();
+ for (i = 0, l = contents->arrayGetLength(); i < l; ++i) {
+ Object contentsobj;
+ copyStream((contents->arrayGet(i, &contentsobj))->getStream());
+ contentsobj.free();
+ }
+ pdf_end_stream();
+ } else { // the contents are optional, but we need to include an empty stream
+ pdf_begin_stream();
+ pdf_end_stream();
+ }
+ // write out all indirect objects
+ writeRefs();
+ // write out all used encodings (and delete list)
+ writeEncodings();
+ // save object list, xref
+ pdf_doc->inObjList = inObjList;
+ pdf_doc->xref = xref;
+}
+
+// Called when an image has been written and it's resources in image_tab are
+// freed and it's not referenced anymore.
+
+void epdf_delete(image_dict * idict)
+{
+ PdfDocument *pdf_doc = (PdfDocument *) img_pdf_doc(idict);
+ xref = pdf_doc->xref;
+ if (pdf_doc->occurences < 0) {
+#ifdef DEBUG
+ fprintf(stderr, "\npdfTeX Debug: Deleting %s\n", pdf_doc->file_name);
+#endif
+ delete_document(pdf_doc);
+ }
+ img_pdf_doc(idict) = NULL;
+}
+
+// Called when PDF embedding system is finalized.
+// Now deallocate all remaining PdfDocuments.
+
+void epdf_check_mem()
+{
+ if (isInit) {
+ PdfDocument *p, *n;
+ for (p = pdfDocuments; p; p = n) {
+ n = p->next;
+ delete_document(p);
+ }
+ // see above for globalParams
+ delete globalParams;
+ }
+}
diff --git a/Build/source/texk/web2c/luatexdir/image/writeimg.c b/Build/source/texk/web2c/luatexdir/image/writeimg.c
new file mode 100644
index 00000000000..66eb459bc0c
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/writeimg.c
@@ -0,0 +1,677 @@
+/*
+Copyright (c) 1996-2002, 2005 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+pdfTeX is free software;
+you can redistribute it and / or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writeimg.c 1119 2008-03-22 11:27:02Z hhenkel $
+*/
+
+#include <assert.h>
+#include "ptexlib.h"
+#include <kpathsea/c-auto.h>
+#include <kpathsea/c-memstr.h>
+
+#include "image.h"
+
+#include <../lua51/lua.h>
+#include <../lua51/lauxlib.h>
+
+extern void pdf_print_real(integer m, integer d);
+
+#define obj_aux(A) obj_tab[(A)].int4
+
+/**********************************************************************/
+/*
+ Patch ImageTypeDetection 2003/02/08 by Heiko Oberdiek.
+
+ Function "readimage" performs some basic initializations.
+ Then it looks at the file extension to determine the
+ image type and calls specific code/functions.
+ The main disadvantage is that standard file extensions
+ have to be used, otherwise pdfTeX is not able to detect
+ the correct image type.
+
+ The patch now looks at the file header first regardless of
+ the file extension. This is implemented in function
+ "check_type_by_header". If this check fails, the traditional
+ test of standard file extension is tried, done in function
+ "check_type_by_extension".
+
+ Magic headers:
+
+ * "PNG (Portable Network Graphics) Specification", Version 1.2
+ (http://www.libpng.org/pub/png):
+
+ | 3.1. PNG file signature
+ |
+ | The first eight bytes of a PNG file always contain the following
+ | (decimal) values:
+ |
+ | 137 80 78 71 13 10 26 10
+
+ Translation to C: "\x89PNG\r\n\x1A\n"
+
+ * "JPEG File Interchange Format", Version 1.02:
+
+ | o you can identify a JFIF file by looking for the following
+ | sequence: X'FF', SOI X'FF', APP0, <2 bytes to be skipped>,
+ | "JFIF", X'00'.
+
+ Function "check_type_by_header" only looks at the first two bytes:
+ "\xFF\xD8"
+
+ * ISO/IEC JTC 1/SC 29/WG 1
+ (ITU-T SG8)
+ Coding of Still Pictures
+ Title: 14492 FCD
+ Source: JBIG Committee
+ Project: JTC 1.29.10
+ Status: Final Committee Draft
+
+ | D.4.1, ID string
+ |
+ | This is an 8-byte sequence containing 0x97 0x4A 0x42 0x32 0x0D 0x0A
+ | 0x1A 0x0A.
+
+ * "PDF Reference", third edition:
+ * The first line should contain "%PDF-1.0" until "%PDF-1.4"
+ (section 3.4.1 "File Header").
+ * The "implementation notes" say:
+
+ | 3.4.1, File Header
+ | 12. Acrobat viewers require only that the header appear
+ | somewhere within the first 1024 bytes of the file.
+ | 13. Acrobat viewers will also accept a header of the form
+ | %!PS-Adobe-N.n PDF-M.m
+
+ The check in function "check_type_by_header" only implements
+ the first issue. The implementation notes are not considered.
+ Therefore files with garbage at start of file must have the
+ standard extension.
+
+ Functions "check_type_by_header" and "check_type_by_extension":
+ img_type(img) is set to IMAGE_TYPE_NONE by new_image_dict().
+ Both functions try to detect a type and set img_type(img).
+ Thus a value other than IMAGE_TYPE_NONE indicates that a
+ type has been found.
+*/
+
+#define HEADER_JPG "\xFF\xD8"
+#define HEADER_PNG "\x89PNG\r\n\x1A\n"
+#define HEADER_JBIG2 "\x97\x4A\x42\x32\x0D\x0A\x1A\x0A"
+#define HEADER_PDF "%PDF-1."
+#define MAX_HEADER (sizeof(HEADER_PNG)-1)
+
+static void check_type_by_header(image_dict * idict)
+{
+ int i;
+ FILE *file = NULL;
+ char header[MAX_HEADER];
+
+ assert(idict != NULL);
+ if (img_type(idict) != IMAGE_TYPE_NONE) /* nothing to do */
+ return;
+ /* read the header */
+ file = xfopen(img_filepath(idict), FOPEN_RBIN_MODE);
+ for (i = 0; (unsigned) i < MAX_HEADER; i++) {
+ header[i] = xgetc(file);
+ if (feof(file))
+ pdftex_fail("reading image file failed");
+ }
+ xfclose(file, img_filepath(idict));
+ /* tests */
+ if (strncmp(header, HEADER_JPG, sizeof(HEADER_JPG) - 1) == 0)
+ img_type(idict) = IMAGE_TYPE_JPG;
+ else if (strncmp(header, HEADER_PNG, sizeof(HEADER_PNG) - 1) == 0)
+ img_type(idict) = IMAGE_TYPE_PNG;
+ else if (strncmp(header, HEADER_JBIG2, sizeof(HEADER_JBIG2) - 1) == 0)
+ img_type(idict) = IMAGE_TYPE_JBIG2;
+ else if (strncmp(header, HEADER_PDF, sizeof(HEADER_PDF) - 1) == 0)
+ img_type(idict) = IMAGE_TYPE_PDF;
+}
+
+static void check_type_by_extension(image_dict * idict)
+{
+ char *image_suffix;
+
+ assert(idict != NULL);
+ if (img_type(idict) != IMAGE_TYPE_NONE) /* nothing to do */
+ return;
+ /* tests */
+ if ((image_suffix = strrchr(img_filename(idict), '.')) == 0)
+ img_type(idict) = IMAGE_TYPE_NONE;
+ else if (strcasecmp(image_suffix, ".png") == 0)
+ img_type(idict) = IMAGE_TYPE_PNG;
+ else if (strcasecmp(image_suffix, ".jpg") == 0 ||
+ strcasecmp(image_suffix, ".jpeg") == 0)
+ img_type(idict) = IMAGE_TYPE_JPG;
+ else if (strcasecmp(image_suffix, ".jbig2") == 0 ||
+ strcasecmp(image_suffix, ".jb2") == 0)
+ img_type(idict) = IMAGE_TYPE_JBIG2;
+ else if (strcasecmp(image_suffix, ".pdf") == 0)
+ img_type(idict) = IMAGE_TYPE_PDF;
+}
+
+/**********************************************************************/
+
+pdf_img_struct *new_pdf_img_struct()
+{
+ pdf_img_struct *p;
+ p = xtalloc(1, pdf_img_struct);
+ p->width = 0;
+ p->height = 0;
+ p->orig_x = 0;
+ p->orig_y = 0;
+ p->doc = NULL;
+ return p;
+}
+
+void init_image(image * p)
+{
+ assert(p != NULL);
+ set_wd_running(p);
+ set_ht_running(p);
+ set_dp_running(p);
+ img_transform(p) = 0;
+ img_flags(p) = 0;
+ img_unset_refered(p); /* wd/ht/dp may be modified */
+ img_unset_scaled(p);
+ img_dict(p) = NULL;
+ img_dictref(p) = LUA_NOREF;
+}
+
+image *new_image()
+{
+ image *p = xtalloc(1, image);
+ init_image(p);
+ return p;
+}
+
+void init_image_dict(image_dict * p)
+{
+ assert(p != NULL);
+ img_objnum(p) = 0;
+ img_index(p) = 0;
+ img_xsize(p) = 0;
+ img_ysize(p) = 0;
+ img_xres(p) = 0;
+ img_yres(p) = 0;
+ img_colorspace(p) = 0;
+ img_totalpages(p) = 0;
+ img_pagenum(p) = 1;
+ img_pagename(p) = NULL;
+ img_filename(p) = NULL;
+ img_filepath(p) = NULL;
+ img_attr(p) = NULL;
+ img_file(p) = NULL;
+ img_type(p) = IMAGE_TYPE_NONE;
+ img_color(p) = 0;
+ img_colordepth(p) = 0;
+ img_pagebox(p) = PDF_BOX_SPEC_MEDIA;
+ img_state(p) = DICT_NEW;
+ img_pdf_ptr(p) = NULL; /* union */
+}
+
+image_dict *new_image_dict()
+{
+ image_dict *p = xtalloc(1, image_dict);
+ init_image_dict(p);
+ return p;
+}
+
+void free_dict_strings(image_dict * p)
+{
+ if (img_filename(p) != NULL)
+ xfree(img_filename(p));
+ img_filename(p) = NULL;
+ if (img_filepath(p) != NULL)
+ xfree(img_filepath(p));
+ img_filepath(p) = NULL;
+ if (img_attr(p) != NULL)
+ xfree(img_attr(p));
+ img_attr(p) = NULL;
+ if (img_pagename(p) != NULL)
+ xfree(img_pagename(p));
+ img_pagename(p) = NULL;
+}
+
+void free_image_dict(image_dict * p)
+{
+ free_dict_strings(p);
+ if (img_type(p) == IMAGE_TYPE_PDF)
+ epdf_delete(p);
+ assert(img_file(p) == NULL);
+ xfree(p);
+}
+
+/**********************************************************************/
+
+void pdf_print_resname_prefix()
+{
+ if (pdf_resname_prefix != 0)
+ pdf_printf(makecstring(pdf_resname_prefix));
+}
+
+void read_img(image_dict * idict, integer pdf_minor_version,
+ integer pdf_inclusion_errorlevel)
+{
+ char *filepath;
+ int callback_id;
+ assert(idict != NULL);
+ if (img_filename(idict) == NULL)
+ pdftex_fail("image file name missing");
+ callback_id = callback_defined(find_image_file_callback);
+ if (img_filepath(idict) == NULL) {
+ if (callback_id > 0
+ && run_callback(callback_id, "S->S", img_filename(idict),
+ &filepath)) {
+ if (filepath && (strlen(filepath) > 0))
+ img_filepath(idict) = strdup(filepath);
+ } else
+ img_filepath(idict) =
+ kpse_find_file(img_filename(idict), kpse_tex_format, true);
+ }
+ if (img_filepath(idict) == NULL)
+ pdftex_fail("cannot find image file");
+ /* type checks */
+ check_type_by_header(idict);
+ check_type_by_extension(idict);
+ /* read image */
+ switch (img_type(idict)) {
+ case IMAGE_TYPE_PDF:
+ read_pdf_info(idict, pdf_minor_version, pdf_inclusion_errorlevel);
+ break;
+ case IMAGE_TYPE_PNG:
+ read_png_info(idict, IMG_CLOSEINBETWEEN);
+ break;
+ case IMAGE_TYPE_JPG:
+ read_jpg_info(idict, IMG_CLOSEINBETWEEN);
+ break;
+ case IMAGE_TYPE_JBIG2:
+ if (pdf_minor_version < 4) {
+ pdftex_fail
+ ("JBIG2 images only possible with at least PDF 1.4; you are generating PDF 1.%i",
+ (int) pdf_minor_version);
+ }
+ read_jbig2_info(idict);
+ break;
+ default:
+ pdftex_fail("internal error: unknown image type");
+ }
+ cur_file_name = NULL;
+ if (img_state(idict) < DICT_FILESCANNED)
+ img_state(idict) = DICT_FILESCANNED;
+}
+
+void scale_img(image * img)
+{
+ integer x, y, xr, yr; /* size and resolution of image */
+ scaled w, h; /* indeed size corresponds to image resolution */
+ integer default_res;
+ assert(img != NULL);
+ image_dict *idict = img_dict(img);
+ assert(idict != NULL);
+ x = img_xsize(idict); /* dimensions, resolutions from image file */
+ y = img_ysize(idict);
+ xr = img_xres(idict);
+ yr = img_yres(idict);
+ if ((img_transform(img) & 1) == 1) {
+ int tmp = x;
+ x = y;
+ y = tmp;
+ tmp = xr;
+ xr = yr;
+ yr = tmp;
+ }
+ if (xr > 65535 || yr > 65535) {
+ xr = 0;
+ yr = 0;
+ pdftex_warn("ext1: too large image resolution ignored");
+ }
+ if (x <= 0 || y <= 0 || xr < 0 || yr < 0)
+ pdftex_fail("ext1: invalid image dimensions");
+ if (img_type(idict) == IMAGE_TYPE_PDF) {
+ w = x;
+ h = y;
+ } else {
+ default_res = fix_int(get_pdf_image_resolution(), 0, 65535);
+ if (default_res > 0 && (xr == 0 || yr == 0)) {
+ xr = default_res;
+ yr = default_res;
+ }
+ if (is_wd_running(img) && is_ht_running(img)) {
+ if (xr > 0 && yr > 0) {
+ w = ext_xn_over_d(one_hundred_inch, x, 100 * xr);
+ h = ext_xn_over_d(one_hundred_inch, y, 100 * yr);
+ } else {
+ w = ext_xn_over_d(one_hundred_inch, x, 7200);
+ h = ext_xn_over_d(one_hundred_inch, y, 7200);
+ }
+ }
+ }
+ if (is_wd_running(img) && is_ht_running(img) && is_dp_running(img)) {
+ img_width(img) = w;
+ img_height(img) = h;
+ img_depth(img) = 0;
+ } else if (is_wd_running(img)) {
+ /* image depth or height is explicitly specified */
+ if (is_ht_running(img)) {
+ /* image depth is explicitly specified */
+ img_width(img) = ext_xn_over_d(h, x, y);
+ img_height(img) = h - img_depth(img);
+ } else if (is_dp_running(img)) {
+ /* image height is explicitly specified */
+ img_width(img) = ext_xn_over_d(img_height(img), x, y);
+ img_depth(img) = 0;
+ } else {
+ /* both image depth and height are explicitly specified */
+ img_width(img) =
+ ext_xn_over_d(img_height(img) + img_depth(img), x, y);
+ }
+ } else {
+ /* image width is explicitly specified */
+ if (is_ht_running(img) && is_dp_running(img)) {
+ /* both image depth and height are not specified */
+ img_height(img) = ext_xn_over_d(img_width(img), y, x);
+ img_depth(img) = 0;
+ }
+ /* image depth is explicitly specified */
+ else if (is_ht_running(img)) {
+ img_height(img) =
+ ext_xn_over_d(img_width(img), y, x) - img_depth(img);
+ }
+ /* image height is explicitly specified */
+ else if (is_dp_running(img)) {
+ img_depth(img) = 0;
+ }
+ /* else both image depth and height are explicitly specified */
+ }
+ img_set_scaled(img);
+}
+
+void out_img(image * img, scaled hpos, scaled vpos)
+{
+ float a[7]; /* transformation matrix (todo: indices should be reduced!) */
+ int r; /* number of digits after the decimal point */
+ assert(img != 0);
+ image_dict *idict = img_dict(img);
+ assert(idict != 0);
+ scaled wd = img_width(img);
+ scaled ht = img_height(img);
+ scaled dp = img_depth(img);
+ if (img_type(idict) == IMAGE_TYPE_PDF) {
+ a[1] = wd * 1.0e6 / img_xsize(idict);
+ a[2] = 0;
+ a[3] = 0;
+ a[4] = (ht + dp) * 1.0e6 / img_ysize(idict);
+ a[5] = hpos -
+ (float) wd *bp2int(img_pdf_orig_x(idict)) / img_xsize(idict);
+ a[6] = vpos -
+ (float) ht *bp2int(img_pdf_orig_y(idict)) / img_ysize(idict);
+ r = 6;
+ } else {
+ a[1] = wd * 1.0e6 / one_hundred_bp;
+ a[2] = 0;
+ a[3] = 0;
+ a[4] = (ht + dp) * 1.0e6 / one_hundred_bp;
+ a[5] = hpos;
+ a[6] = vpos;
+ r = 4;
+ }
+ if ((img_transform(img) & 1) == 1) {
+ if (ht == -dp)
+ pdftex_fail("image transform: division by zero (height == -depth)");
+ if (wd == 0)
+ pdftex_fail("image transform: division by zero (width == 0)");
+ }
+ switch (img_transform(img) & 7) {
+ case 0: /* unrotated */
+ break;
+ case 1: /* rot. 90 deg. (counterclockwise) */
+ a[2] = a[1] * (ht + dp) / wd;
+ a[1] = 0;
+ a[3] = -a[4] * wd / (ht + dp);
+ a[4] = 0;
+ a[5] += wd;
+ break;
+ case 2: /* rot. 180 deg. */
+ a[1] = -a[1];
+ a[4] = -a[4];
+ a[5] += wd;
+ a[6] += ht + dp;
+ break;
+ case 3: /* rot. 270 deg. */
+ a[2] = -a[1] * (ht + dp) / wd;
+ a[1] = 0;
+ a[3] = a[4] * wd / (ht + dp);
+ a[4] = 0;
+ a[6] += ht + dp;
+ break;
+ case 4: /* mirrored, unrotated */
+ a[1] = -a[1];
+ a[5] += wd;
+ break;
+ case 5: /* mirrored, then rot. 90 deg. */
+ a[2] = -a[1] * (ht + dp) / wd;
+ a[1] = 0;
+ a[3] = -a[4] * wd / (ht + dp);
+ a[4] = 0;
+ a[5] += wd;
+ a[6] += ht + dp;
+ break;
+ case 6: /* mirrored, then rot. 180 deg. */
+ a[4] = -a[4];
+ a[6] += ht + dp;
+ break;
+ case 7: /* mirrored, then rot. 270 deg. */
+ a[2] = a[1] * (ht + dp) / wd;
+ a[1] = 0;
+ a[3] = a[4] * wd / (ht + dp);
+ a[4] = 0;
+ break;
+ default:
+ assert(0);
+ }
+ pdf_end_text();
+ pdf_printf("q\n");
+ pdf_print_real((integer) a[1], r);
+ pdfout(' ');
+ pdf_print_real((integer) a[2], r);
+ pdfout(' ');
+ pdf_print_real((integer) a[3], r);
+ pdfout(' ');
+ pdf_print_real((integer) a[4], r);
+ pdfout(' ');
+ pdf_print_bp((integer) a[5]);
+ pdfout(' ');
+ pdf_print_bp((integer) a[6]);
+ pdf_printf(" cm\n/Im");
+ pdf_print_int(img_index(idict));
+ pdf_print_resname_prefix();
+ pdf_printf(" Do\nQ\n");
+ if (img_state(idict) < DICT_OUTIMG)
+ img_state(idict) = DICT_OUTIMG;
+}
+
+void write_img(image_dict * idict)
+{
+ assert(idict != NULL);
+ if (img_state(idict) < DICT_WRITTEN) {
+ if (tracefilenames)
+ tex_printf(" <%s", img_filepath(idict));
+ switch (img_type(idict)) {
+ case IMAGE_TYPE_PNG:
+ write_png(idict);
+ break;
+ case IMAGE_TYPE_JPG:
+ write_jpg(idict);
+ break;
+ case IMAGE_TYPE_JBIG2:
+ write_jbig2(idict);
+ break;
+ case IMAGE_TYPE_PDF:
+ write_epdf(idict);
+ break;
+ default:
+ pdftex_fail("internal error: unknown image type");
+ }
+ if (tracefilenames)
+ tex_printf(">");
+ }
+ if (img_state(idict) < DICT_WRITTEN)
+ img_state(idict) = DICT_WRITTEN;
+}
+
+/**********************************************************************/
+
+typedef image *img_entry;
+/* define img_ptr, img_array, & img_limit */
+define_array(img); /* array of pointers to image structures */
+
+integer img_to_array(image * img)
+{
+ assert(img != NULL);
+ alloc_array(img, 1, SMALL_BUF_SIZE);
+ *img_ptr = img;
+ return img_ptr++ - img_array; /* now img is read-only */
+}
+
+/**********************************************************************/
+/* stuff to be accessible from TeX */
+
+integer read_image(integer objnum, integer index, strnumber filename,
+ integer page_num,
+ strnumber attr,
+ strnumber page_name,
+ integer colorspace, integer page_box,
+ integer pdf_minor_version, integer pdf_inclusion_errorlevel)
+{
+ integer ref;
+ image *a = new_image();
+ ref = img_to_array(a);
+ image_dict *idict = img_dict(a) = new_image_dict();
+ assert(idict != NULL);
+ img_objnum(idict) = objnum;
+ img_index(idict) = index;
+ /* img_xsize, img_ysize, img_xres, img_yres set by read_img() */
+ img_colorspace(idict) = colorspace;
+ img_pagenum(idict) = page_num;
+ /* img_totalpages set by read_img() */
+ if (page_name != 0)
+ img_pagename(idict) = xstrdup(makecstring(page_name));
+ cur_file_name = makecfilename(filename);
+ assert(cur_file_name != NULL);
+ img_filename(idict) = xstrdup(cur_file_name);
+ if (attr != 0)
+ img_attr(idict) = xstrdup(makecstring(attr));
+ img_pagebox(idict) = page_box;
+ read_img(idict, pdf_minor_version, pdf_inclusion_errorlevel);
+ img_unset_scaled(a);
+ img_set_refered(a);
+ return ref;
+}
+
+void set_image_dimensions(integer ref, integer wd, integer ht, integer dp)
+{
+ image *a = img_array[ref];
+ img_width(a) = wd;
+ img_height(a) = ht;
+ img_depth(a) = dp;
+}
+
+void scale_image(integer ref)
+{
+ scale_img(img_array[ref]);
+}
+
+void out_image(integer ref, scaled hpos, scaled vpos)
+{
+ image *a = img_array[ref];
+ out_img(a, hpos, vpos);
+}
+
+void write_image(integer ref)
+{
+ write_img(img_dict(img_array[ref]));
+}
+
+integer image_pages(integer ref)
+{
+ return img_totalpages(img_dict(img_array[ref]));
+}
+
+integer image_colordepth(integer ref)
+{
+ return img_colordepth(img_dict(img_array[ref]));
+}
+
+integer epdf_orig_x(integer ref)
+{
+ return bp2int(img_pdf_orig_x(img_dict(img_array[ref])));
+}
+
+integer epdf_orig_y(integer ref)
+{
+ return bp2int(img_pdf_orig_y(img_dict(img_array[ref])));
+}
+
+integer image_objnum(integer ref)
+{
+ return img_objnum(img_dict(img_array[ref]));
+}
+
+integer image_index(integer ref)
+{
+ return img_index(img_dict(img_array[ref]));
+}
+
+integer image_width(integer ref)
+{
+ return img_width(img_array[ref]);
+}
+
+integer image_height(integer ref)
+{
+ return img_height(img_array[ref]);
+}
+
+integer image_depth(integer ref)
+{
+ return img_depth(img_array[ref]);
+}
+
+void update_image_procset(integer ref)
+{
+ pdf_image_procset |= img_color(img_dict(img_array[ref]));
+}
+
+/**********************************************************************/
+
+boolean check_image_b(integer procset)
+{
+ return procset & IMAGE_COLOR_B;
+}
+
+boolean check_image_c(integer procset)
+{
+ return procset & IMAGE_COLOR_C;
+}
+
+boolean check_image_i(integer procset)
+{
+ return procset & IMAGE_COLOR_I;
+}
diff --git a/Build/source/texk/web2c/luatexdir/image/writejbig2.c b/Build/source/texk/web2c/luatexdir/image/writejbig2.c
new file mode 100644
index 00000000000..d50ed88c485
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/writejbig2.c
@@ -0,0 +1,749 @@
+/***********************************************************************
+Copyright (c) 2002-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2 of the License, or (at your option)
+any later version.
+
+pdfTeX is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License along
+with pdfTeX; if not, write to the Free Software Foundation, Inc., 59
+Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+This is experimental JBIG2 image support to pdfTeX. JBIG2 image decoding
+is part of Adobe PDF-1.4, and requires Acroread 5.0 or later.
+
+References
+==========
+
+* 14492 FCD: Information technology -- coded representation of picture
+and audio information -- lossy/lossless coding of bi-level images /
+JBIG committee, 1999 July 16. This JBIG2 Working Draft is available from
+http://www.jpeg.org/public/fcd14492.pdf. The references in the C-code
+correspond to the sections of this document.
+
+* PDF Reference, 5th edition, version 1.6, 1985--2005 Adobe Systems
+Incorporated. Available online:
+
+http://partners.adobe.com/public/developer/en/pdf/PDFReference16.pdf
+
+News
+====
+
+31 May 2006: no need to wait for endoffileflag in sequential access
+organization.
+
+10 May 2006: ygetc() for some catching of broken JBIG2 files; modify to
+accept Example 3.4 from PDFRef 5th ed. with short end-of-file segment.
+
+09 May 2006: pages_maketree() and segments_maketree() by AVL tree,
+some cleaning up.
+
+06 May 2006: File list replaced by AVL tree; new_fileinfo(),
+new_pageinfo().
+
+04 May 2006: Updated for pdftex-1.40-beta-20060213.
+
+08 Jan. 2003: Added flushjbig2page0objects() function. Now at the end
+of the pdfTeX run all pending page0 objects are written out.
+
+08 Jan. 2003: Release on private webpage.
+
+04 Jan. 2003: Completely rewritten. Now with some data structures.
+Rudimentary local file and image bookkeeping. Multiple image inclusion
+from one JBIG2 file. Only required page0 segments are marked for
+inclusion.
+
+13 Nov. 2002: pdfcrypting removed.
+
+08 Dec. 2002: bug in page 0 stream writing repaired.
+Strategy for multiple page inclusion from same JBIG2 file: When writing
+1st image, create fresh PDF object for page 0, and include any page
+0 segments from complete file (even if these segments are not needed
+for image). When writing next image, check by filename comparison if
+PDF object for page 0 of this JBIG2 file has already been written. This
+can only remember the file name for the direct predecessor JBIG2 image
+(but images of other types might come inbetween). If such page 0 PDF
+object exists, reference it. Else create fresh one.
+
+09 Dec. 2002: JBIG2 seg. page numbers > 0 are now set to 1, see PDF Ref.
+
+$Id: writejbig2.c 1027 2008-02-14 21:01:03Z hhenkel $
+***********************************************************************/
+
+#include "writejbig2.h"
+#undef DEBUG
+
+/**********************************************************************/
+
+struct avl_table *file_tree = NULL;
+
+static int comp_file_entry(const void *pa, const void *pb, void *p)
+{
+ return strcmp(((const FILEINFO *) pa)->filepath,
+ ((const FILEINFO *) pb)->filepath);
+}
+
+static int comp_page_entry(const void *pa, const void *pb, void *p)
+{
+ return ((const PAGEINFO *) pa)->pagenum - ((const PAGEINFO *) pb)->pagenum;
+}
+
+static int comp_segment_entry(const void *pa, const void *pb, void *p)
+{
+ return ((const SEGINFO *) pa)->segnum - ((const SEGINFO *) pb)->segnum;
+}
+
+/**********************************************************************/
+
+int ygetc(FILE * stream)
+{
+ int c = getc(stream);
+ if (c < 0) {
+ if (c == EOF)
+ pdftex_fail("getc() failed; premature end of JBIG2 image file");
+ else
+ pdftex_fail("getc() failed (can't happen)");
+ }
+ return c;
+}
+
+/**********************************************************************/
+
+FILEINFO *new_fileinfo()
+{
+ FILEINFO *fip;
+ fip = xtalloc(1, FILEINFO);
+ fip->file = NULL;
+ fip->filepath = NULL;
+ fip->filesize = 0;
+ initlinkedlist(&(fip->pages));
+ initlinkedlist(&(fip->page0));
+ fip->filehdrflags = 0;
+ fip->sequentialaccess = false;
+ fip->numofpages = 0;
+ fip->streamstart = 0;
+ fip->pdfpage0objnum = 0;
+ fip->phase = INITIAL;
+ return fip;
+}
+
+PAGEINFO *new_pageinfo()
+{
+ PAGEINFO *pip;
+ pip = xtalloc(1, PAGEINFO);
+ initlinkedlist(&(pip->segments));
+ pip->pagenum = 0;
+ pip->width = 0;
+ pip->height = 0;
+ pip->xres = 0;
+ pip->yres = 0;
+ pip->pagesegmentflags = 0;
+ pip->stripinginfo = 0;
+ pip->stripedheight = 0;
+ return pip;
+}
+
+void init_seginfo(SEGINFO * sip)
+{
+ sip->segnum = 0;
+ sip->isrefered = false;
+ sip->refers = false;
+ sip->seghdrflags = 0;
+ sip->pageassocsizeflag = false;
+ sip->reftosegcount = 0;
+ sip->countofrefered = 0;
+ sip->fieldlen = 0;
+ sip->segnumwidth = 0;
+ sip->segpage = 0;
+ sip->segdatalen = 0;
+ sip->hdrstart = 0;
+ sip->hdrend = 0;
+ sip->datastart = 0;
+ sip->dataend = 0;
+ sip->endofstripeflag = false;
+ sip->endofpageflag = false;
+ sip->pageinfoflag = false;
+ sip->endoffileflag = false;
+}
+
+/**********************************************************************/
+
+void initlinkedlist(LIST * lp)
+{
+ lp->first = NULL;
+ lp->last = NULL;
+ lp->tree = NULL;
+}
+
+LIST *litem_append(LIST * lp)
+{
+ LITEM *ip;
+ ip = xtalloc(1, LITEM);
+ if (lp->first == NULL) {
+ lp->first = ip;
+ ip->prev = NULL;
+ } else {
+ lp->last->next = ip;
+ ip->prev = lp->last;
+ }
+ lp->last = ip;
+ ip->next = NULL;
+ ip->d = NULL;
+ return lp;
+}
+
+/**********************************************************************/
+
+void pages_maketree(LIST * plp)
+{
+ LITEM *ip;
+ void **aa;
+ assert(plp->tree == NULL);
+ plp->tree = avl_create(comp_page_entry, NULL, &avl_xallocator);
+ assert(plp->tree != NULL);
+ for (ip = plp->first; ip != NULL; ip = ip->next) {
+ aa = avl_probe(plp->tree, (PAGEINFO *) ip->d);
+ assert(aa != NULL);
+ }
+}
+
+void segments_maketree(LIST * slp)
+{
+ LITEM *ip;
+ void **aa;
+ assert(slp->tree == NULL);
+ slp->tree = avl_create(comp_segment_entry, NULL, &avl_xallocator);
+ assert(slp->tree != NULL);
+ for (ip = slp->first; ip != NULL; ip = ip->next) {
+ aa = avl_probe(slp->tree, (SEGINFO *) ip->d);
+ assert(aa != NULL);
+ }
+}
+
+/**********************************************************************/
+
+PAGEINFO *find_pageinfo(LIST * plp, unsigned long pagenum)
+{
+ PAGEINFO tmp;
+ tmp.pagenum = pagenum;
+ assert(plp->tree != NULL);
+ return (PAGEINFO *) avl_find(plp->tree, &tmp);
+}
+
+SEGINFO *find_seginfo(LIST * slp, unsigned long segnum)
+{
+ SEGINFO tmp;
+ tmp.segnum = segnum;
+ assert(slp->tree != NULL);
+ return (SEGINFO *) avl_find(slp->tree, &tmp);
+}
+
+/**********************************************************************/
+
+unsigned int read2bytes(FILE * f)
+{
+ unsigned int c = ygetc(f);
+ return (c << 8) + ygetc(f);
+}
+
+unsigned long read4bytes(FILE * f)
+{
+ unsigned int l = read2bytes(f);
+ return (l << 16) + read2bytes(f);
+}
+
+/**********************************************************************/
+
+unsigned long getstreamlen(LITEM * slip, boolean refer)
+{
+ SEGINFO *sip;
+ unsigned long len = 0;
+ for (; slip != NULL; slip = slip->next) {
+ sip = slip->d;
+ if (refer || sip->isrefered)
+ len += sip->hdrend - sip->hdrstart + sip->dataend - sip->datastart;
+ }
+ return len;
+}
+
+/**********************************************************************/
+
+void readfilehdr(FILEINFO * fip)
+{
+ unsigned int i;
+ /* Annex D.4 File header syntax */
+ /* Annex D.4.1 ID string */
+ unsigned char jbig2_id[] = { 0x97, 'J', 'B', '2', 0x0d, 0x0a, 0x1a, 0x0a };
+ xfseek(fip->file, 0, SEEK_SET, fip->filepath);
+ for (i = 0; i < 8; i++)
+ if (ygetc(fip->file) != jbig2_id[i])
+ pdftex_fail
+ ("readfilehdr(): reading JBIG2 image file failed: ID string missing");
+ /* Annex D.4.2 File header flags */
+ fip->filehdrflags = ygetc(fip->file);
+ fip->sequentialaccess = (fip->filehdrflags & 0x01) ? true : false;
+ if (fip->sequentialaccess) { /* Annex D.1 vs. Annex D.2 */
+ xfseek(fip->file, 0, SEEK_END, fip->filepath);
+ fip->filesize = xftell(fip->file, fip->filepath);
+ xfseek(fip->file, 9, SEEK_SET, fip->filepath);
+ }
+ /* Annex D.4.3 Number of pages */
+ if (!(fip->filehdrflags >> 1) & 0x01) /* known number of pages */
+ fip->numofpages = read4bytes(fip->file);
+ /* --- at end of file header --- */
+}
+
+/**********************************************************************/
+/* for first reading of file; return value tells if header been read */
+
+boolean readseghdr(FILEINFO * fip, SEGINFO * sip)
+{
+ unsigned int i;
+ sip->hdrstart = xftell(fip->file, fip->filepath);
+ if (fip->sequentialaccess && sip->hdrstart == fip->filesize)
+ return false; /* no endoffileflag is ok for sequentialaccess */
+#ifdef DEBUG
+ printf("\nhdrstart %d\n", sip->hdrstart);
+#endif
+ /* 7.2.2 Segment number */
+ sip->segnum = read4bytes(fip->file);
+#ifdef DEBUG
+ printf(" segnum %d\n", sip->segnum);
+#endif
+ /* 7.2.3 Segment header flags */
+ sip->seghdrflags = ygetc(fip->file);
+#ifdef DEBUG
+ printf(" hdrflags %d\n", sip->seghdrflags & 0x3f);
+#endif
+ checkseghdrflags(sip);
+ if (fip->sequentialaccess && sip->endoffileflag) /* accept shorter segment, */
+ return true; /* makes it compliant with Example 3.4 of PDFRef. 5th ed. */
+ sip->pageassocsizeflag = ((sip->seghdrflags >> 6) & 0x01) ? true : false;
+ /* 7.2.4 Referred-to segment count and retention flags */
+ sip->reftosegcount = (unsigned int) ygetc(fip->file);
+ sip->countofrefered = sip->reftosegcount >> 5;
+ if (sip->countofrefered < 5)
+ sip->fieldlen = 1;
+ else {
+ sip->fieldlen = 5 + sip->countofrefered / 8;
+ xfseek(fip->file, sip->fieldlen - 1, SEEK_CUR, fip->filepath);
+ }
+ /* 7.2.5 Referred-to segment numbers */
+ if (sip->segnum <= 256)
+ sip->segnumwidth = 1;
+ else if (sip->segnum <= 65536)
+ sip->segnumwidth = 2;
+ else
+ sip->segnumwidth = 4;
+ for (i = 0; i < sip->countofrefered; i++) {
+ switch (sip->segnumwidth) {
+ case 1:
+ (void) ygetc(fip->file);
+ break;
+ case 2:
+ (void) read2bytes(fip->file);
+ break;
+ case 4:
+ (void) read4bytes(fip->file);
+ break;
+ }
+ }
+ /* 7.2.6 Segment page association */
+ if (sip->pageassocsizeflag)
+ sip->segpage = read4bytes(fip->file);
+ else
+ sip->segpage = ygetc(fip->file);
+ /* 7.2.7 Segment data length */
+ sip->segdatalen = read4bytes(fip->file);
+ sip->hdrend = xftell(fip->file, fip->filepath);
+ /* ---- at end of segment header ---- */
+ return true;
+}
+
+/**********************************************************************/
+/* for writing, marks refered page0 segments, sets segpage > 0 to 1 */
+
+void writeseghdr(FILEINFO * fip, SEGINFO * sip)
+{
+ unsigned int i;
+ unsigned long referedseg = 0;
+ /* 7.2.2 Segment number */
+ /* 7.2.3 Segment header flags */
+ /* 7.2.4 Referred-to segment count and retention flags */
+ for (i = 0; i < 5 + sip->fieldlen; i++)
+ pdfout(ygetc(fip->file));
+ /* 7.2.5 Referred-to segment numbers */
+ for (i = 0; i < sip->countofrefered; i++) {
+ switch (sip->segnumwidth) {
+ case 1:
+ referedseg = ygetc(fip->file);
+ pdfout(referedseg);
+ break;
+ case 2:
+ referedseg = read2bytes(fip->file);
+ pdfout((referedseg >> 8) & 0xff);
+ pdfout(referedseg & 0xff);
+ break;
+ case 4:
+ referedseg = read4bytes(fip->file);
+ pdfout((referedseg >> 24) & 0xff);
+ pdfout((referedseg >> 16) & 0xff);
+ pdfout((referedseg >> 8) & 0xff);
+ pdfout(referedseg & 0xff);
+ break;
+ }
+ if (fip->page0.last != NULL && !sip->refers)
+ markpage0seg(fip, referedseg);
+ }
+ if (sip->countofrefered > 0)
+ sip->refers = true;
+ /* 7.2.6 Segment page association */
+ if (sip->pageassocsizeflag)
+ for (i = 0; i < 3; i++) {
+ (void) ygetc(fip->file);
+ pdfout(0);
+ }
+ (void) ygetc(fip->file);
+ pdfout((sip->segpage > 0) ? 1 : 0);
+ /* 7.2.7 Segment data length */
+ for (i = 0; i < 4; i++)
+ pdfout(ygetc(fip->file));
+ /* ---- at end of segment header ---- */
+}
+
+/**********************************************************************/
+/* for recursive marking of refered page0 segments */
+
+void checkseghdr(FILEINFO * fip, SEGINFO * sip)
+{
+ unsigned int i;
+ unsigned long referedseg = 0;
+ /* 7.2.2 Segment number */
+ /* 7.2.3 Segment header flags */
+ /* 7.2.4 Referred-to segment count and retention flags */
+ xfseek(fip->file, 5 + sip->fieldlen, SEEK_CUR, fip->filepath);
+ /* 7.2.5 Referred-to segment numbers */
+ for (i = 0; i < sip->countofrefered; i++) {
+ switch (sip->segnumwidth) {
+ case 1:
+ referedseg = ygetc(fip->file);
+ break;
+ case 2:
+ referedseg = read2bytes(fip->file);
+ break;
+ case 4:
+ referedseg = read4bytes(fip->file);
+ break;
+ }
+ if (!sip->refers)
+ markpage0seg(fip, referedseg);
+ }
+ if (sip->countofrefered > 0)
+ sip->refers = true;
+ /* 7.2.6 Segment page association */
+ /* 7.2.7 Segment data length */
+ if (sip->pageassocsizeflag)
+ xfseek(fip->file, 8, SEEK_CUR, fip->filepath);
+ else
+ xfseek(fip->file, 5, SEEK_CUR, fip->filepath);
+ /* ---- at end of segment header ---- */
+}
+
+/**********************************************************************/
+
+void checkseghdrflags(SEGINFO * sip)
+{
+ sip->endofstripeflag = false;
+ sip->endofpageflag = false;
+ sip->pageinfoflag = false;
+ sip->endoffileflag = false;
+ /* 7.3 Segment types */
+ switch (sip->seghdrflags & 0x3f) {
+ case M_SymbolDictionary:
+ case M_IntermediateTextRegion:
+ case M_ImmediateTextRegion:
+ case M_ImmediateLosslessTextRegion:
+ case M_PatternDictionary:
+ case M_IntermediateHalftoneRegion:
+ case M_ImmediateHalftoneRegion:
+ case M_ImmediateLosslessHalftoneRegion:
+ case M_IntermediateGenericRegion:
+ case M_ImmediateGenericRegion:
+ case M_ImmediateLosslessGenericRegion:
+ case M_IntermediateGenericRefinementRegion:
+ case M_ImmediateGenericRefinementRegion:
+ case M_ImmediateLosslessGenericRefinementRegion:
+ break;
+ case M_PageInformation:
+ sip->pageinfoflag = true;
+ break;
+ case M_EndOfPage:
+ sip->endofpageflag = true;
+ break;
+ case M_EndOfStripe:
+ sip->endofstripeflag = true;
+ break;
+ case M_EndOfFile:
+ sip->endoffileflag = true;
+ break;
+ case M_Profiles:
+ case M_Tables:
+ case M_Extension:
+ break;
+ default:
+ pdftex_fail
+ ("checkseghdrflags(): unknown segment type in JBIG2 image file");
+ break;
+ }
+}
+
+/**********************************************************************/
+
+void markpage0seg(FILEINFO * fip, unsigned long referedseg)
+{
+ PAGEINFO *pip;
+ SEGINFO *sip;
+ pip = fip->page0.first->d;
+ sip = find_seginfo(&(pip->segments), referedseg);
+ if (sip != NULL) {
+ if (!sip->refers && sip->countofrefered > 0)
+ checkseghdr(fip, sip);
+ sip->isrefered = true;
+ }
+}
+
+/**********************************************************************/
+
+unsigned long findstreamstart(FILEINFO * fip)
+{
+ SEGINFO tmp;
+ assert(!fip->sequentialaccess); /* D.2 Random-access organisation */
+ do /* find random-access stream start */
+ (void) readseghdr(fip, &tmp);
+ while (!tmp.endoffileflag);
+ fip->streamstart = tmp.hdrend;
+ readfilehdr(fip);
+ return fip->streamstart;
+}
+
+/**********************************************************************/
+
+void rd_jbig2_info(FILEINFO * fip)
+{
+ unsigned long seekdist = 0; /* for sequential-access only */
+ unsigned long streampos = 0; /* for random-access only */
+ unsigned long currentpage = 0;
+ boolean sipavail = false;
+ PAGEINFO *pip;
+ SEGINFO *sip = NULL;
+ LIST *plp, *slp;
+ fip->file = xfopen(fip->filepath, FOPEN_RBIN_MODE);
+ readfilehdr(fip);
+ if (!fip->sequentialaccess) /* D.2 Random-access organisation */
+ streampos = findstreamstart(fip);
+ while (true) { /* loop over segments */
+ if (!sipavail) {
+ sip = xtalloc(1, SEGINFO);
+ sipavail = true;
+ }
+ init_seginfo(sip);
+ if (!readseghdr(fip, sip) || sip->endoffileflag)
+ break;
+ if (sip->segpage > 0) {
+ if (sip->segpage > currentpage) {
+ plp = litem_append(&(fip->pages));
+ plp->last->d = new_pageinfo();
+ currentpage = sip->segpage;
+ }
+ pip = fip->pages.last->d;
+ } else {
+ if (fip->page0.last == NULL) {
+ plp = litem_append(&(fip->page0));
+ plp->last->d = new_pageinfo();
+ }
+ pip = fip->page0.last->d;
+ }
+ if (!sip->endofpageflag) {
+ slp = litem_append(&(pip->segments));
+ slp->last->d = sip;
+ sipavail = false;
+ }
+ if (!fip->sequentialaccess)
+ sip->datastart = streampos;
+ else
+ sip->datastart = sip->hdrend;
+ sip->dataend = sip->datastart + sip->segdatalen;
+ if (!fip->sequentialaccess
+ && (sip->pageinfoflag || sip->endofstripeflag))
+ xfseek(fip->file, sip->datastart, SEEK_SET, fip->filepath);
+ seekdist = sip->segdatalen;
+ /* 7.4.8 Page information segment syntax */
+ if (sip->pageinfoflag) {
+ pip->pagenum = sip->segpage;
+ pip->width = read4bytes(fip->file);
+ pip->height = read4bytes(fip->file);
+ pip->xres = read4bytes(fip->file);
+ pip->yres = read4bytes(fip->file);
+ pip->pagesegmentflags = ygetc(fip->file);
+ /* 7.4.8.6 Page striping information */
+ pip->stripinginfo = read2bytes(fip->file);
+ seekdist -= 19;
+ }
+ if (sip->endofstripeflag) {
+ pip->stripedheight = read4bytes(fip->file);
+ seekdist -= 4;
+ }
+ if (!fip->sequentialaccess
+ && (sip->pageinfoflag || sip->endofstripeflag))
+ xfseek(fip->file, sip->hdrend, SEEK_SET, fip->filepath);
+ if (!fip->sequentialaccess)
+ streampos += sip->segdatalen;
+ if (fip->sequentialaccess)
+ xfseek(fip->file, seekdist, SEEK_CUR, fip->filepath);
+ if (sip->endofpageflag && currentpage && (pip->stripinginfo >> 15))
+ pip->height = pip->stripedheight;
+ }
+ fip->phase = HAVEINFO;
+ if (sipavail)
+ xfree(sip);
+ xfclose(fip->file, fip->filepath);
+}
+
+/**********************************************************************/
+
+void wr_jbig2(FILEINFO * fip, unsigned long page)
+{
+ LITEM *slip;
+ PAGEINFO *pip;
+ SEGINFO *sip;
+ unsigned long i;
+ if (page > 0) {
+ pip = find_pageinfo(&(fip->pages), page);
+ assert(pip != NULL);
+ pdf_puts("/Type /XObject\n/Subtype /Image\n");
+ pdf_printf("/Width %i\n", pip->width);
+ pdf_printf("/Height %i\n", pip->height);
+ pdf_puts("/ColorSpace /DeviceGray\n");
+ pdf_puts("/BitsPerComponent 1\n");
+ pdf_printf("/Length %lu\n", getstreamlen(pip->segments.first, true));
+ pdf_puts("/Filter [/JBIG2Decode]\n");
+ if (fip->page0.last != NULL) {
+ if (fip->pdfpage0objnum == 0) {
+ pdf_create_obj(0, 0);
+ fip->pdfpage0objnum = obj_ptr;
+ }
+ pdf_printf("/DecodeParms [<< /JBIG2Globals %lu 0 R >>]\n",
+ fip->pdfpage0objnum);
+ }
+ } else {
+ pip = find_pageinfo(&(fip->page0), page);
+ assert(pip != NULL);
+ pdf_begin_dict(fip->pdfpage0objnum, 0);
+ pdf_printf("/Length %lu\n", getstreamlen(pip->segments.first, false));
+ }
+ pdf_puts(">>\n");
+ pdf_puts("stream\n");
+ fip->file = xfopen(fip->filepath, FOPEN_RBIN_MODE);
+ for (slip = pip->segments.first; slip != NULL; slip = slip->next) { /* loop over page segments */
+ sip = slip->d;
+ if (sip->isrefered || page > 0) {
+ xfseek(fip->file, sip->hdrstart, SEEK_SET, fip->filepath);
+ /* mark refered-to page 0 segments, change segpages > 1 to 1 */
+ writeseghdr(fip, sip);
+ xfseek(fip->file, sip->datastart, SEEK_SET, fip->filepath);
+ for (i = sip->datastart; i < sip->dataend; i++)
+ pdfout(ygetc(fip->file));
+ }
+ }
+ pdf_end_stream();
+ xfclose(fip->file, fip->filepath);
+}
+
+/**********************************************************************/
+
+void read_jbig2_info(image_dict * idict)
+{
+ FILEINFO *fip, tmp;
+ PAGEINFO *pip;
+ void **aa;
+ assert(idict != NULL);
+ img_type(idict) = IMAGE_TYPE_JBIG2;
+ if (img_pagenum(idict) < 1)
+ pdftex_fail
+ ("read_jbig2_info(): page %d not in JBIG2 image file; page must be > 0",
+ (int) img_pagenum(idict));
+ if (file_tree == NULL) {
+ file_tree = avl_create(comp_file_entry, NULL, &avl_xallocator);
+ assert(file_tree != NULL);
+ }
+ tmp.filepath = img_filepath(idict);
+ fip = (FILEINFO *) avl_find(file_tree, &tmp);
+ if (fip == NULL) {
+ fip = new_fileinfo();
+ fip->filepath = xstrdup(img_filepath(idict));
+ aa = avl_probe(file_tree, fip);
+ assert(aa != NULL);
+ }
+ if (fip->phase == INITIAL) {
+ rd_jbig2_info(fip);
+ pages_maketree(&(fip->pages));
+ if (fip->page0.last != NULL) {
+ pages_maketree(&(fip->page0));
+ pip = fip->page0.first->d;
+ segments_maketree(&(pip->segments));
+ }
+ }
+ pip = find_pageinfo(&(fip->pages), img_pagenum(idict));
+ if (pip == NULL)
+ pdftex_fail("read_jbig2_info(): page %d not found in JBIG2 image file",
+ (int) img_pagenum(idict));
+ img_xsize(idict) = pip->width;
+ img_ysize(idict) = pip->height;
+ img_xres(idict) = (int) (pip->xres * 0.0254 + 0.5);
+ img_yres(idict) = (int) (pip->yres * 0.0254 + 0.5);
+ img_colordepth(idict) = 1;
+}
+
+/**********************************************************************/
+
+void write_jbig2(image_dict * idict)
+{
+ FILEINFO *fip, tmp;
+ PAGEINFO *pip;
+ assert(idict != NULL);
+ assert(file_tree != NULL);
+ tmp.filepath = img_filepath(idict);
+ fip = (FILEINFO *) avl_find(file_tree, &tmp);
+ assert(fip != NULL);
+ assert(fip->phase == HAVEINFO); /* don't write before rd_jbig2_info() call */
+ pip = find_pageinfo(&(fip->pages), img_pagenum(idict));
+ assert(pip != NULL);
+ wr_jbig2(fip, pip->pagenum);
+ img_file(idict) = NULL;
+}
+
+/**********************************************************************/
+
+void flush_jbig2_page0_objects()
+{
+ FILEINFO *fip;
+ struct avl_traverser t;
+ if (file_tree != NULL) {
+ avl_t_init(&t, file_tree);
+ for (fip = avl_t_first(&t, file_tree); fip != NULL;
+ fip = avl_t_next(&t)) {
+ if (fip->page0.last != NULL)
+ wr_jbig2(fip, 0);
+ }
+ }
+}
+
+/**********************************************************************/
diff --git a/Build/source/texk/web2c/luatexdir/image/writejbig2.h b/Build/source/texk/web2c/luatexdir/image/writejbig2.h
new file mode 100644
index 00000000000..c1bec32d859
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/writejbig2.h
@@ -0,0 +1,151 @@
+/***********************************************************************
+Copyright (c) 2002-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2 of the License, or (at your option)
+any later version.
+
+pdfTeX is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License along
+with pdfTeX; if not, write to the Free Software Foundation, Inc., 59
+Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+This is experimental JBIG2 image support to pdfTeX. JBIG2 image decoding
+is part of Adobe PDF-1.4, and requires Acroread 5.0 or later.
+
+$Id: writejbig2.h 1012 2008-02-14 00:00:57Z oneiros $
+***********************************************************************/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <assert.h>
+#include "ptexlib.h"
+#include "ptexmac.h"
+#include "image.h"
+
+/* 7.3 Segment types */
+#define M_SymbolDictionary 0
+#define M_IntermediateTextRegion 4
+#define M_ImmediateTextRegion 6
+#define M_ImmediateLosslessTextRegion 7
+#define M_PatternDictionary 16
+#define M_IntermediateHalftoneRegion 20
+#define M_ImmediateHalftoneRegion 22
+#define M_ImmediateLosslessHalftoneRegion 23
+#define M_IntermediateGenericRegion 36
+#define M_ImmediateGenericRegion 38
+#define M_ImmediateLosslessGenericRegion 39
+#define M_IntermediateGenericRefinementRegion 40
+#define M_ImmediateGenericRefinementRegion 42
+#define M_ImmediateLosslessGenericRefinementRegion 43
+#define M_PageInformation 48
+#define M_EndOfPage 49
+#define M_EndOfStripe 50
+#define M_EndOfFile 51
+#define M_Profiles 52
+#define M_Tables 53
+#define M_Extension 62
+
+/**********************************************************************/
+
+typedef enum { INITIAL, HAVEINFO, WRITEPDF } PHASE;
+
+typedef struct _LITEM {
+ struct _LITEM *prev;
+ struct _LITEM *next;
+ void *d; /* data */
+} LITEM;
+
+typedef struct _LIST {
+ LITEM *first;
+ LITEM *last;
+ struct avl_table *tree;
+} LIST;
+
+typedef struct _SEGINFO {
+ unsigned long segnum;
+ boolean isrefered;
+ boolean refers;
+ unsigned int seghdrflags; /* set by readseghdr() */
+ boolean pageassocsizeflag; /* set by readseghdr() */
+ unsigned int reftosegcount; /* set by readseghdr() */
+ unsigned int countofrefered; /* set by readseghdr() */
+ unsigned int fieldlen; /* set by readseghdr() */
+ unsigned int segnumwidth; /* set by readseghdr() */
+ long segpage; /* set by readseghdr() */
+ unsigned long segdatalen; /* set by readseghdr() */
+ unsigned long hdrstart; /* set by readseghdr() */
+ unsigned long hdrend; /* set by readseghdr() */
+ unsigned long datastart;
+ unsigned long dataend;
+ boolean endofstripeflag; /* set by checkseghdrflags() */
+ boolean endofpageflag; /* set by checkseghdrflags() */
+ boolean pageinfoflag; /* set by checkseghdrflags() */
+ boolean endoffileflag; /* set by checkseghdrflags() */
+} SEGINFO;
+
+typedef struct _PAGEINFO {
+ LIST segments; /* segments associated with page */
+ unsigned long pagenum;
+ unsigned int width;
+ unsigned int height;
+ unsigned int xres;
+ unsigned int yres;
+ unsigned int pagesegmentflags;
+ unsigned int stripinginfo;
+ unsigned int stripedheight;
+} PAGEINFO;
+
+typedef struct _FILEINFO {
+ FILE *file;
+ char *filepath;
+ long filesize;
+ LIST pages; /* not including page0 */
+ LIST page0;
+ unsigned int filehdrflags; /* set by readfilehdr() */
+ boolean sequentialaccess; /* set by readfilehdr() */
+ unsigned long numofpages; /* set by readfilehdr() */
+ unsigned long streamstart; /* set by get_jbig2_info() */
+ unsigned long pdfpage0objnum;
+ PHASE phase;
+} FILEINFO;
+
+/**********************************************************************/
+
+static int comp_file_entry(const void *, const void *, void *);
+static int comp_page_entry(const void *, const void *, void *);
+static int comp_segment_entry(const void *, const void *, void *);
+int ygetc(FILE *);
+FILEINFO *new_fileinfo();
+PAGEINFO *new_pageinfo();
+void initseginfo(SEGINFO *);
+void initlinkedlist(LIST *);
+LIST *litem_append(LIST *);
+void pages_maketree(LIST *);
+void segments_maketree(LIST *);
+PAGEINFO *find_pageinfo(LIST *, unsigned long);
+SEGINFO *find_seginfo(LIST *, unsigned long);
+unsigned int read2bytes(FILE *);
+unsigned long read4bytes(FILE *);
+unsigned long getstreamlen(LITEM *, boolean);
+void readfilehdr(FILEINFO *);
+boolean readseghdr(FILEINFO *, SEGINFO *);
+void writeseghdr(FILEINFO *, SEGINFO *);
+void checkseghdr(FILEINFO *, SEGINFO *);
+void checkseghdrflags(SEGINFO * sip);
+void markpage0seg(FILEINFO *, unsigned long);
+unsigned long findstreamstart(FILEINFO *);
+void rd_jbig2_info(FILEINFO *);
+void wr_jbig2(FILEINFO *, unsigned long);
+void read_jbig2_info(image_dict *);
+void write_jbig2(image_dict *);
+void flushjbig2page0objects();
+
+/**********************************************************************/
diff --git a/Build/source/texk/web2c/luatexdir/image/writejpg.c b/Build/source/texk/web2c/luatexdir/image/writejpg.c
new file mode 100644
index 00000000000..422c29470fb
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/writejpg.c
@@ -0,0 +1,277 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writejpg.c 1100 2008-03-09 13:40:48Z hhenkel $
+*/
+
+#include <assert.h>
+#include "ptexlib.h"
+#include "image.h"
+
+#define JPG_GRAY 1 /* Gray color space, use /DeviceGray */
+#define JPG_RGB 3 /* RGB color space, use /DeviceRGB */
+#define JPG_CMYK 4 /* CMYK color space, use /DeviceCMYK */
+
+typedef enum { /* JPEG marker codes */
+ M_SOF0 = 0xc0, /* baseline DCT */
+ M_SOF1 = 0xc1, /* extended sequential DCT */
+ M_SOF2 = 0xc2, /* progressive DCT */
+ M_SOF3 = 0xc3, /* lossless (sequential) */
+
+ M_SOF5 = 0xc5, /* differential sequential DCT */
+ M_SOF6 = 0xc6, /* differential progressive DCT */
+ M_SOF7 = 0xc7, /* differential lossless */
+
+ M_JPG = 0xc8, /* JPEG extensions */
+ M_SOF9 = 0xc9, /* extended sequential DCT */
+ M_SOF10 = 0xca, /* progressive DCT */
+ M_SOF11 = 0xcb, /* lossless (sequential) */
+
+ M_SOF13 = 0xcd, /* differential sequential DCT */
+ M_SOF14 = 0xce, /* differential progressive DCT */
+ M_SOF15 = 0xcf, /* differential lossless */
+
+ M_DHT = 0xc4, /* define Huffman tables */
+
+ M_DAC = 0xcc, /* define arithmetic conditioning table */
+
+ M_RST0 = 0xd0, /* restart */
+ M_RST1 = 0xd1, /* restart */
+ M_RST2 = 0xd2, /* restart */
+ M_RST3 = 0xd3, /* restart */
+ M_RST4 = 0xd4, /* restart */
+ M_RST5 = 0xd5, /* restart */
+ M_RST6 = 0xd6, /* restart */
+ M_RST7 = 0xd7, /* restart */
+
+ M_SOI = 0xd8, /* start of image */
+ M_EOI = 0xd9, /* end of image */
+ M_SOS = 0xda, /* start of scan */
+ M_DQT = 0xdb, /* define quantization tables */
+ M_DNL = 0xdc, /* define number of lines */
+ M_DRI = 0xdd, /* define restart interval */
+ M_DHP = 0xde, /* define hierarchical progression */
+ M_EXP = 0xdf, /* expand reference image(s) */
+
+ M_APP0 = 0xe0, /* application marker, used for JFIF */
+ M_APP1 = 0xe1, /* application marker */
+ M_APP2 = 0xe2, /* application marker */
+ M_APP3 = 0xe3, /* application marker */
+ M_APP4 = 0xe4, /* application marker */
+ M_APP5 = 0xe5, /* application marker */
+ M_APP6 = 0xe6, /* application marker */
+ M_APP7 = 0xe7, /* application marker */
+ M_APP8 = 0xe8, /* application marker */
+ M_APP9 = 0xe9, /* application marker */
+ M_APP10 = 0xea, /* application marker */
+ M_APP11 = 0xeb, /* application marker */
+ M_APP12 = 0xec, /* application marker */
+ M_APP13 = 0xed, /* application marker */
+ M_APP14 = 0xee, /* application marker, used by Adobe */
+ M_APP15 = 0xef, /* application marker */
+
+ M_JPG0 = 0xf0, /* reserved for JPEG extensions */
+ M_JPG13 = 0xfd, /* reserved for JPEG extensions */
+ M_COM = 0xfe, /* comment */
+
+ M_TEM = 0x01, /* temporary use */
+
+ M_ERROR = 0x100 /* dummy marker, internal use only */
+} JPEG_MARKER;
+
+static JPG_UINT16 read2bytes(FILE * f)
+{
+ int c = xgetc(f);
+ return (c << 8) + xgetc(f);
+}
+
+void close_and_cleanup_jpg(image_dict * idict)
+{
+ assert(idict != NULL);
+ assert(img_file(idict) != NULL);
+ assert(img_filepath(idict) != NULL);
+ xfclose(img_file(idict), img_filepath(idict));
+ img_file(idict) = NULL;
+ assert(img_jpg_ptr(idict) != NULL);
+ xfree(img_jpg_ptr(idict));
+ img_jpg_ptr(idict) = NULL;
+}
+
+void read_jpg_info(image_dict * idict, img_readtype_e readtype)
+{
+ int i, units = 0;
+ unsigned char jpg_id[] = "JFIF";
+ assert(idict != NULL);
+ assert(img_type(idict) == IMAGE_TYPE_JPG);
+ img_totalpages(idict) = 1;
+ img_pagenum(idict) = 1;
+ img_xres(idict) = img_yres(idict) = 0;
+ assert(img_file(idict) == NULL);
+ img_file(idict) = xfopen(img_filepath(idict), FOPEN_RBIN_MODE);
+ assert(img_jpg_ptr(idict) == NULL);
+ img_jpg_ptr(idict) = xtalloc(1, jpg_img_struct);
+ xfseek(img_file(idict), 0, SEEK_END, img_filepath(idict));
+ img_jpg_ptr(idict)->length = xftell(img_file(idict), img_filepath(idict));
+ xfseek(img_file(idict), 0, SEEK_SET, img_filepath(idict));
+ if (read2bytes(img_file(idict)) != 0xFFD8)
+ pdftex_fail("reading JPEG image failed (no JPEG header found)");
+ /* currently only true JFIF files allow extracting img_xres and img_yres */
+ if (read2bytes(img_file(idict)) == 0xFFE0) { /* check for JFIF */
+ (void) read2bytes(img_file(idict));
+ for (i = 0; i < 5; i++) {
+ if (xgetc(img_file(idict)) != jpg_id[i])
+ break;
+ }
+ if (i == 5) { /* it's JFIF */
+ read2bytes(img_file(idict));
+ units = xgetc(img_file(idict));
+ img_xres(idict) = read2bytes(img_file(idict));
+ img_yres(idict) = read2bytes(img_file(idict));
+ switch (units) {
+ case 1:
+ break; /* pixels per inch */
+ case 2:
+ img_xres(idict) *= 2.54;
+ img_yres(idict) *= 2.54;
+ break; /* pixels per cm */
+ default:
+ img_xres(idict) = img_yres(idict) = 0;
+ break;
+ }
+ }
+ }
+ xfseek(img_file(idict), 0, SEEK_SET, img_filepath(idict));
+ while (1) {
+ if (feof(img_file(idict)))
+ pdftex_fail("reading JPEG image failed (premature file end)");
+ if (fgetc(img_file(idict)) != 0xFF)
+ pdftex_fail("reading JPEG image failed (no marker found)");
+ switch (xgetc(img_file(idict))) {
+ case M_SOF5:
+ case M_SOF6:
+ case M_SOF7:
+ case M_SOF9:
+ case M_SOF10:
+ case M_SOF11:
+ case M_SOF13:
+ case M_SOF14:
+ case M_SOF15:
+ pdftex_fail("unsupported type of compression");
+ case M_SOF2:
+ if (fixed_pdf_minor_version <= 2)
+ pdftex_fail("cannot use progressive DCT with PDF-1.2");
+ case M_SOF0:
+ case M_SOF1:
+ case M_SOF3:
+ (void) read2bytes(img_file(idict)); /* read segment length */
+ img_colordepth(idict) = xgetc(img_file(idict));
+ img_ysize(idict) = read2bytes(img_file(idict));
+ img_xsize(idict) = read2bytes(img_file(idict));
+ img_jpg_color(idict) = xgetc(img_file(idict));
+ xfseek(img_file(idict), 0, SEEK_SET, img_filepath(idict));
+ switch (img_jpg_color(idict)) {
+ case JPG_GRAY:
+ img_color(idict) = IMAGE_COLOR_B;
+ break;
+ case JPG_RGB:
+ img_color(idict) = IMAGE_COLOR_C;
+ break;
+ case JPG_CMYK:
+ img_color(idict) = IMAGE_COLOR_C;
+ break;
+ default:
+ pdftex_fail("Unsupported color space %i",
+ (int) img_jpg_color(idict));
+ }
+ if (readtype == IMG_CLOSEINBETWEEN)
+ close_and_cleanup_jpg(idict);
+ return;
+ case M_SOI: /* ignore markers without parameters */
+ case M_EOI:
+ case M_TEM:
+ case M_RST0:
+ case M_RST1:
+ case M_RST2:
+ case M_RST3:
+ case M_RST4:
+ case M_RST5:
+ case M_RST6:
+ case M_RST7:
+ break;
+ default: /* skip variable length markers */
+ xfseek(img_file(idict), read2bytes(img_file(idict)) - 2,
+ SEEK_CUR, img_filepath(idict));
+ break;
+ }
+ }
+ assert(0);
+}
+
+static void reopen_jpg(image_dict * idict)
+{
+ integer width, height, xres, yres;
+ width = img_xsize(idict);
+ height = img_ysize(idict);
+ xres = img_xres(idict);
+ yres = img_yres(idict);
+ read_jpg_info(idict, IMG_KEEPOPEN);
+ if (width != img_xsize(idict) || height != img_ysize(idict)
+ || xres != img_xres(idict) || yres != img_yres(idict))
+ pdftex_fail("writejpg: image dimensions have changed");
+}
+
+void write_jpg(image_dict * idict)
+{
+ long unsigned l;
+ FILE *f;
+ assert(idict != NULL);
+ if (img_file(idict) == NULL)
+ reopen_jpg(idict);
+ assert(img_jpg_ptr(idict) != NULL);
+ pdf_puts("/Type /XObject\n/Subtype /Image\n");
+ if (img_attr(idict) != NULL && strlen(img_attr(idict)) > 0)
+ pdf_printf("%s\n", img_attr(idict));
+ pdf_printf("/Width %i\n/Height %i\n/BitsPerComponent %i\n/Length %i\n",
+ (int) img_xsize(idict),
+ (int) img_ysize(idict),
+ (int) img_colordepth(idict), (int) img_jpg_ptr(idict)->length);
+ pdf_puts("/ColorSpace ");
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ switch (img_jpg_color(idict)) {
+ case JPG_GRAY:
+ pdf_puts("/DeviceGray\n");
+ break;
+ case JPG_RGB:
+ pdf_puts("/DeviceRGB\n");
+ break;
+ case JPG_CMYK:
+ pdf_puts("/DeviceCMYK\n/Decode [1 0 1 0 1 0 1 0]\n");
+ break;
+ default:
+ pdftex_fail("Unsupported color space %i",
+ (int) img_jpg_color(idict));
+ }
+ }
+ pdf_puts("/Filter /DCTDecode\n>>\nstream\n");
+ for (l = img_jpg_ptr(idict)->length, f = img_file(idict); l > 0; l--)
+ pdfout(xgetc(f));
+ pdf_end_stream();
+ close_and_cleanup_jpg(idict);
+}
diff --git a/Build/source/texk/web2c/luatexdir/image/writepng.c b/Build/source/texk/web2c/luatexdir/image/writepng.c
new file mode 100644
index 00000000000..7f1269d9943
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/image/writepng.c
@@ -0,0 +1,635 @@
+/*
+Copyright (c) 1996-2004 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id: writepng.c 1101 2008-03-09 16:12:15Z hhenkel $
+*/
+
+#include <assert.h>
+#include "ptexlib.h"
+#include "image.h"
+
+void close_and_cleanup_png(image_dict * idict)
+{
+ assert(idict != NULL);
+ assert(img_file(idict) != NULL);
+ assert(img_filepath(idict) != NULL);
+ xfclose(img_file(idict), img_filepath(idict));
+ img_file(idict) = NULL;
+ assert(img_png_ptr(idict) != NULL);
+ png_destroy_read_struct(&(img_png_png_ptr(idict)),
+ &(img_png_info_ptr(idict)), NULL);
+ xfree(img_png_ptr(idict));
+ img_png_ptr(idict) = NULL;
+}
+
+void read_png_info(image_dict * idict, img_readtype_e readtype)
+{
+ double gamma;
+ png_structp png_p;
+ png_infop info_p;
+ assert(idict != NULL);
+ assert(img_type(idict) == IMAGE_TYPE_PNG);
+ img_totalpages(idict) = 1;
+ img_pagenum(idict) = 1;
+ img_xres(idict) = img_yres(idict) = 0;
+ assert(img_file(idict) == NULL);
+ img_file(idict) = xfopen(img_filepath(idict), FOPEN_RBIN_MODE);
+ assert(img_png_ptr(idict) == NULL);
+ img_png_ptr(idict) = xtalloc(1, png_img_struct);
+ if ((png_p = png_create_read_struct(PNG_LIBPNG_VER_STRING,
+ NULL, NULL, NULL)) == NULL)
+ pdftex_fail("libpng: png_create_read_struct() failed");
+ img_png_png_ptr(idict) = png_p;
+ if ((info_p = png_create_info_struct(png_p)) == NULL)
+ pdftex_fail("libpng: png_create_info_struct() failed");
+ img_png_info_ptr(idict) = info_p;
+ if (setjmp(png_p->jmpbuf))
+ pdftex_fail("libpng: internal error");
+ png_init_io(png_p, img_file(idict));
+ png_read_info(png_p, info_p);
+ /* simple transparency support */
+ if (png_get_valid(png_p, info_p, PNG_INFO_tRNS)) {
+ png_set_tRNS_to_alpha(png_p);
+ }
+ /* alpha channel support */
+ if (fixed_pdf_minor_version < 4 && png_p->color_type | PNG_COLOR_MASK_ALPHA)
+ png_set_strip_alpha(png_p);
+ /* 16bit depth support */
+ if (fixed_pdf_minor_version < 5)
+ fixed_image_hicolor = 0;
+ if (info_p->bit_depth == 16 && !fixed_image_hicolor)
+ png_set_strip_16(png_p);
+ /* gamma support */
+ if (fixed_image_apply_gamma) {
+ if (png_get_gAMA(png_p, info_p, &gamma))
+ png_set_gamma(png_p, (fixed_gamma / 1000.0), gamma);
+ else
+ png_set_gamma(png_p, (fixed_gamma / 1000.0),
+ (1000.0 / fixed_image_gamma));
+ }
+ /* reset structure */
+ png_read_update_info(png_p, info_p);
+ /* resolution support */
+ img_xsize(idict) = info_p->width;
+ img_ysize(idict) = info_p->height;
+ if (info_p->valid & PNG_INFO_pHYs) {
+ img_xres(idict) =
+ round(0.0254 * png_get_x_pixels_per_meter(png_p, info_p));
+ img_yres(idict) =
+ round(0.0254 * png_get_y_pixels_per_meter(png_p, info_p));
+ }
+ switch (info_p->color_type) {
+ case PNG_COLOR_TYPE_PALETTE:
+ img_color(idict) = IMAGE_COLOR_C | IMAGE_COLOR_I;
+ break;
+ case PNG_COLOR_TYPE_GRAY:
+ case PNG_COLOR_TYPE_GRAY_ALPHA:
+ img_color(idict) = IMAGE_COLOR_B;
+ break;
+ case PNG_COLOR_TYPE_RGB:
+ case PNG_COLOR_TYPE_RGB_ALPHA:
+ img_color(idict) = IMAGE_COLOR_C;
+ break;
+ default:
+ pdftex_fail("unsupported type of color_type <%i>", info_p->color_type);
+ }
+ img_colordepth(idict) = info_p->bit_depth;
+ if (readtype == IMG_CLOSEINBETWEEN)
+ close_and_cleanup_png(idict);
+}
+
+#define write_gray_pixel_16(r) \
+ if (j % 4 == 0||j % 4 == 1) pdf_buf[pdf_ptr++] = *r++; \
+ else smask[smask_ptr++] = *r++
+
+#define write_gray_pixel_8(r) \
+ if (j % 2 == 0) pdf_buf[pdf_ptr++] = *r++; \
+ else smask[smask_ptr++] = *r++
+
+
+#define write_rgb_pixel_16(r) \
+ if (!(j % 8 == 6||j % 8 == 7)) pdf_buf[pdf_ptr++] = *r++; \
+ else smask[smask_ptr++] = *r++
+
+#define write_rgb_pixel_8(r) \
+ if (j % 4 != 3) pdf_buf[pdf_ptr++] = *r++; \
+ else smask[smask_ptr++] = *r++
+
+#define write_simple_pixel(r) pdf_buf[pdf_ptr++] = *r++
+
+#define write_noninterlaced(outmac) \
+ for (i = 0; (unsigned) i < (int)info_p->height; i++) { \
+ png_read_row(png_p, row, NULL); \
+ r = row; \
+ k = info_p->rowbytes; \
+ while(k > 0) { \
+ l = (k > pdf_buf_size)? pdf_buf_size : k; \
+ pdfroom(l); \
+ for (j = 0; j < l; j++) { \
+ outmac; \
+ } \
+ k -= l; \
+ } \
+ }
+
+#define write_interlaced(outmac) \
+ for (i = 0; (unsigned) i < (int)info_p->height; i++) { \
+ row = rows[i]; \
+ k = info_p->rowbytes; \
+ while(k > 0) { \
+ l = (k > pdf_buf_size)? pdf_buf_size : k;\
+ pdfroom(l); \
+ for (j = 0; j < l; j++) { \
+ outmac; \
+ } \
+ k -= l; \
+ } \
+ xfree(rows[i]); \
+ }
+
+void write_png_palette(image_dict * idict)
+{
+ int i, j, k, l;
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ png_bytep row, r, *rows;
+ integer palette_objnum = 0;
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ pdf_create_obj(0, 0);
+ palette_objnum = obj_ptr;
+ pdf_printf("[/Indexed /DeviceRGB %i %i 0 R]\n",
+ (int) (info_p->num_palette - 1), (int) palette_objnum);
+ }
+ pdf_begin_stream();
+ if (info_p->interlace_type == PNG_INTERLACE_NONE) {
+ row = xtalloc(info_p->rowbytes, png_byte);
+ write_noninterlaced(write_simple_pixel(r));
+ xfree(row);
+ } else {
+ if (info_p->height * info_p->rowbytes >= 10240000L)
+ pdftex_warn
+ ("large interlaced PNG might cause out of memory (use non-interlaced PNG to fix this)");
+ rows = xtalloc(info_p->height, png_bytep);
+ for (i = 0; (unsigned) i < info_p->height; i++)
+ rows[i] = xtalloc(info_p->rowbytes, png_byte);
+ png_read_image(png_p, rows);
+ write_interlaced(write_simple_pixel(row));
+ xfree(rows);
+ }
+ pdf_end_stream();
+ if (palette_objnum > 0) {
+ pdf_begin_dict(palette_objnum, 0);
+ pdf_begin_stream();
+ for (i = 0; (unsigned) i < info_p->num_palette; i++) {
+ pdfroom(3);
+ pdf_buf[pdf_ptr++] = info_p->palette[i].red;
+ pdf_buf[pdf_ptr++] = info_p->palette[i].green;
+ pdf_buf[pdf_ptr++] = info_p->palette[i].blue;
+ }
+ pdf_end_stream();
+ }
+}
+
+void write_png_gray(image_dict * idict)
+{
+ int i, j, k, l;
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ png_bytep row, r, *rows;
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ pdf_puts("/DeviceGray\n");
+ }
+ pdf_begin_stream();
+ if (info_p->interlace_type == PNG_INTERLACE_NONE) {
+ row = xtalloc(info_p->rowbytes, png_byte);
+ write_noninterlaced(write_simple_pixel(r));
+ xfree(row);
+ } else {
+ if (info_p->height * info_p->rowbytes >= 10240000L)
+ pdftex_warn
+ ("large interlaced PNG might cause out of memory (use non-interlaced PNG to fix this)");
+ rows = xtalloc(info_p->height, png_bytep);
+ for (i = 0; (unsigned) i < info_p->height; i++)
+ rows[i] = xtalloc(info_p->rowbytes, png_byte);
+ png_read_image(png_p, rows);
+ write_interlaced(write_simple_pixel(row));
+ xfree(rows);
+ }
+ pdf_end_stream();
+}
+
+void write_png_gray_alpha(image_dict * idict)
+{
+ int i, j, k, l;
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ png_bytep row, r, *rows;
+ integer smask_objnum = 0;
+ png_bytep smask;
+ integer smask_ptr = 0;
+ integer smask_size = 0;
+ int bitdepth;
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ pdf_puts("/DeviceGray\n");
+ }
+ pdf_create_obj(0, 0);
+ smask_objnum = obj_ptr;
+ pdf_printf("/SMask %i 0 R\n", (int) smask_objnum);
+ smask_size = (info_p->rowbytes / 2) * info_p->height;
+ smask = xtalloc(smask_size, png_byte);
+ pdf_begin_stream();
+ if (info_p->interlace_type == PNG_INTERLACE_NONE) {
+ row = xtalloc(info_p->rowbytes, png_byte);
+ if ((info_p->bit_depth == 16) && fixed_image_hicolor) {
+ write_noninterlaced(write_gray_pixel_16(r));
+ } else {
+ write_noninterlaced(write_gray_pixel_8(r));
+ }
+ xfree(row);
+ } else {
+ if (info_p->height * info_p->rowbytes >= 10240000L)
+ pdftex_warn
+ ("large interlaced PNG might cause out of memory (use non-interlaced PNG to fix this)");
+ rows = xtalloc(info_p->height, png_bytep);
+ for (i = 0; (unsigned) i < info_p->height; i++)
+ rows[i] = xtalloc(info_p->rowbytes, png_byte);
+ png_read_image(png_p, rows);
+ if ((info_p->bit_depth == 16) && fixed_image_hicolor) {
+ write_interlaced(write_gray_pixel_16(row));
+ } else {
+ write_interlaced(write_gray_pixel_8(row));
+ }
+ xfree(rows);
+ }
+ pdf_end_stream();
+ pdf_flush();
+ /* now write the Smask object */
+ bitdepth = (int) info_p->bit_depth;
+ pdf_begin_dict(smask_objnum, 0);
+ pdf_puts("/Type /XObject\n/Subtype /Image\n");
+ if (img_attr(idict) != NULL && strlen(img_attr(idict)) > 0)
+ pdf_printf("%s\n", img_attr(idict));
+ pdf_printf("/Width %i\n/Height %i\n/BitsPerComponent %i\n",
+ (int) info_p->width,
+ (int) info_p->height, (bitdepth == 16 ? 8 : bitdepth));
+ pdf_puts("/ColorSpace /DeviceGray\n");
+ pdf_begin_stream();
+ for (i = 0; i < smask_size; i++) {
+ if (i % 8 == 0)
+ pdfroom(8);
+ pdf_buf[pdf_ptr++] = smask[i];
+ if (bitdepth == 16)
+ i++;
+ }
+ pdf_end_stream();
+ xfree(smask);
+}
+
+void write_png_rgb(image_dict * idict)
+{
+ int i, j, k, l;
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ png_bytep row, r, *rows;
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ pdf_puts("/DeviceRGB\n");
+ }
+ pdf_begin_stream();
+ if (info_p->interlace_type == PNG_INTERLACE_NONE) {
+ row = xtalloc(info_p->rowbytes, png_byte);
+ write_noninterlaced(write_simple_pixel(r));
+ xfree(row);
+ } else {
+ if (info_p->height * info_p->rowbytes >= 10240000L)
+ pdftex_warn
+ ("large interlaced PNG might cause out of memory (use non-interlaced PNG to fix this)");
+ rows = xtalloc(info_p->height, png_bytep);
+ for (i = 0; (unsigned) i < info_p->height; i++)
+ rows[i] = xtalloc(info_p->rowbytes, png_byte);
+ png_read_image(png_p, rows);
+ write_interlaced(write_simple_pixel(row));
+ xfree(rows);
+ }
+ pdf_end_stream();
+}
+
+void write_png_rgb_alpha(image_dict * idict)
+{
+ int i, j, k, l;
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ png_bytep row, r, *rows;
+ integer smask_objnum = 0;
+ png_bytep smask;
+ integer smask_ptr = 0;
+ integer smask_size = 0;
+ int bitdepth;
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ pdf_puts("/DeviceRGB\n");
+ }
+ pdf_create_obj(0, 0);
+ smask_objnum = obj_ptr;
+ pdf_printf("/SMask %i 0 R\n", (int) smask_objnum);
+ smask_size = (info_p->rowbytes / 2) * info_p->height;
+ smask = xtalloc(smask_size, png_byte);
+ pdf_begin_stream();
+ if (info_p->interlace_type == PNG_INTERLACE_NONE) {
+ row = xtalloc(info_p->rowbytes, png_byte);
+ if ((info_p->bit_depth == 16) && fixed_image_hicolor) {
+ write_noninterlaced(write_rgb_pixel_16(r));
+ } else {
+ write_noninterlaced(write_rgb_pixel_8(r));
+ }
+ xfree(row);
+ } else {
+ if (info_p->height * info_p->rowbytes >= 10240000L)
+ pdftex_warn
+ ("large interlaced PNG might cause out of memory (use non-interlaced PNG to fix this)");
+ rows = xtalloc(info_p->height, png_bytep);
+ for (i = 0; (unsigned) i < info_p->height; i++)
+ rows[i] = xtalloc(info_p->rowbytes, png_byte);
+ png_read_image(png_p, rows);
+ if ((info_p->bit_depth == 16) && fixed_image_hicolor) {
+ write_interlaced(write_rgb_pixel_16(row));
+ } else {
+ write_interlaced(write_rgb_pixel_8(row));
+ }
+ xfree(rows);
+ }
+ pdf_end_stream();
+ pdf_flush();
+ /* now write the Smask object */
+ if (smask_objnum > 0) {
+ bitdepth = (int) info_p->bit_depth;
+ pdf_begin_dict(smask_objnum, 0);
+ pdf_puts("/Type /XObject\n/Subtype /Image\n");
+ if (img_attr(idict) != NULL)
+ pdf_printf("%s\n", img_attr(idict));
+ pdf_printf("/Width %i\n/Height %i\n/BitsPerComponent %i\n",
+ (int) info_p->width,
+ (int) info_p->height, (bitdepth == 16 ? 8 : bitdepth));
+ pdf_puts("/ColorSpace /DeviceGray\n");
+ pdf_begin_stream();
+ for (i = 0; i < smask_size; i++) {
+ if (i % 8 == 0)
+ pdfroom(8);
+ pdf_buf[pdf_ptr++] = smask[i];
+ if (bitdepth == 16)
+ i++;
+ }
+ xfree(smask);
+ pdf_end_stream();
+ }
+}
+
+/**********************************************************************/
+/*
+ * The |copy_png| function is from Hartmut Henkel. The goal is to use
+ * pdf's native FlateDecode support if that is possible.
+ *
+ * Only a subset of the png files allows this, but when possible it
+ * greatly improves inclusion speed.
+ *
+ * Code cheerfully gleaned from Thomas Merz' PDFlib,
+ * file p_png.c "SPNG - Simple PNG"
+ */
+
+static int spng_getint(FILE * fp)
+{
+ unsigned char buf[4];
+ if (fread(buf, 1, 4, fp) != 4)
+ pdftex_fail("writepng: reading chunk type failed");
+ return ((((((int) buf[0] << 8) + buf[1]) << 8) + buf[2]) << 8) + buf[3];
+}
+
+#define SPNG_CHUNK_IDAT 0x49444154
+#define SPNG_CHUNK_IEND 0x49454E44
+
+void copy_png(image_dict * idict)
+{
+ assert(idict != NULL);
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ FILE *fp = (FILE *) png_p->io_ptr;
+ int i, len, type, streamlength = 0;
+ boolean endflag = false;
+ int idat = 0; /* flag to check continuous IDAT chunks sequence */
+ /* 1st pass to find overall stream /Length */
+ if (fseek(fp, 8, SEEK_SET) != 0)
+ pdftex_fail("writepng: fseek in PNG file failed");
+ do {
+ len = spng_getint(fp);
+ type = spng_getint(fp);
+ switch (type) {
+ case SPNG_CHUNK_IEND:
+ endflag = true;
+ break;
+ case SPNG_CHUNK_IDAT:
+ streamlength += len;
+ default:
+ if (fseek(fp, len + 4, SEEK_CUR) != 0)
+ pdftex_fail("writepng: fseek in PNG file failed");
+ }
+ } while (endflag == false);
+ pdf_printf("/Length %d\n", streamlength);
+ pdf_printf("/Filter /FlateDecode\n");
+ pdf_printf("/DecodeParms << ");
+ pdf_printf("/Colors %d ", info_p->color_type == 2 ? 3 : 1);
+ pdf_printf("/Columns %d ", (int) info_p->width);
+ pdf_printf("/BitsPerComponent %i ", (int) info_p->bit_depth);
+ pdf_printf("/Predictor %d ", 10); /* actual predictor defined on line basis */
+ pdf_printf(">>\n>>\nstream\n");
+ /* 2nd pass to copy data */
+ endflag = false;
+ if (fseek(fp, 8, SEEK_SET) != 0)
+ pdftex_fail("writepng: fseek in PNG file failed");
+ do {
+ len = spng_getint(fp);
+ type = spng_getint(fp);
+ switch (type) {
+ case SPNG_CHUNK_IDAT: /* do copy */
+ if (idat == 2)
+ pdftex_fail("writepng: IDAT chunk sequence broken");
+ idat = 1;
+ while (len > 0) {
+ i = (len > pdf_buf_size) ? pdf_buf_size : len;
+ pdfroom(i);
+ fread(&pdf_buf[pdf_ptr], 1, i, fp);
+ pdf_ptr += i;
+ len -= i;
+ }
+ if (fseek(fp, 4, SEEK_CUR) != 0)
+ pdftex_fail("writepng: fseek in PNG file failed");
+ break;
+ case SPNG_CHUNK_IEND: /* done */
+ pdf_end_stream();
+ endflag = true;
+ break;
+ default:
+ if (idat == 1)
+ idat = 2;
+ if (fseek(fp, len + 4, SEEK_CUR) != 0)
+ pdftex_fail("writepng: fseek in PNG file failed");
+ }
+ } while (endflag == false);
+}
+
+void reopen_png(image_dict * idict)
+{
+ integer width, height, xres, yres;
+ width = img_xsize(idict); /* do consistency check */
+ height = img_ysize(idict);
+ xres = img_xres(idict);
+ yres = img_yres(idict);
+ read_png_info(idict, IMG_KEEPOPEN);
+ if (width != img_xsize(idict) || height != img_ysize(idict)
+ || xres != img_xres(idict) || yres != img_yres(idict))
+ pdftex_fail("writepng: image dimensions have changed");
+}
+
+void write_png(image_dict * idict)
+{
+ double gamma, checked_gamma;
+ int i;
+ integer palette_objnum = 0;
+ assert(idict != NULL);
+ if (img_file(idict) == NULL)
+ reopen_png(idict);
+ assert(img_png_ptr(idict) != NULL);
+ png_structp png_p = img_png_png_ptr(idict);
+ png_infop info_p = img_png_info_ptr(idict);
+ if (fixed_pdf_minor_version < 5)
+ fixed_image_hicolor = 0;
+ pdf_puts("/Type /XObject\n/Subtype /Image\n");
+ if (img_attr(idict) != NULL && strlen(img_attr(idict)) > 0)
+ pdf_printf("%s\n", img_attr(idict));
+ pdf_printf("/Width %i\n/Height %i\n/BitsPerComponent %i\n",
+ (int) info_p->width,
+ (int) info_p->height, (int) info_p->bit_depth);
+ pdf_puts("/ColorSpace ");
+ checked_gamma = 1.0;
+ if (fixed_image_apply_gamma) {
+ if (png_get_gAMA(png_p, info_p, &gamma)) {
+ checked_gamma = (fixed_gamma / 1000.0) * gamma;
+ } else {
+ checked_gamma =
+ (fixed_gamma / 1000.0) * (1000.0 / fixed_image_gamma);
+ }
+ }
+ /* the switching between |info_p| and |png_p| queries has been trial and error.
+ */
+ if (fixed_pdf_minor_version > 1 && info_p->interlace_type == PNG_INTERLACE_NONE && (png_p->transformations == 0 || png_p->transformations == 0x2000) /* gamma */
+ &&!(png_p->color_type == PNG_COLOR_TYPE_GRAY_ALPHA ||
+ png_p->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+ && (fixed_image_hicolor || (png_p->bit_depth <= 8))
+ && (checked_gamma <= 1.01 && checked_gamma > 0.99)
+ ) {
+ if (img_colorspace(idict) != 0) {
+ pdf_printf("%i 0 R\n", (int) img_colorspace(idict));
+ } else {
+ switch (info_p->color_type) {
+ case PNG_COLOR_TYPE_PALETTE:
+ pdf_create_obj(0, 0);
+ palette_objnum = obj_ptr;
+ pdf_printf("[/Indexed /DeviceRGB %i %i 0 R]\n",
+ (int) (info_p->num_palette - 1),
+ (int) palette_objnum);
+ break;
+ case PNG_COLOR_TYPE_GRAY:
+ pdf_puts("/DeviceGray\n");
+ break;
+ default: /* RGB */
+ pdf_puts("/DeviceRGB\n");
+ };
+ }
+ if (tracefilenames)
+ tex_printf(" (PNG copy)");
+ copy_png(idict);
+ if (palette_objnum > 0) {
+ pdf_begin_dict(palette_objnum, 0);
+ pdf_begin_stream();
+ for (i = 0; (unsigned) i < info_p->num_palette; i++) {
+ pdfroom(3);
+ pdf_buf[pdf_ptr++] = info_p->palette[i].red;
+ pdf_buf[pdf_ptr++] = info_p->palette[i].green;
+ pdf_buf[pdf_ptr++] = info_p->palette[i].blue;
+ }
+ pdf_end_stream();
+ }
+ } else {
+ if (0) {
+ tex_printf(" PNG copy skipped because: ");
+ if (fixed_image_apply_gamma &&
+ (checked_gamma > 1.01 || checked_gamma < 0.99))
+ tex_printf("gamma delta=%lf ", checked_gamma);
+ if (png_p->transformations != PNG_TRANSFORM_IDENTITY)
+ tex_printf("transform=%lu", (long) png_p->transformations);
+ if ((info_p->color_type != PNG_COLOR_TYPE_GRAY)
+ && (info_p->color_type != PNG_COLOR_TYPE_RGB)
+ && (info_p->color_type != PNG_COLOR_TYPE_PALETTE))
+ tex_printf("colortype ");
+ if (fixed_pdf_minor_version <= 1)
+ tex_printf("version=%d ", (int) fixed_pdf_minor_version);
+ if (info_p->interlace_type != PNG_INTERLACE_NONE)
+ tex_printf("interlaced ");
+ if (info_p->bit_depth > 8)
+ tex_printf("bitdepth=%d ", info_p->bit_depth);
+ if (png_get_valid(png_p, info_p, PNG_INFO_tRNS))
+ tex_printf("simple transparancy ");
+ }
+ switch (info_p->color_type) {
+ case PNG_COLOR_TYPE_PALETTE:
+ write_png_palette(idict);
+ break;
+ case PNG_COLOR_TYPE_GRAY:
+ write_png_gray(idict);
+ break;
+ case PNG_COLOR_TYPE_GRAY_ALPHA:
+ if (fixed_pdf_minor_version >= 4)
+ write_png_gray_alpha(idict);
+ else
+ write_png_gray(idict);
+ break;
+ case PNG_COLOR_TYPE_RGB:
+ write_png_rgb(idict);
+ break;
+ case PNG_COLOR_TYPE_RGB_ALPHA:
+ if (fixed_pdf_minor_version >= 4)
+ write_png_rgb_alpha(idict);
+ else
+ write_png_rgb(idict);
+ break;
+ default:
+ pdftex_fail("unsupported type of color_type <%i>",
+ info_p->color_type);
+ }
+ }
+ pdf_flush();
+ close_and_cleanup_png(idict);
+}
diff --git a/Build/source/texk/web2c/luatexdir/lang/hnjalloc.c b/Build/source/texk/web2c/luatexdir/lang/hnjalloc.c
new file mode 100644
index 00000000000..59d62e2aabb
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lang/hnjalloc.c
@@ -0,0 +1,72 @@
+/* LibHnj is dual licensed under LGPL and MPL. Boilerplate for both
+ * licenses follows.
+ */
+
+/* LibHnj - a library for high quality hyphenation and justification
+ * Copyright (C) 1998 Raph Levien, (C) 2001 ALTLinux, Moscow
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Library General Public License for more details.
+ *
+ * You should have received a copy of the GNU Library General Public
+ * License along with this library; if not, write to the
+ * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ * Boston, MA 02111-1307 USA.
+*/
+
+/*
+ * The contents of this file are subject to the Mozilla Public License
+ * Version 1.0 (the "MPL"); you may not use this file except in
+ * compliance with the MPL. You may obtain a copy of the MPL at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the MPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the MPL
+ * for the specific language governing rights and limitations under the
+ * MPL.
+ *
+ */
+/* wrappers for malloc */
+
+#include <stdlib.h>
+#include <stdio.h>
+
+void *
+hnj_malloc (int size)
+{
+ void *p;
+
+ p = malloc (size);
+ if (p == NULL)
+ {
+ fprintf (stderr, "can't allocate %d bytes\n", size);
+ exit (1);
+ }
+ return p;
+}
+
+void *
+hnj_realloc (void *p, int size)
+{
+ p = realloc (p, size);
+ if (p == NULL)
+ {
+ fprintf (stderr, "can't allocate %d bytes\n", size);
+ exit (1);
+ }
+ return p;
+}
+
+void
+hnj_free (void *p)
+{
+ free (p);
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lang/hnjalloc.h b/Build/source/texk/web2c/luatexdir/lang/hnjalloc.h
new file mode 100644
index 00000000000..db82fb9c758
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lang/hnjalloc.h
@@ -0,0 +1,46 @@
+/* LibHnj is dual licensed under LGPL and MPL. Boilerplate for both
+ * licenses follows.
+ */
+
+/* LibHnj - a library for high quality hyphenation and justification
+ * Copyright (C) 1998 Raph Levien
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Library General Public License for more details.
+ *
+ * You should have received a copy of the GNU Library General Public
+ * License along with this library; if not, write to the
+ * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ * Boston, MA 02111-1307 USA.
+*/
+
+/*
+ * The contents of this file are subject to the Mozilla Public License
+ * Version 1.0 (the "MPL"); you may not use this file except in
+ * compliance with the MPL. You may obtain a copy of the MPL at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the MPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the MPL
+ * for the specific language governing rights and limitations under the
+ * MPL.
+ *
+ */
+/* wrappers for malloc */
+
+void *
+hnj_malloc (int size);
+
+void *
+hnj_realloc (void *p, int size);
+
+void
+hnj_free (void *p);
+
diff --git a/Build/source/texk/web2c/luatexdir/lang/hyphen.c b/Build/source/texk/web2c/luatexdir/lang/hyphen.c
new file mode 100644
index 00000000000..140cde8d768
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lang/hyphen.c
@@ -0,0 +1,830 @@
+/* Libhnj is dual licensed under LGPL and MPL. Boilerplate for both
+ * licenses follows.
+ */
+
+/* LibHnj - a library for high quality hyphenation and justification
+ * Copyright (C) 1998 Raph Levien,
+ * (C) 2001 ALTLinux, Moscow (http://www.alt-linux.org),
+ * (C) 2001 Peter Novodvorsky (nidd@cs.msu.su)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Library General Public License for more details.
+ *
+ * You should have received a copy of the GNU Library General Public
+ * License along with this library; if not, write to the
+ * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ * Boston, MA 02111-1307 USA.
+*/
+
+/*
+ * The contents of this file are subject to the Mozilla Public License
+ * Version 1.0 (the "MPL"); you may not use this file except in
+ * compliance with the MPL. You may obtain a copy of the MPL at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the MPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the MPL
+ * for the specific language governing rights and limitations under the
+ * MPL.
+ *
+ */
+#include <stdlib.h> /* for NULL, malloc */
+#include <stdio.h> /* for fprintf */
+#include <string.h> /* for strdup */
+#include <stdlib.h> /* for malloc used by substring inclusion*/
+
+#define MAXPATHS 40960
+
+#ifdef UNX
+#include <unistd.h> /* for exit */
+#endif
+
+#include <ctype.h>
+
+/*#define VERBOSE*/
+
+#include "hnjalloc.h"
+#include "hyphen.h"
+
+/* SHOULD BE MOVED TO SEPARATE LIBRARY */
+static unsigned char * hnj_strdup(
+ const unsigned char *s
+) {
+ unsigned char *new;
+ int l;
+
+ l = strlen ((char*)s);
+ new = hnj_malloc (l + 1);
+ memcpy (new, s, l);
+ new[l] = 0;
+ return new;
+}
+
+static int is_utf8_follow(
+ unsigned char c
+) {
+ if (c>=0x80 && c<0xC0) return 1;
+ return 0;
+}
+
+/* --------------------------------------------------------------------
+ *
+ * Type definitions
+ *
+ * --------------------------------------------------------------------
+ */
+
+/* a little bit of a hash table implementation. This simply maps strings
+ to state numbers */
+
+typedef struct _HashTab HashTab;
+typedef struct _HashEntry HashEntry;
+typedef struct _HashIter HashIter;
+typedef union _HashVal HashVal;
+
+/* A cheap, but effective, hack. */
+#define HASH_SIZE 31627
+
+struct _HashTab {
+ HashEntry *entries[HASH_SIZE];
+};
+
+union _HashVal {
+ int state;
+ char* hyppat;
+};
+
+struct _HashEntry {
+ HashEntry *next;
+ unsigned char *key;
+ HashVal u;
+};
+
+struct _HashIter {
+ HashEntry** e;
+ HashEntry* cur;
+ int ndx;
+};
+
+/* State machine */
+typedef struct _HyphenState HyphenState;
+typedef struct _HyphenTrans HyphenTrans;
+#define MAX_CHARS 256
+#define MAX_NAME 20
+
+struct _HyphenDict {
+ int num_states;
+ int pat_length;
+ char cset[MAX_NAME];
+ HyphenState *states;
+ HashTab *patterns;
+ HashTab *merged;
+ HashTab *state_num;
+};
+
+struct _HyphenState {
+ char *match;
+ /*char *repl;*/
+ /*signed char replindex;*/
+ /*signed char replcut;*/
+ int fallback_state;
+ int num_trans;
+ HyphenTrans *trans;
+};
+
+struct _HyphenTrans {
+ int uni_ch;
+ int new_state;
+};
+
+
+/* Combine two right-aligned number patterns, 04000 + 020 becomes 04020*/
+static char *combine(
+ char *expr,
+ const char *subexpr
+) {
+ int l1 = strlen(expr);
+ int l2 = strlen(subexpr);
+ int off = l1-l2;
+ int j;
+ /* this works also for utf8 sequences because the substring is identical
+ * to the last substring-length bytes of expr except for the (single byte)
+ * hyphenation encoders
+ */
+ for (j=0; j<l2; j++) {
+ if (expr[off+j]<subexpr[j]) expr[off+j] = subexpr[j];
+ }
+ return expr;
+}
+
+
+/* --------------------------------------------------------------------
+ * ORIGINAL CODE
+ * --------------------------------------------------------------------
+ */
+
+HashIter* new_HashIter(
+ HashTab* h
+) {
+ HashIter* i = hnj_malloc(sizeof(HashIter));
+ i->e = h->entries;
+ i->cur = NULL;
+ i->ndx = -1;
+ return i;
+}
+
+
+int nextHashStealPattern(
+ HashIter*i,
+ unsigned char**word,
+ char **pattern
+) {
+ while (i->cur==NULL) {
+ if (i->ndx >= HASH_SIZE-1) return 0;
+ i->cur = i->e[++i->ndx];
+ }
+ *word = i->cur->key;
+ *pattern = i->cur->u.hyppat;
+ i->cur->u.hyppat = NULL;
+ i->cur = i->cur->next;
+ return 1;
+}
+
+
+int nextHash(
+ HashIter*i,
+ unsigned char**word
+) {
+ while (i->cur==NULL) {
+ if (i->ndx >= HASH_SIZE-1) return 0;
+ i->cur = i->e[++i->ndx];
+ }
+ *word = i->cur->key;
+ i->cur = i->cur->next;
+ return 1;
+}
+
+
+int eachHash(
+ HashIter*i,
+ unsigned char**word,
+ char**pattern
+) {
+ while (i->cur==NULL) {
+ if (i->ndx >= HASH_SIZE-1) return 0;
+ i->cur = i->e[++i->ndx];
+ }
+ *word = i->cur->key;
+ *pattern = i->cur->u.hyppat;
+ i->cur = i->cur->next;
+ return 1;
+}
+
+
+void delete_HashIter(
+ HashIter*i
+) {
+ hnj_free(i);
+}
+
+
+/* a char* hash function from ASU - adapted from Gtk+ */
+static unsigned int hnj_string_hash (
+ const unsigned char *s
+) {
+ const unsigned char *p;
+ unsigned int h=0, g;
+
+ for (p = s; *p != '\0'; p += 1) {
+ h = ( h << 4 ) + *p;
+ if ( ( g = h & 0xf0000000 ) ) {
+ h = h ^ (g >> 24);
+ h = h ^ g;
+ }
+ }
+ return h /* % M */;
+}
+
+
+/* assumes that key is not already present! */
+static void state_insert(
+ HashTab *hashtab,
+ unsigned char *key,
+ int state
+) {
+ int i;
+ HashEntry *e;
+
+ i = hnj_string_hash (key) % HASH_SIZE;
+ e = hnj_malloc (sizeof(HashEntry));
+ e->next = hashtab->entries[i];
+ e->key = key;
+ e->u.state = state;
+ hashtab->entries[i] = e;
+}
+
+
+/* assumes that key is not already present! */
+static void hyppat_insert(
+ HashTab *hashtab,
+ unsigned char *key,
+ char* hyppat
+) {
+ int i;
+ HashEntry *e;
+
+ i = hnj_string_hash (key) % HASH_SIZE;
+ for (e = hashtab->entries[i]; e; e=e->next) {
+ if (strcmp((char*)e->key,(char*)key)==0) {
+ if (e->u.hyppat) hnj_free(e->u.hyppat);
+ e->u.hyppat = hyppat;
+ hnj_free(key);
+ return;
+ }
+ }
+ e = hnj_malloc (sizeof(HashEntry));
+ e->next = hashtab->entries[i];
+ e->key = key;
+ e->u.hyppat = hyppat;
+ hashtab->entries[i] = e;
+}
+
+
+/* return state if found, otherwise -1 */
+static int state_lookup(
+ HashTab *hashtab,
+ const unsigned char *key
+) {
+ int i;
+ HashEntry *e;
+
+ i = hnj_string_hash (key) % HASH_SIZE;
+ for (e = hashtab->entries[i]; e; e = e->next) {
+ if (!strcmp ((char*)key, (char*)e->key)) {
+ return e->u.state;
+ }
+ }
+ return -1;
+}
+
+
+/* return state if found, otherwise -1 */
+static char* hyppat_lookup(
+ HashTab *hashtab,
+ const unsigned char *chars,
+ int l
+) {
+ int i;
+ HashEntry *e;
+ unsigned char key[128]; /* should be ample*/
+ strncpy((char*)key,(char*)chars,l); key[l]=0;
+ i = hnj_string_hash (key) % HASH_SIZE;
+ for (e = hashtab->entries[i]; e; e = e->next) {
+ if (!strcmp ((char*)key, (char*)e->key)) {
+ return e->u.hyppat;
+ }
+ }
+ return NULL;
+}
+
+
+/* Get the state number, allocating a new state if necessary. */
+static int hnj_get_state(
+ HyphenDict *dict,
+ const unsigned char *string,
+ int *state_num
+) {
+ *state_num = state_lookup(dict->state_num, string);
+
+ if (*state_num >= 0)
+ return *state_num;
+
+ state_insert(dict->state_num, hnj_strdup(string), dict->num_states);
+ /* predicate is true if dict->num_states is a power of two */
+ if (!(dict->num_states & (dict->num_states - 1))) {
+ dict->states = hnj_realloc(
+ dict->states,
+ (dict->num_states << 1) * sizeof(HyphenState));
+ }
+ dict->states[dict->num_states].match = NULL;
+ dict->states[dict->num_states].fallback_state = -1;
+ dict->states[dict->num_states].num_trans = 0;
+ dict->states[dict->num_states].trans = NULL;
+ return dict->num_states++;
+}
+
+
+/* add a transition from state1 to state2 through ch - assumes that the
+ transition does not already exist */
+static void hnj_add_trans(
+ HyphenDict *dict,
+ int state1,
+ int state2,
+ int uni_ch
+) {
+ int num_trans;
+ /* TH: this test was a bit too strict, it is quite normal for old
+ patterns to have chars in the range 0-31 or 127-159 (inclusive).
+ To ease the transition, let's only disallow NUL for now
+ (this is probably a requirement of the code anyway).
+ */
+ if (uni_ch==0) {
+ fprintf(stderr,"Character out of bounds: u%04x \n",uni_ch);
+ exit(1);
+ }
+ num_trans = dict->states[state1].num_trans;
+ if (num_trans == 0) {
+ dict->states[state1].trans = hnj_malloc(sizeof(HyphenTrans));
+ } else if (!(num_trans & (num_trans - 1))) {
+ dict->states[state1].trans = hnj_realloc(
+ dict->states[state1].trans,
+ (num_trans << 1) * sizeof(HyphenTrans));
+ }
+ dict->states[state1].trans[num_trans].uni_ch = uni_ch;
+ dict->states[state1].trans[num_trans].new_state = state2;
+ dict->states[state1].num_trans++;
+}
+
+
+#ifdef VERBOSE
+
+static unsigned char *get_state_str(
+ int state
+) {
+ int i;
+ HashEntry *e;
+
+ for (i = 0; i < HASH_SIZE; i++)
+ for (e = global->entries[i]; e; e = e->next)
+ if (e->u.state == state)
+ return e->key;
+ return NULL;
+}
+#endif
+
+
+/* I've changed the semantics a bit here: hnj_hyphen_load used to
+ operate on a file, but now the argument is a string buffer.
+ */
+
+static const unsigned char* next_pattern(
+ size_t* length,
+ const unsigned char **buf
+) {
+ const unsigned char *rover = *buf;
+ while (*rover && isspace(*rover)) rover++;
+ const unsigned char *here = rover;
+ while (*rover) {
+ if (isspace(*rover)) {
+ *length = rover-here;
+ *buf = rover;
+ return here;
+ }
+ rover++;
+ }
+ *length = rover-here;
+ *buf = rover;
+ return *length ? here : NULL; /* zero sensed */
+}
+
+static void init_hash(
+ HashTab**h
+) {
+ if (*h) return;
+ int i;
+ *h = hnj_malloc(sizeof(HashTab));
+ for (i = 0; i < HASH_SIZE; i++) (*h)->entries[i] = NULL;
+}
+
+
+static void clear_state_hash(
+ HashTab**h
+) {
+ if (*h==NULL) return;
+ int i;
+ for (i = 0; i < HASH_SIZE; i++) {
+ HashEntry *e, *next;
+ for (e = (*h)->entries[i]; e; e = next) {
+ next = e->next;
+ hnj_free (e->key);
+ hnj_free (e);
+ }
+ }
+ hnj_free(*h);
+ *h=NULL;
+}
+
+
+static void clear_hyppat_hash(
+ HashTab**h
+) {
+ if (*h==NULL) return;
+ int i;
+ for (i = 0; i < HASH_SIZE; i++) {
+ HashEntry *e, *next;
+ for (e = (*h)->entries[i]; e; e = next) {
+ next = e->next;
+ hnj_free(e->key);
+ if (e->u.hyppat) hnj_free(e->u.hyppat);
+ hnj_free(e);
+ }
+ }
+ hnj_free(*h);
+ *h=NULL;
+}
+
+
+static void init_dict(
+ HyphenDict* dict
+) {
+ dict->num_states = 1;
+ dict->pat_length = 0;
+ dict->states = hnj_malloc (sizeof(HyphenState));
+ dict->states[0].match = NULL;
+ dict->states[0].fallback_state = -1;
+ dict->states[0].num_trans = 0;
+ dict->states[0].trans = NULL;
+ dict->patterns = NULL;
+ dict->merged = NULL;
+ dict->state_num = NULL;
+ init_hash(&dict->patterns);
+}
+
+
+static void clear_dict(
+ HyphenDict* dict
+) {
+ int state_num;
+ for (state_num = 0; state_num < dict->num_states; state_num++) {
+ HyphenState *hstate = &dict->states[state_num];
+ if (hstate->match) hnj_free (hstate->match);
+ if (hstate->trans) hnj_free (hstate->trans);
+ }
+ hnj_free (dict->states);
+ clear_hyppat_hash(&dict->patterns);
+ clear_hyppat_hash(&dict->merged);
+ clear_state_hash(&dict->state_num);
+}
+
+
+
+HyphenDict* hnj_hyphen_new() {
+ HyphenDict* dict = hnj_malloc (sizeof(HyphenDict));
+ init_dict(dict);
+ return dict;
+}
+
+
+void hnj_hyphen_clear(
+ HyphenDict* dict
+) {
+ clear_dict(dict);
+ init_dict(dict);
+}
+
+
+void hnj_hyphen_free(
+ HyphenDict *dict
+) {
+ clear_dict(dict);
+ hnj_free(dict);
+}
+
+unsigned char* hnj_serialize(
+ HyphenDict* dict
+) {
+ HashIter *v;
+ unsigned char* word;
+ char* pattern;
+ unsigned char* buf = hnj_malloc(dict->pat_length);
+ unsigned char* cur = buf;
+ v = new_HashIter(dict->patterns);
+ while (eachHash(v,&word,&pattern)) {
+ int i=0, e=0;
+ while(word[e+i]) {
+ if (pattern[i]!='0') *cur++ = (unsigned char) pattern[i];
+ *cur++ = word[e+i++];
+ while (is_utf8_follow(word[e+i])) *cur++ = word[i+e++];
+ }
+ if (pattern[i]!='0') *cur++ = (unsigned char) pattern[i];
+ *cur++ = ' ';
+ }
+ delete_HashIter(v);
+ *cur = 0;
+ return buf;
+}
+
+
+void hnj_free_serialize(
+ unsigned char* c
+) {
+ hnj_free(c);
+}
+
+
+/* hyphenation pattern:
+ * signed bytes
+ * 0 indicates end (actually any negative number)
+ * : prio(1+),startpos,length,len1,[replace],len2,[replace]
+ * most basic example is:
+ * p n 0 0 0
+ * for a hyphenation point between characters
+ */
+
+
+void hnj_hyphen_load(
+ HyphenDict* dict,
+ const unsigned char *f
+) {
+ int state_num, last_state;
+ int i, j = 0;
+ int ch;
+ int found;
+ HashEntry *e;
+ HashIter *v;
+ unsigned char* word;
+ char* pattern;
+ size_t l = 0;
+
+
+ /***************************************/
+
+ const unsigned char* format;
+ const unsigned char* begin = f;
+ while((format = next_pattern(&l,&f))!=NULL) {
+ int i,j,e;
+ /*
+ printf("%s\n",format);
+ char* repl = strnchr(format, '/',l);
+ int replindex = 0;
+ int replcut = 0;
+ if (repl) {
+ int clen = l-(repl-format);
+ l = repl-format;
+ char * index = strnchr(repl + 1, ',',clen);
+ if (index) {
+ char * index2 = strnchr(index + 1, ',',clen-(index-repl));
+ if (index2) {
+ replindex = (signed char) atoi(index + 1) - 1;
+ replcut = (signed char) atoi(index2 + 1);
+ }
+ } else {
+ hnj_strchomp(repl + 1);
+ replindex = 0;
+ replcut = strlen(buf);
+ }
+ repl = hnj_strdup(repl + 1);
+ }
+ */
+ for (i=0,j=0,e=0; i<l; i++) {
+ if (format[i]>='0'&&format[i]<='9') j++;
+ if (is_utf8_follow(format[i])) e++;
+ }
+ /* l-e => number of _characters_ not _bytes_*/
+ /* l-e-j => number of pattern characters*/
+ unsigned char *pat = (unsigned char*) malloc(1+l-j);
+ char *org = ( char*) malloc(2+l-e-j);
+ /* remove hyphenation encoders (digits) from pat*/
+ org[0] = '0';
+ for (i=0,j=0,e=0; i<l; i++) {
+ unsigned char c = format[i];
+ if (is_utf8_follow(c)) {
+ pat[j+e++] = c;
+ } else if (c<'0' || c>'9') {
+ pat[e+j++] = c;
+ org[j] = '0';
+ } else {
+ org[j] = c;
+ }
+ }
+ pat[e+j] = 0;
+ org[j+1] = 0;
+ hyppat_insert(dict->patterns,pat,org);
+ }
+ dict->pat_length += (f-begin)+2; /* 2 for spurious spaces*/
+ init_hash(&dict->merged);
+ v = new_HashIter(dict->patterns);
+ while (nextHash(v,&word)) {
+ int wordsize = strlen((char*)word);
+ int j,l;
+ for (l=1; l<=wordsize; l++) {
+ if (is_utf8_follow(word[l])) continue; /* Do not clip an utf8 sequence*/
+ for (j=1; j<=l; j++) {
+ int i = l-j;
+ if (is_utf8_follow(word[i])) continue; /* Do not start halfway an utf8 sequence*/
+ char *subpat_pat;
+ if ((subpat_pat = hyppat_lookup(dict->patterns,word+i,j))!=NULL) {
+ char* newpat_pat;
+ if ((newpat_pat = hyppat_lookup(dict->merged,word,l))==NULL) {
+ unsigned char *newword=(unsigned char*)malloc(l+1);
+ strncpy((char*)newword, (char*)word,l); newword[l]=0;
+ int e=0;
+ for (i=0; i<l; i++) if (is_utf8_follow(newword[i])) e++;
+ char *neworg = malloc(l+2-e);
+ sprintf(neworg,"%0*d",l+1-e,0); /* fill with right amount of '0'*/
+ hyppat_insert(dict->merged,newword,combine(neworg,subpat_pat));
+ } else {
+ combine(newpat_pat,subpat_pat);
+ }
+ }
+ }
+ }
+ }
+ delete_HashIter(v);
+
+ init_hash(&dict->state_num);
+ state_insert(dict->state_num, hnj_strdup((unsigned char*)""), 0);
+ v = new_HashIter(dict->merged);
+ while (nextHashStealPattern(v,&word,&pattern)) {
+ static unsigned char mask[] = {0x3F,0x1F,0xF,0x7};
+ int j = strlen((char*)word);
+#ifdef VERBOSE
+ printf ("word %s pattern %s, j = %d\n", word, pattern, j);
+#endif
+ state_num = hnj_get_state( dict, word, &found );
+ dict->states[state_num].match = pattern;
+
+ /* now, put in the prefix transitions */
+ while (found < 0) {
+ j--;
+ last_state = state_num;
+ ch = word[j];
+ if (ch>=0x80) {
+ int i=1;
+ while (is_utf8_follow(word[j-i])) i++;
+ ch = word[j-i] & mask[i];
+ int m = j-i;
+ while (i--) {
+ ch = (ch<<6)+(0x3F & word[j-i]);
+ }
+ j = m;
+ }
+ word[j] = '\0';
+ state_num = hnj_get_state (dict, word, &found);
+ hnj_add_trans (dict, state_num, last_state, ch);
+ }
+ }
+ delete_HashIter(v);
+ clear_hyppat_hash(&dict->merged);
+
+ /***************************************/
+
+ /* put in the fallback states */
+ for (i = 0; i < HASH_SIZE; i++) {
+ for (e = dict->state_num->entries[i]; e; e = e->next) {
+ /* do not do state==0 otherwise things get confused*/
+ if (e->u.state) {
+ for (j = 1; 1; j++) {
+ state_num = state_lookup(dict->state_num, e->key + j);
+ if (state_num >= 0) break;
+ }
+ dict->states[e->u.state].fallback_state = state_num;
+ }
+ }
+ }
+#ifdef VERBOSE
+ for (i = 0; i < HASH_SIZE; i++) {
+ for (e = dict->state_num->entries[i]; e; e = e->next) {
+ printf ("%d string %s state %d, fallback=%d\n", i, e->key, e->u.state,
+ dict->states[e->u.state].fallback_state);
+ for (j = 0; j < dict->states[e->u.state].num_trans; j++) {
+ printf (" u%4x->%d\n", (int)dict->states[e->u.state].trans[j].uni_ch,
+ dict->states[e->u.state].trans[j].new_state);
+ }
+ }
+ }
+#endif
+ clear_state_hash(&dict->state_num);
+}
+
+
+void hnj_hyphen_hyphenate(
+ HyphenDict *dict,
+ halfword first,
+ halfword last,
+ int length,
+ halfword left,
+ halfword right,
+ lang_variables *lan
+) {
+ /* +2 for dots at each end, +1 for points /outside/ characters*/
+ int ext_word_len = length+2;
+ int hyphen_len = ext_word_len+1;
+ /*char *hyphens = hnj_malloc((hyphen_len*2)+1); */ /* LATER */
+ char *hyphens = hnj_malloc(hyphen_len+1);
+
+ /* Add a '.' to beginning and end to facilitate matching*/
+ set_vlink(begin_point,first);
+ set_vlink(end_point,get_vlink(last));
+ set_vlink(last,end_point);
+
+ int char_num;
+ for (char_num = 0; char_num < hyphen_len; char_num++) {
+ /* hyphens[char_num*2] = '0'; */ /* LATER */
+ /* hyphens[char_num*2+1] = '0'; */ /* LATER */
+ hyphens[char_num] = '0';
+ }
+ /*hyphens[hyphen_len*2] = 0; */ /* LATER */
+ hyphens[hyphen_len] = 0;
+
+ /* now, run the finite state machine */
+ int state = 0;
+ halfword here;
+ for (char_num=0, here=begin_point; here!=end_point; here=get_vlink(here)) {
+
+ int ch = get_character(here);
+
+ while (state!=-1) {
+ /* printf("%*s%s%c",char_num-strlen(get_state_str(state)),"",get_state_str(state),(char)ch);*/
+ HyphenState *hstate = &dict->states[state];
+ int k;
+ for (k = 0; k < hstate->num_trans; k++) {
+ if (hstate->trans[k].uni_ch == ch) {
+ state = hstate->trans[k].new_state;
+ /* printf(" state %d\n",state);*/
+ char *match = dict->states[state].match;
+ if (match) {
+ /* +2 because:
+ * 1 string length is one bigger than offset
+ * 1 hyphenation starts before first character
+ */
+ int offset = char_num + 2 - strlen (match);
+ /* printf ("%*s%s\n", offset,"", match);*/
+ int m;
+ for (m = 0; match[m]; m++) {
+ if (hyphens[offset+m] < match[m]) hyphens[offset+m] = match[m];
+ }
+ }
+ goto try_next_letter;
+ }
+ }
+ state = hstate->fallback_state;
+ /* printf (" back to %d\n", state);*/
+ }
+ /* nothing worked, let's go to the next character*/
+ state = 0;
+try_next_letter: ;
+ char_num++;
+ }
+
+ /* restore the correct pointers*/
+ set_vlink(last,get_vlink(end_point));
+
+ /* pattern is ^.^w^o^r^d^.^ word_len=4, ext_word_len=6, hyphens=7
+ * check ^ ^ ^ so drop first two and stop after word_len-1
+ */
+ for (here=first,char_num=2; here!=left; here=get_vlink(here)) char_num++;
+ for (; here!=right; here=get_vlink(here)) {
+ if (hyphens[char_num] & 1)
+ here = insert_syllable_discretionary(here, lan);
+ char_num++;
+ }
+ hnj_free(hyphens);
+}
diff --git a/Build/source/texk/web2c/luatexdir/lang/texlang.c b/Build/source/texk/web2c/luatexdir/lang/texlang.c
new file mode 100644
index 00000000000..12390ae2fcf
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lang/texlang.c
@@ -0,0 +1,825 @@
+/*
+Copyright (c) 2007 Taco Hoekwater <taco@latex.org>
+
+This file is part of luatex.
+
+luatex is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+luatex is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with luatex; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+This is texlang.c
+*/
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include <string.h>
+
+#include "nodes.h"
+#include "hyphen.h"
+
+/* functions from the fontforge unicode library */
+
+extern unsigned int *utf82u_strcpy(unsigned int *ubuf,const char *utf8buf);
+extern unsigned int u_strlen(unsigned int *ubuf);
+extern char *utf8_idpb(char *w,unsigned int i);
+
+#define noVERBOSE
+
+#define MAX_TEX_LANGUAGES 32767
+
+static struct tex_language *tex_languages[MAX_TEX_LANGUAGES] = {NULL};
+static int next_lang_id = 0;
+
+struct tex_language *
+new_language (void) {
+ struct tex_language* lang;
+ if (next_lang_id<MAX_TEX_LANGUAGES) {
+ lang = xmalloc(sizeof(struct tex_language));
+ tex_languages[next_lang_id] = lang;
+ lang->id = next_lang_id++;
+ lang->exceptions = 0;
+ lang->patterns = NULL;
+ lang->pre_hyphen_char = '-';
+ lang->post_hyphen_char = 0;
+ return lang;
+ } else {
+ return NULL;
+ }
+}
+
+struct tex_language *
+get_language (int n) {
+ if (n>=0 && n<=MAX_TEX_LANGUAGES ) {
+ if (tex_languages[n]!=NULL) {
+ return tex_languages[n];
+ } else {
+ return new_language();
+ }
+ } else {
+ return NULL;
+ }
+}
+
+void
+set_pre_hyphen_char (integer n, integer v) {
+ struct tex_language *l = get_language((int)n);
+ l->pre_hyphen_char = (int)v;
+}
+
+void
+set_post_hyphen_char (integer n, integer v) {
+ struct tex_language *l = get_language((int)n);
+ l->post_hyphen_char = (int)v;
+}
+
+integer
+get_pre_hyphen_char (integer n) {
+ struct tex_language *l = get_language((int)n);
+ return (integer)l->pre_hyphen_char;
+}
+
+integer
+get_post_hyphen_char (integer n) {
+ struct tex_language *l = get_language((int)n);
+ return (integer)l->post_hyphen_char;
+}
+
+void
+load_patterns (struct tex_language *lang, unsigned char *buffer) {
+ if (lang==NULL)
+ return;
+ if (lang->patterns==NULL) {
+ lang->patterns = hnj_hyphen_new();
+ }
+ hnj_hyphen_load (lang->patterns,buffer);
+}
+
+void
+clear_patterns (struct tex_language *lang) {
+ if (lang==NULL)
+ return;
+ if (lang->patterns!=NULL) {
+ hnj_hyphen_clear(lang->patterns);
+ }
+}
+
+void
+load_tex_patterns(int curlang, halfword head) {
+ char *s = tokenlist_to_cstring (head,1, NULL);
+ load_patterns(get_language(curlang),(unsigned char *)s);
+}
+
+
+#define STORE_CHAR(x) { word[w] = x ; if (w<MAX_WORD_LEN) w++; }
+
+/* todo change this! */
+
+char *
+clean_hyphenation (char *buffer, char **cleaned) {
+ int items;
+ unsigned char word [MAX_WORD_LEN+1];
+ int w = 0;
+ char *s = buffer;
+ while (*s && !isspace(*s)) {
+ if (*s == '-') { /* skip */
+ } else if (*s == '=') {
+ STORE_CHAR('-');
+ } else if (*s == '{') {
+ s++;
+ items=0;
+ while (*s && *s!='}') { s++; }
+ if (*s=='}') { items++; s++; }
+ while (*s && *s!='}') { s++; }
+ if (*s=='}') { items++; s++; }
+ if (*s=='{') { s++; }
+ while (*s && *s!='}') {STORE_CHAR(*s); s++; }
+ if (*s=='}') { items++; } else { s--; }
+ if (items!=3) { /* syntax error */
+ *cleaned = NULL;
+ while (*s && !isspace(*s)) { s++; }
+ return s;
+ }
+ } else {
+ STORE_CHAR(*s);
+ }
+ s++;
+ }
+ word[w] = 0;
+ *cleaned = xstrdup((char *)word);
+ return s;
+}
+
+void
+load_hyphenation (struct tex_language *lang, unsigned char *buffer) {
+ char *s, *value, *cleaned;
+ lua_State *L = Luas[0];
+ if (lang==NULL)
+ return;
+ if (lang->exceptions==0) {
+ lua_newtable(L);
+ lang->exceptions = luaL_ref(L,LUA_REGISTRYINDEX);
+ }
+ lua_rawgeti(L, LUA_REGISTRYINDEX, lang->exceptions);
+ s = (char *)buffer;
+ while (*s) {
+ while (isspace(*s)) s++;
+ if (*s) {
+ value = s;
+ s = clean_hyphenation(s, &cleaned);
+ if (cleaned!=NULL) {
+ if ((s-value)>0) {
+ lua_pushstring(L,cleaned);
+ lua_pushlstring(L,value,(s-value));
+ lua_rawset(L,-3);
+ }
+ free(cleaned);
+ } else {
+#ifdef VERBOSE
+ fprintf(stderr,"skipping invalid hyphenation exception: %s\n",value);
+#endif
+ }
+ }
+ }
+}
+
+void
+clear_hyphenation (struct tex_language *lang) {
+ if (lang==NULL)
+ return;
+ if (lang->exceptions!=0) {
+ luaL_unref(Luas[0],LUA_REGISTRYINDEX,lang->exceptions);
+ lang->exceptions = 0;
+ }
+}
+
+
+void
+load_tex_hyphenation(int curlang, halfword head) {
+ char *s = tokenlist_to_cstring (head,1, NULL);
+ load_hyphenation(get_language(curlang),(unsigned char *)s);
+}
+
+/* TODO: clean this up. The delete_attribute_ref() statements are not very
+ nice, but needed. Also, in the post-break, it would be nicer to get the
+ attribute list from vlink(n). No rush, as it is currently not used much. */
+
+halfword insert_discretionary ( halfword t, halfword pre, halfword post, halfword replace) {
+ halfword g, n;
+ n = new_node(disc_node,syllable_disc);
+ try_couple_nodes(n,vlink(t));
+ couple_nodes(t,n);
+ for (g=pre;g!=null;g=vlink(g)) {
+ font(g)=font(replace);
+ if (node_attr(t)!=null) {
+ delete_attribute_ref(node_attr(g));
+ node_attr(g) = node_attr(t);
+ attr_list_ref(node_attr(t)) += 1;
+ }
+ }
+ for (g=post;g!=null;g =vlink(g)) {
+ font(g)=font(replace);
+ if (node_attr(t)!=null) {
+ delete_attribute_ref(node_attr(g));
+ node_attr(g) = node_attr(t);
+ attr_list_ref(node_attr(t)) += 1;
+ }
+ }
+ for (g=replace;g!=null;g =vlink(g)) {
+ if (node_attr(t)!=null) {
+ delete_attribute_ref(node_attr(g));
+ node_attr(g) = node_attr(t);
+ attr_list_ref(node_attr(t)) += 1;
+ }
+ }
+ if (node_attr(t)!=null) {
+ delete_attribute_ref(node_attr(vlink(t)));
+ node_attr(vlink(t)) = node_attr(t);
+ attr_list_ref(node_attr(t)) += 1;
+ }
+ t = vlink(t);
+ set_disc_field(pre_break(t),pre);
+ set_disc_field(post_break(t),post);
+ set_disc_field(no_break(t),replace);
+ return t;
+}
+
+halfword
+insert_syllable_discretionary ( halfword t, lang_variables *lan) {
+ halfword g, n;
+ n = new_node(disc_node,syllable_disc);
+ couple_nodes(n,vlink(t));
+ couple_nodes(t,n);
+ delete_attribute_ref(node_attr(n));
+ if (node_attr(t)!=null) {
+ node_attr(n) = node_attr(t);
+ attr_list_ref(node_attr(t))++ ;
+ } else {
+ node_attr(n) = null;
+ }
+ if (lan->pre_hyphen_char >0) {
+ g = raw_glyph_node();
+ set_to_character(g);
+ character(g)=lan->pre_hyphen_char;
+ font(g)=font(t);
+ lang_data(g)=lang_data(t);
+ if (node_attr(t)!=null) {
+ node_attr(g) = node_attr(t);
+ attr_list_ref(node_attr(t)) ++;
+ }
+ set_disc_field(pre_break(n),g);
+ }
+
+ if (lan->post_hyphen_char >0) {
+ t = vlink(n);
+ g = raw_glyph_node();
+ set_to_character(g);
+ character(g)=lan->post_hyphen_char;
+ font(g)=font(t);
+ lang_data(g)=lang_data(t);
+ if (node_attr(t)!=null) {
+ node_attr(g) = node_attr(t);
+ attr_list_ref(node_attr(t)) += 1;
+ }
+ set_disc_field(post_break(n),g);
+ }
+ return n;
+}
+
+halfword insert_word_discretionary ( halfword t, lang_variables *lan) {
+ halfword pre = null, pos = null;
+ if (lan->pre_hyphen_char >0) pre = insert_character ( null, lan->pre_hyphen_char);
+ if (lan->post_hyphen_char>0) pos = insert_character ( null, lan->post_hyphen_char);
+ return insert_discretionary ( t, pre, pos, null);
+}
+
+halfword insert_complex_discretionary ( halfword t, lang_variables *lan,
+ halfword pre, halfword pos, halfword replace) {
+ return insert_discretionary ( t, pre, pos, replace);
+}
+
+
+halfword insert_character ( halfword t, int c) {
+ halfword p;
+ p=new_node(glyph_node,0);
+ set_to_character(p);
+ character(p)=c;
+ if (t!=null) {
+ couple_nodes(t,p);
+ }
+ return p;
+}
+
+
+void
+set_disc_field (halfword f, halfword t) {
+ if (t!=null) {
+ couple_nodes(f,t);
+ tlink(f) = tail_of_list(t);
+ }
+}
+
+
+
+char *hyphenation_exception(int exceptions, char *w) {
+ char *ret = NULL;
+ lua_State *L = Luas[0];
+ lua_checkstack(L,2);
+ lua_rawgeti(L,LUA_REGISTRYINDEX,exceptions);
+ if (lua_istable(L,-1)) { /* ?? */
+ lua_pushstring(L,w); /* word table */
+ lua_rawget(L,-2);
+ if (lua_isstring(L,-1)) {
+ ret = xstrdup((char *)lua_tostring(L,-1));
+ }
+ lua_pop(L,2);
+ } else {
+ lua_pop(L,1);
+ }
+ return ret;
+}
+
+
+char *exception_strings(struct tex_language *lang) {
+ char *value;
+ int size = 0, current =0;
+ size_t l =0;
+ char *ret = NULL;
+ lua_State *L = Luas[0];
+ if (lang->exceptions==0)
+ return NULL;
+ lua_checkstack(L,2);
+ lua_rawgeti(L,LUA_REGISTRYINDEX,lang->exceptions);
+ if (lua_istable(L,-1)) {
+ /* iterate and join */
+ lua_pushnil(L); /* first key */
+ while (lua_next(L,-2) != 0) {
+ value = (char *)lua_tolstring(L, -1, &l);
+ if (current + 2 + l > size ) {
+ ret = xrealloc(ret, (1.2*size)+current+l+1024);
+ size = (1.2*size)+current+l+1024;
+ }
+ *(ret+current) = ' ';
+ strcpy(ret+current+1,value);
+ current += l+1;
+ lua_pop(L, 1);
+ }
+ }
+ return ret;
+}
+
+
+/* the sequence from |wordstart| to |r| can contain only normal characters */
+/* it could be faster to modify a halfword pointer and return an integer */
+
+halfword find_exception_part(int *j, int *uword, int len) {
+ halfword g = null, gg = null;
+ register int i = *j;
+ i++; /* this puts uword[i] on the '{' */
+ while (i<len && uword[i+1] != '}') {
+ if (g==null) {
+ gg = new_char(0,uword[i+1]);
+ g = gg;
+ } else {
+ halfword s = new_char(0,uword[i+1]);
+ couple_nodes(g,s);
+ g = vlink(g);
+ }
+ i++;
+ }
+ *j = ++i;
+ return gg;
+}
+
+int count_exception_part(int *j, int *uword, int len) {
+ int ret=0;
+ register int i = *j;
+ i++; /* this puts uword[i] on the '{' */
+ while (i<len && uword[i+1] != '}') {
+ ret++;
+ i++;
+ }
+ *j = ++i;
+ return ret;
+}
+
+
+static char *PAT_ERROR[] = {
+ "Exception discretionaries should contain three pairs of braced items.",
+ "No intervening spaces are allowed.",
+ NULL };
+
+void do_exception (halfword wordstart, halfword r, char *replacement) {
+ int i;
+ halfword t;
+ unsigned len;
+ int clang;
+ lang_variables langdata;
+ int uword[MAX_WORD_LEN+1] = {0};
+ (void)utf82u_strcpy((unsigned int *)uword,replacement);
+ len = u_strlen((unsigned int *)uword);
+ i = 0;
+ t=wordstart;
+ clang = char_lang(wordstart);
+ langdata.pre_hyphen_char = get_pre_hyphen_char(clang);
+ langdata.post_hyphen_char = get_post_hyphen_char(clang);
+
+ for (i=0;i<len;i++) {
+ if (uword[i+1] == '-') { /* a hyphen follows */
+ while (vlink(t)!=r && (type(t)!=glyph_node || !is_simple_character(t)))
+ t = vlink(t);
+ if (vlink(t)==r)
+ break;
+ insert_syllable_discretionary(t, &langdata);
+ t = vlink(t); /* skip the new disc */
+ } else if (uword[i+1] == '=') {
+ /* do nothing ? */
+ t = vlink(t);
+ } else if (uword[i+1] == '{') {
+ halfword gg, hh, replace = null;
+ int repl;
+ gg = find_exception_part(&i,uword,len);
+ if (i==len || uword[i+1] != '{') {
+ tex_error ("broken pattern 1", PAT_ERROR);
+ }
+ hh = find_exception_part(&i,uword,len);
+ if (i==len || uword[i+1] != '{') {
+ tex_error ("broken pattern 2", PAT_ERROR);
+ }
+ repl = count_exception_part(&i,uword,len);
+ if (i==len) {
+ tex_error ("broken pattern 3", PAT_ERROR);
+ }
+ /*i++; */ /* jump over the last right brace */
+ if (vlink(t)==r)
+ break;
+ if (repl>0) {
+ halfword q = t;
+ replace = vlink(q);
+ while(repl>0 && q!=null) {
+ q=vlink(q);
+ if (type(q)==glyph_node) {
+ repl--;
+ }
+ }
+ try_couple_nodes(t,vlink(q));
+ vlink(q)=null;
+ }
+ t = insert_discretionary(t,gg,hh,replace);
+ } else {
+ t = vlink(t);
+ }
+ }
+}
+
+/* This is a documentation section from the pascal web file. It is not
+true any more, but I do not have time right now to rewrite it -- Taco
+
+When the line-breaking routine is unable to find a feasible sequence of
+breakpoints, it makes a second pass over the paragraph, attempting to
+hyphenate the hyphenatable words. The goal of hyphenation is to insert
+discretionary material into the paragraph so that there are more
+potential places to break.
+
+The general rules for hyphenation are somewhat complex and technical,
+because we want to be able to hyphenate words that are preceded or
+followed by punctuation marks, and because we want the rules to work
+for languages other than English. We also must contend with the fact
+that hyphens might radically alter the ligature and kerning structure
+of a word.
+
+A sequence of characters will be considered for hyphenation only if it
+belongs to a ``potentially hyphenatable part'' of the current paragraph.
+This is a sequence of nodes $p_0p_1\ldots p_m$ where $p_0$ is a glue node,
+$p_1\ldots p_{m-1}$ are either character or ligature or whatsit or
+implicit kern nodes, and $p_m$ is a glue or penalty or insertion or adjust
+or mark or whatsit or explicit kern node. (Therefore hyphenation is
+disabled by boxes, math formulas, and discretionary nodes already inserted
+by the user.) The ligature nodes among $p_1\ldots p_{m-1}$ are effectively
+expanded into the original non-ligature characters; the kern nodes and
+whatsits are ignored. Each character |c| is now classified as either a
+nonletter (if |lc_code(c)=0|), a lowercase letter (if
+|lc_code(c)=c|), or an uppercase letter (otherwise); an uppercase letter
+is treated as if it were |lc_code(c)| for purposes of hyphenation. The
+characters generated by $p_1\ldots p_{m-1}$ may begin with nonletters; let
+$c_1$ be the first letter that is not in the middle of a ligature. Whatsit
+nodes preceding $c_1$ are ignored; a whatsit found after $c_1$ will be the
+terminating node $p_m$. All characters that do not have the same font as
+$c_1$ will be treated as nonletters. The |hyphen_char| for that font
+must be between 0 and 255, otherwise hyphenation will not be attempted.
+\TeX\ looks ahead for as many consecutive letters $c_1\ldots c_n$ as
+possible; however, |n| must be less than 64, so a character that would
+otherwise be $c_{64}$ is effectively not a letter. Furthermore $c_n$ must
+not be in the middle of a ligature. In this way we obtain a string of
+letters $c_1\ldots c_n$ that are generated by nodes $p_a\ldots p_b$, where
+|1<=a<=b+1<=m|. If |n>=l_hyf+r_hyf|, this string qualifies for hyphenation;
+however, |uc_hyph| must be positive, if $c_1$ is uppercase.
+
+The hyphenation process takes place in three stages. First, the candidate
+sequence $c_1\ldots c_n$ is found; then potential positions for hyphens
+are determined by referring to hyphenation tables; and finally, the nodes
+$p_a\ldots p_b$ are replaced by a new sequence of nodes that includes the
+discretionary breaks found.
+
+Fortunately, we do not have to do all this calculation very often, because
+of the way it has been taken out of \TeX's inner loop. For example, when
+the second edition of the author's 700-page book {\sl Seminumerical
+Algorithms} was typeset by \TeX, only about 1.2 hyphenations needed to be
+@^Knuth, Donald Ervin@>
+tried per paragraph, since the line breaking algorithm needed to use two
+passes on only about 5 per cent of the paragraphs.
+
+
+When a word been set up to contain a candidate for hyphenation,
+\TeX\ first looks to see if it is in the user's exception dictionary. If not,
+hyphens are inserted based on patterns that appear within the given word,
+using an algorithm due to Frank~M. Liang.
+@^Liang, Franklin Mark@>
+*/
+
+/*
+ * This is incompatible with TEX because the first word of a paragraph
+ * can be hyphenated, but most european users seem to agree that
+ * prohibiting hyphenation there was not a the best idea ever.
+ */
+
+halfword find_next_wordstart(halfword r) {
+ register int l;
+ register int start_ok = 1;
+ int mathlevel = 1;
+ while (r!=null) {
+ switch (type(r)) {
+ case glue_node:
+ start_ok = 1;
+ break;
+ case math_node:
+ while (mathlevel>0 ){
+ r = vlink(r);
+ if (r==null)
+ return r;
+ if (type(r)==math_node) {
+ if (subtype(r)==before) {
+ mathlevel++;
+ } else {
+ mathlevel--;
+ }
+ }
+ }
+ break;
+ case glyph_node:
+ if (start_ok &&
+ is_simple_character(r) &&
+ (l = get_lc_code(character(r)))>0 &&
+ (char_uchyph(r) || l == character(r)))
+ return r;
+ /* fall through */
+ default:
+ start_ok = 0;
+ break;
+ }
+ r = vlink(r);
+ }
+ return r;
+}
+
+int valid_wordend( halfword s) {
+ register halfword r = s;
+ register int clang = char_lang(s);
+ if (r==null)
+ return 1;
+ while ((r!=null) &&
+ ((type(r)==glyph_node && is_simple_character(r) && clang == char_lang(r)) ||
+ (type(r)==kern_node && subtype(r)==normal))) {
+ r = vlink(r);
+ }
+ if (r==null ||
+ (type(r)==glyph_node && is_simple_character(r) && clang != char_lang(r)) ||
+ type(r)==glue_node ||
+ type(r)==whatsit_node ||
+ type(r)==ins_node ||
+ type(r)==adjust_node ||
+ type(r)==penalty_node ||
+ (type(r)==kern_node && subtype(r)==explicit))
+ return 1;
+ return 0;
+}
+
+void
+hnj_hyphenation (halfword head, halfword tail) {
+ int lchar, i;
+ struct tex_language* lang;
+ lang_variables langdata;
+ char utf8word[(4*MAX_WORD_LEN)+1] = {0};
+ int wordlen = 0;
+ char *hy = utf8word;
+ char *replacement = NULL;
+ halfword s, r = head, wordstart = null, save_tail = null, left = null, right = null;
+
+ /* this first movement assures two things:
+ * a) that we won't waste lots of time on something that has been
+ * handled already (in that case, none of the glyphs match |simple_character|).
+ * b) that the first word can be hyphenated. if the movement was
+ * not explicit, then the indentation at the start of a paragraph
+ * list would make find_next_wordstart() look too far ahead.
+ */
+
+ while (r!=null && (type(r)!=glyph_node || !is_simple_character(r)))
+ r =vlink(r);
+ /* this will make |r| a glyph node with subtype_character */
+ r = find_next_wordstart(r);
+ if (r==null)
+ return;
+
+ assert (tail!=null);
+ save_tail = vlink(tail);
+ s = new_penalty(0);
+ couple_nodes(tail, s);
+
+ while (r!=null) { /* could be while(1), but let's be paranoid */
+ wordstart = r;
+ assert (is_simple_character(wordstart));
+ int clang = char_lang(wordstart);
+ int lhmin = char_lhmin(wordstart);
+ int rhmin = char_rhmin(wordstart);
+ langdata.pre_hyphen_char = get_pre_hyphen_char(clang);
+ langdata.post_hyphen_char = get_post_hyphen_char(clang);
+ while (r!=null &&
+ type(r)==glyph_node &&
+ is_simple_character(r) &&
+ clang == char_lang(r) &&
+ (lchar = get_lc_code(character(r)))>0) {
+ wordlen++;
+ hy = utf8_idpb(hy,character(r));
+ /* this should not be needed any more */
+ /*if (vlink(r)!=null) alink(vlink(r))=r;*/
+ r = vlink(r);
+ }
+ if (valid_wordend(r) && wordlen>=lhmin+rhmin && (lang=tex_languages[clang])!=NULL) {
+ *hy=0;
+ if (lang->exceptions!=0 &&
+ (replacement = hyphenation_exception(lang->exceptions,utf8word))!=NULL) {
+#ifdef VERBOSE
+ fprintf(stderr,"replacing %s (c=%d) by %s\n",utf8word,clang,replacement);
+#endif
+ do_exception(wordstart,r,replacement);
+ free(replacement);
+ } else if (lang->patterns!=NULL) {
+
+ left = wordstart;
+ for (i=lhmin;i>1;i--) {
+ left = vlink(left);
+ while (!is_simple_character(left))
+ left = vlink(left);
+ }
+ right = r;
+ for (i=rhmin;i>0;i--) {
+ right = alink(right);
+ while (!is_simple_character(right))
+ right = alink(right);
+ }
+
+#ifdef VERBOSE
+ fprintf(stderr,"hyphenate %s (c=%d,l=%d,r=%d) from %c to %c\n",utf8word,
+ clang,lhmin,rhmin,
+ character(left), character(right));
+#endif
+ (void)hnj_hyphen_hyphenate(lang->patterns,wordstart,r,wordlen,left,right, &langdata);
+ }
+ }
+ wordlen = 0;
+ hy = utf8word;
+ if (r==null)
+ break;
+ r = find_next_wordstart(r);
+ }
+ flush_node(vlink(tail));
+ vlink(tail) = save_tail;
+}
+
+
+void
+new_hyphenation (halfword head, halfword tail) {
+ register int callback_id = 0;
+ if (head==null || vlink(head)==null)
+ return;
+ fix_node_list (head); /* TODO: use couple_nodes() in append_tail()!*/
+ callback_id = callback_defined(hyphenate_callback);
+ if (callback_id>0) {
+ lua_State *L = Luas[0];
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2);
+ return;
+ }
+ nodelist_to_lua(L,head);
+ nodelist_to_lua(L,tail);
+ if (lua_pcall(L,2,0,0) != 0) {
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ lua_error(L);
+ return;
+ }
+ lua_pop(L,1);
+ } else {
+ hnj_hyphenation(head,tail);
+ }
+}
+
+/* dumping and undumping fonts */
+
+#define dump_string(a) \
+ if (a!=NULL) { \
+ x = strlen(a)+1; \
+ dump_int(x); dump_things(*a, x); \
+ } else { \
+ x = 0; dump_int(x); \
+ }
+
+
+void dump_one_language (int i) {
+ char *s = NULL;
+ unsigned x = 0;
+ struct tex_language *lang;
+ lang = tex_languages[i];
+ dump_int(lang->id);
+ dump_int(lang->pre_hyphen_char);
+ dump_int(lang->post_hyphen_char);
+ if (lang->patterns!=NULL) {
+ s = (char *)hnj_serialize(lang->patterns);
+ }
+ dump_string(s);
+ if (s!=NULL) {
+ free(s);
+ s = NULL;
+ }
+ if (lang->exceptions!=0)
+ s = exception_strings(lang);
+ dump_string(s);
+ if (s!=NULL) {
+ free(s);
+ }
+ free (lang);
+}
+
+void dump_language_data (void) {
+ int i;
+ dump_int(next_lang_id);
+ for (i=0;i<next_lang_id;i++) {
+ if (tex_languages[i]) {
+ dump_int(1);
+ dump_one_language(i);
+ } else {
+ dump_int(0);
+ }
+ }
+}
+
+
+void undump_one_language (int i) {
+ char *s = NULL;
+ unsigned x = 0;
+ struct tex_language *lang = get_language(i);
+ undump_int(x); lang->id = x;
+ undump_int(x); lang->pre_hyphen_char = x;
+ undump_int(x); lang->post_hyphen_char = x;
+ /* patterns */
+ undump_int (x);
+ if (x>0) {
+ s = xmalloc(x);
+ undump_things(*s,x);
+ load_patterns(lang,(unsigned char *)s);
+ free(s);
+ }
+ /* exceptions */
+ undump_int (x);
+ if (x>0) {
+ s = xmalloc(x);
+ undump_things(*s,x);
+ load_hyphenation(lang,(unsigned char *)s);
+ free(s);
+ }
+}
+
+void undump_language_data (void) {
+ int i;
+ unsigned x, numlangs;
+ undump_int(numlangs);
+ for (i=0;i<numlangs;i++) {
+ undump_int(x);
+ if (x==1) {
+ undump_one_language(i);
+ }
+ }
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/.indent.pro b/Build/source/texk/web2c/luatexdir/lua/.indent.pro
new file mode 100644
index 00000000000..e9e690f1ba8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/.indent.pro
@@ -0,0 +1,12 @@
+/* $Id$ */
+--k-and-r-style
+--blank-lines-after-procedures
+--line-length 80
+--procnames-start-lines
+--no-space-after-function-call-names
+--dont-break-procedure-type
+--space-after-cast
+/* this does not work in indent 2.2.6 :-( */
+--no-tabs
+/* this is new in indent 2.2.9 */
+--preprocessor-indentation 2
diff --git a/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c b/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c
new file mode 100644
index 00000000000..fa207420dfb
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c
@@ -0,0 +1,463 @@
+/* $Id: lcallbacklib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+extern int do_run_callback (int special, char *values, va_list vl);
+
+int callback_set[total_callbacks] = {0};
+
+static const char *const callbacknames[] = {
+ "", /* empty on purpose */
+ "find_write_file",
+ "find_output_file",
+ "find_image_file",
+ "find_format_file",
+ "find_read_file", "open_read_file",
+ "find_ocp_file", "read_ocp_file",
+ "find_vf_file", "read_vf_file",
+ "find_data_file", "read_data_file",
+ "find_font_file", "read_font_file",
+ "find_map_file", "read_map_file",
+ "find_enc_file", "read_enc_file",
+ "find_type1_file", "read_type1_file",
+ "find_truetype_file", "read_truetype_file",
+ "find_opentype_file", "read_opentype_file",
+ "find_sfd_file", "read_sfd_file",
+ "find_pk_file", "read_pk_file",
+ "show_error_hook",
+ "process_input_buffer",
+ "start_page_number", "stop_page_number",
+ "start_run", "stop_run",
+ "define_font",
+ "token_filter",
+ "pre_output_filter",
+ "buildpage_filter",
+ "hpack_filter", "vpack_filter",
+ "char_exists",
+ "hyphenate",
+ "ligaturing",
+ "kerning",
+ "pre_linebreak_filter",
+ "linebreak_filter",
+ "post_linebreak_filter",
+ NULL };
+
+int callback_callbacks_id = 0;
+
+void
+get_lua_boolean (char *table, char *name, boolean *target) {
+ int stacktop;
+ stacktop = lua_gettop(Luas[0]);
+ luaL_checkstack(Luas[0],2,"out of stack space");
+ lua_getglobal(Luas[0],table);
+ if (lua_istable(Luas[0],-1)) {
+ lua_getfield(Luas[0],-1,name);
+ if (lua_isboolean(Luas[0],-1)) {
+ *target = (lua_toboolean(Luas[0],-1));
+ } else if (lua_isnumber(Luas[0],-1)) {
+ *target = (lua_tonumber(Luas[0],-1)==0 ? 0 : 1);
+ }
+ }
+ lua_settop(Luas[0],stacktop);
+ return;
+}
+
+void
+get_saved_lua_boolean (int r, char *name, boolean *target) {
+ int stacktop;
+ stacktop = lua_gettop(Luas[0]);
+ luaL_checkstack(Luas[0],2,"out of stack space");
+ lua_rawgeti(Luas[0],LUA_REGISTRYINDEX,r);
+ if (lua_istable(Luas[0],-1)) {
+ lua_getfield(Luas[0],-1,name);
+ if (lua_isboolean(Luas[0],-1)) {
+ *target = lua_toboolean(Luas[0],-1);
+ } else if (lua_isnumber(Luas[0],-1)) {
+ *target = (lua_tonumber(Luas[0],-1)==0 ? 0 : 1);
+ }
+ }
+ lua_settop(Luas[0],stacktop);
+ return;
+}
+
+void
+get_lua_number (char *table, char *name, integer *target) {
+ int stacktop;
+ stacktop = lua_gettop(Luas[0]);
+ luaL_checkstack(Luas[0],2,"out of stack space");
+ lua_getglobal(Luas[0],table);
+ if (lua_istable(Luas[0],-1)) {
+ lua_getfield(Luas[0],-1,name);
+ if (lua_isnumber(Luas[0],-1)) {
+ *target = lua_tonumber(Luas[0],-1);
+ }
+ }
+ lua_settop(Luas[0],stacktop);
+ return;
+}
+
+void
+get_saved_lua_number (int r, char *name, integer *target) {
+ int stacktop;
+ stacktop = lua_gettop(Luas[0]);
+ luaL_checkstack(Luas[0],2,"out of stack space");
+ lua_rawgeti(Luas[0],LUA_REGISTRYINDEX,r);
+ if (lua_istable(Luas[0],-1)) {
+ lua_getfield(Luas[0],-1,name);
+ if (lua_isnumber(Luas[0],-1)) {
+ *target = lua_tonumber(Luas[0],-1);
+ }
+ }
+ lua_settop(Luas[0],stacktop);
+ return;
+}
+
+
+void
+get_lua_string (char *table, char *name, char **target) {
+ int stacktop;
+ stacktop = lua_gettop(Luas[0]);
+ luaL_checkstack(Luas[0],2,"out of stack space");
+ lua_getglobal(Luas[0],table);
+ if (lua_istable(Luas[0],-1)) {
+ lua_getfield(Luas[0],-1,name);
+ if (lua_isstring(Luas[0],-1)) {
+ *target = (char *)lua_tostring(Luas[0],-1);
+ }
+ }
+ lua_settop(Luas[0],stacktop);
+ return;
+}
+
+void
+get_saved_lua_string (int r, char *name, char **target) {
+ int stacktop;
+ stacktop = lua_gettop(Luas[0]);
+ luaL_checkstack(Luas[0],2,"out of stack space");
+ lua_rawgeti(Luas[0],LUA_REGISTRYINDEX,r);
+ if (lua_istable(Luas[0],-1)) {
+ lua_getfield(Luas[0],-1,name);
+ if (lua_isstring(Luas[0],-1)) {
+ *target = (char *)lua_tostring(Luas[0],-1);
+ }
+ }
+ lua_settop(Luas[0],stacktop);
+ return;
+}
+
+
+#define CALLBACK_BOOLEAN 'b'
+#define CALLBACK_INTEGER 'd'
+#define CALLBACK_LINE 'l'
+#define CALLBACK_STRNUMBER 's'
+#define CALLBACK_STRING 'S'
+#define CALLBACK_CHARNUM 'c'
+
+int
+run_saved_callback (int r, char *name, char *values, ...) {
+ va_list args;
+ int ret = 0;
+ lua_State *L = Luas[0];
+ int stacktop = lua_gettop(L);
+ va_start(args,values);
+ luaL_checkstack(L,2,"out of stack space");
+ lua_rawgeti(L,LUA_REGISTRYINDEX,r);
+ lua_pushstring(L,name);
+ lua_rawget(L,-2);
+ if (lua_isfunction(L,-1)) {
+ ret = do_run_callback(2,values,args);
+ }
+ va_end(args);
+ lua_settop(L,stacktop);
+ return ret;
+}
+
+
+int
+run_and_save_callback (int i, char *values, ...) {
+ va_list args;
+ int ret = 0;
+ lua_State *L = Luas[0];
+ int stacktop = lua_gettop(L);
+ va_start(args,values);
+ luaL_checkstack(L,2,"out of stack space");
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1,i);
+ if (lua_isfunction(L,-1)) {
+ ret = do_run_callback(1,values,args);
+ }
+ va_end(args);
+ if (ret>0) {
+ ret = luaL_ref(L,LUA_REGISTRYINDEX);
+ }
+ lua_settop(L,stacktop);
+ return ret;
+}
+
+
+int
+run_callback (int i, char *values, ...) {
+ va_list args;
+ int ret = 0;
+ lua_State *L = Luas[0];
+ int stacktop = lua_gettop(L);
+ va_start(args,values);
+ luaL_checkstack(L,2,"out of stack space");
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, i);
+ if (lua_isfunction(L,-1)) {
+ ret = do_run_callback(0,values,args);
+ }
+ va_end(args);
+ lua_settop(L,stacktop);
+ return ret;
+}
+
+int
+do_run_callback (int special, char *values, va_list vl) {
+ int ret, len;
+ int narg,nres;
+ char *s;
+ char cs;
+ int *bufloc;
+ char *ss = NULL;
+ int retval = 0;
+ lua_State *L = Luas[0];
+ if (special==2) { /* copy the enclosing table */
+ luaL_checkstack(L,1,"out of stack space");
+ lua_pushvalue(L,-2);
+ }
+ for (narg = 0; *values; narg++) {
+ luaL_checkstack(L,1,"out of stack space");
+ switch (*values++) {
+ case CALLBACK_CHARNUM: /* an ascii char! */
+ cs = (char)va_arg(vl, int);
+ lua_pushlstring(L,&cs, 1);
+ break;
+ case CALLBACK_STRING: /* C string */
+ s = va_arg(vl, char *);
+ lua_pushstring(L, s);
+ break;
+ case CALLBACK_INTEGER: /* int */
+ lua_pushnumber(L, va_arg(vl, int));
+ break;
+ case CALLBACK_STRNUMBER: /* TeX string */
+ s = makeclstring(va_arg(vl, int),&len);
+ lua_pushlstring(L, s,len);
+ break;
+ case CALLBACK_BOOLEAN: /* boolean */
+ lua_pushboolean(L, va_arg(vl, int));
+ break;
+ case CALLBACK_LINE: /* a buffer section, with implied start */
+ lua_pushlstring(L, (char *)(buffer+first), va_arg(vl, int));
+ break;
+ case '-':
+ narg--;
+ break;
+ case '>':
+ goto ENDARGS;
+ default :
+ ;
+ }
+ }
+ ENDARGS:
+ nres = strlen(values);
+ if (special==1) {
+ nres++;
+ }
+ if (special==2) {
+ narg++;
+ }
+ if(lua_pcall(L,narg,nres,0) != 0) {
+ /* Can't be more precise here, could be called before
+ * TeX initialization is complete
+ */
+ fprintf(stderr,"This went wrong: %s\n",lua_tostring(L,-1));
+ error();
+ return 0;
+ };
+ if (nres==0) {
+ return 1;
+ }
+ nres = -nres;
+ while (*values) {
+ switch (*values++) {
+ case CALLBACK_BOOLEAN:
+ if (!lua_isboolean(L,nres)) {
+ fprintf(stderr,"Expected a boolean, not: %s\n", lua_typename(L,lua_type(L,nres)));
+ goto EXIT;
+ }
+ int b = lua_toboolean(L,nres);
+ *va_arg(vl, boolean *) = (boolean)b;
+ break;
+ case CALLBACK_INTEGER:
+ if (!lua_isnumber(L,nres)) {
+ fprintf(stderr,"Expected a number, not: %s\n", lua_typename(L,lua_type(L,nres)));
+ goto EXIT;
+ }
+ b = lua_tonumber(L,nres);
+ *va_arg(vl, int *) = b;
+ break;
+ case CALLBACK_LINE: /* TeX line */
+ if (!lua_isstring(L,nres)) {
+ if (!lua_isnil(L,nres))
+ fprintf(stderr,"Expected a string for (l), not: %s\n",
+ lua_typename(L,lua_type(L,nres)));
+ goto EXIT;
+ }
+ s = (char *)lua_tolstring(L,nres, (size_t *)&len);
+ if (s!=NULL) { /* |len| can be zero */
+ bufloc = va_arg(vl, int *);
+ ret = *bufloc;
+ check_buffer_overflow (ret+len);
+ while (len--) {
+ buffer[(*bufloc)++] = *s++;
+ }
+ while ((*bufloc)-1>ret && buffer[(*bufloc)-1] == ' ')
+ (*bufloc)--;
+ } else {
+ bufloc = 0;
+ }
+ break;
+ case CALLBACK_STRNUMBER: /* TeX string */
+ if (!lua_isstring(L,nres)) {
+ if (!lua_isnil(L,nres)) {
+ fprintf(stderr,"Expected a string for (s), not: %s\n",
+ lua_typename(L,lua_type(L,nres)));
+ goto EXIT;
+ }
+ }
+ s = (char *)lua_tolstring(L,nres,(size_t *)&len);
+ if (s==NULL) /* |len| can be zero */
+ *va_arg(vl, int *) = 0;
+ else {
+ *va_arg(vl, int *) = maketexlstring(s,len);
+ }
+ break;
+ case CALLBACK_STRING: /* C string aka buffer */
+ if (!lua_isstring(L,nres)) {
+ if (!lua_isnil(L,nres)) {
+ fprintf(stderr,"Expected a string for (S), not: %s\n",
+ lua_typename(L,lua_type(L,nres)));
+ goto EXIT;
+ }
+ }
+ s = (char *)lua_tolstring(L,nres,(size_t *)&len);
+
+ if (s==NULL) /* |len| can be zero */
+ *va_arg(vl, int *) = 0;
+ else {
+ ss = xmalloc(len+1);
+ (void)memcpy(ss,s,(len+1));
+ *va_arg(vl, char **) = ss;
+ }
+ break;
+ default:
+ fprintf(stdout,"invalid return value type");
+ goto EXIT;
+ }
+ nres++;
+ }
+ retval = 1;
+ EXIT:
+ return retval;
+}
+
+void
+destroy_saved_callback (int i) {
+ luaL_unref(Luas[0],LUA_REGISTRYINDEX,i);
+}
+
+static int callback_register (lua_State *L) {
+ int cb;
+ char *s;
+ if (!lua_isstring(L,1) ||
+ ((!lua_isfunction(L,2)) && !lua_isnil(L,2))) {
+ lua_pushnil(L);
+ lua_pushstring(L,"Invalid arguments to callback.register.");
+ return 2;
+ }
+ s = (char *)lua_tostring(L,1);
+ for(cb=0;cb<total_callbacks;cb++) {
+ if (strcmp(callbacknames[cb],s)==0)
+ break;
+ }
+ if (cb==total_callbacks) {
+ lua_pushnil(L);
+ lua_pushstring(L,"No such callback exists.");
+ return 2;
+ }
+ if (lua_isfunction(L,2)) {
+ callback_set[cb]=cb;
+ } else {
+ callback_set[cb]=0;
+ }
+ luaL_checkstack(L,2,"out of stack space");
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id); /* push the table */
+ lua_pushvalue(L,2); /* the function or nil */
+ lua_rawseti(L,-2,cb);
+ lua_rawseti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_pushnumber(L,cb);
+ return 1;
+}
+
+static int callback_find (lua_State *L) {
+ int cb;
+ char * s;
+ if (!lua_isstring(L,1)) {
+ lua_pushnil(L);
+ lua_pushstring(L,"Invalid arguments to callback.find.");
+ return 2;
+ }
+ s = (char *)lua_tostring(L,1);
+ for(cb=0;cb<total_callbacks;cb++) {
+ if (strcmp(callbacknames[cb],s)==0)
+ break;
+ }
+ if (cb==total_callbacks) {
+ lua_pushnil(L);
+ lua_pushstring(L,"No such callback exists.");
+ return 2;
+ }
+ luaL_checkstack(L,2,"out of stack space");
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id); /* push the table */
+ lua_rawgeti(L,-1,cb);
+ return 1;
+}
+
+
+static int callback_listf (lua_State *L) {
+ int i;
+ luaL_checkstack(L,3,"out of stack space");
+ lua_newtable(L);
+ for (i=1; callbacknames[i]; i++) {
+ lua_pushstring(L,callbacknames[i]);
+ if (callback_defined(i)) {
+ lua_pushboolean(L,1);
+ } else {
+ lua_pushboolean(L,0);
+ }
+ lua_rawset(L,-3);
+ }
+ return 1;
+}
+
+static const struct luaL_reg callbacklib [] = {
+ {"find", callback_find},
+ {"register",callback_register},
+ {"list", callback_listf},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_callback (lua_State *L)
+{
+ luaL_register(L, "callback", callbacklib);
+ luaL_checkstack(L,1,"out of stack space");
+ lua_newtable(L);
+ callback_callbacks_id = luaL_ref(L,LUA_REGISTRYINDEX);
+ return 1;
+}
+
+
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/lfontlib.c b/Build/source/texk/web2c/luatexdir/lua/lfontlib.c
new file mode 100644
index 00000000000..13632527082
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lfontlib.c
@@ -0,0 +1,213 @@
+/* $Id: lfontlib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "nodes.h"
+
+/* this function is in vfovf.c for the moment */
+extern int make_vf_table(lua_State *L, char *name, scaled s);
+
+static int
+font_read_tfm (lua_State *L) {
+ internalfontnumber f;
+ scaled s;
+ int k;
+ char *cnom;
+ if(lua_isstring(L, 1)) {
+ cnom = (char *)lua_tostring(L, 1);
+ if(lua_isnumber(L, 2)) {
+ s = (integer)lua_tonumber(L,2);
+ if (strlen(cnom)) {
+ f = new_font();
+ if (read_tfm_info(f, cnom, "", s)) {
+ k = font_to_lua(L,f);
+ delete_font(f);
+ return k;
+ } else {
+ delete_font(f);
+ lua_pushstring(L, "font loading failed");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "expected tfm name as first argument");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "expected an integer size as second argument");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "expected tfm name as first argument");
+ lua_error(L);
+ }
+ return 2; /* not reached */
+}
+
+
+static int
+font_read_vf (lua_State *L) {
+ scaled s;
+ char *cnom;
+ if(lua_isstring(L, 1)) {
+ cnom = (char *)lua_tostring(L, 1);
+ if (strlen(cnom)) {
+ if(lua_isnumber(L, 2)) {
+ s = lua_tonumber(L,2);
+ return make_vf_table(L,cnom,s);
+ } else {
+ lua_pushstring(L, "expected an integer size as second argument");
+ lua_error(L);
+ return 2;
+ }
+ }
+ }
+ lua_pushstring(L, "expected vf name as first argument");
+ lua_error(L);
+ return 2; /* not reached */
+}
+
+static int
+tex_current_font (lua_State *L) {
+ int i;
+ i = (int)luaL_optinteger(L,1,0);
+ if (i>0) {
+ if (is_valid_font(i)) {
+ zset_cur_font(i);
+ return 0;
+ } else {
+ lua_pushstring(L, "expected a valid font id");
+ lua_error(L);
+ return 2; /* not reached */
+ }
+ } else {
+ lua_pushnumber(L,get_cur_font());
+ return 1;
+ }
+}
+
+static int
+tex_max_font (lua_State *L) {
+ lua_pushnumber(L,max_font_id());
+ return 1;
+}
+
+
+static int
+tex_each_font_next (lua_State *L) {
+ int i,m; /* id */
+ m = lua_tonumber(L,1);
+ i = lua_tonumber(L,2);
+ i++;
+ while(i<=m && !is_valid_font(i))
+ i++;
+ if (i>m) {
+ lua_pushnil(L);
+ return 1;
+ } else {
+ lua_pushnumber(L, i);
+ font_to_lua (L, i);
+ return 2;
+ }
+}
+
+static int
+tex_each_font (lua_State *L) {
+ lua_pushcclosure(L, tex_each_font_next, 0);
+ lua_pushnumber(L, max_font_id());
+ lua_pushnumber(L, 0);
+ return 3;
+}
+
+static int
+frozenfont (lua_State *L) {
+ int i;
+ i = (int)luaL_checkinteger(L,1);
+ if (i) {
+ if (is_valid_font(i)) {
+ if (font_touched(i) || font_used(i)) {
+ lua_pushboolean(L,1);
+ } else {
+ lua_pushboolean(L,0);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ } else {
+ lua_pushstring(L, "expected an integer argument");
+ lua_error(L);
+ }
+ return 0; /* not reached */
+}
+
+
+static int
+setfont (lua_State *L) {
+ int i;
+ i = (int)luaL_checkinteger(L,-2);
+ if (i) {
+ luaL_checktype(L,-1,LUA_TTABLE);
+ if (is_valid_font(i)) {
+ if (! (font_touched(i) || font_used(i))) {
+ font_from_lua (L,i) ;
+ } else {
+ lua_pushstring(L, "that font has been accessed already, changing it is forbidden");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "that integer id is not a valid font");
+ lua_error(L);
+ }
+ }
+ return 0;
+}
+
+
+static int
+deffont (lua_State *L) {
+ int i;
+ luaL_checktype(L,-1,LUA_TTABLE);
+
+ i = new_font();
+ if(font_from_lua (L,i)) {
+ lua_pushnumber(L,i);
+ return 1;
+ } else {
+ lua_pop(L,1); /* pop the broken table */
+ delete_font(i);
+ lua_pushstring(L, "font creation failed");
+ lua_error(L);
+ }
+ return 0; /* not reached */
+}
+
+static int
+getfont (lua_State *L) {
+ int i;
+ i = (int)luaL_checkinteger(L,-1);
+ if (i && is_valid_font(i) && font_to_lua (L, i))
+ return 1;
+ lua_pushnil(L);
+ return 1;
+}
+
+
+static const struct luaL_reg fontlib [] = {
+ {"read_tfm", font_read_tfm},
+ {"read_vf", font_read_vf},
+ {"current", tex_current_font},
+ {"max", tex_max_font},
+ {"each", tex_each_font},
+ {"getfont", getfont},
+ {"setfont", setfont},
+ {"define", deffont},
+ {"frozen", frozenfont},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_font (lua_State *L)
+{
+ luaL_register(L, "font", fontlib);
+ make_table(L,"fonts","getfont","setfont");
+ return 1;
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/limglib.c b/Build/source/texk/web2c/luatexdir/lua/limglib.c
new file mode 100644
index 00000000000..fd75e49799a
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/limglib.c
@@ -0,0 +1,714 @@
+/* $Id: limglib.c 1098 2008-03-09 10:28:19Z hhenkel $ */
+
+#include <stdio.h>
+#include <string.h>
+#include <assert.h>
+#include <../lua51/lua.h>
+#include <../lua51/lauxlib.h>
+#include <ptexlib.h>
+#include "../image/image.h"
+#include "../luatex-api.h"
+
+/**********************************************************************/
+
+#ifdef DEBUG
+static void stackDump(lua_State * L, char *s)
+{
+ int i;
+ int top = lua_gettop(L);
+ printf("\n=== stackDump <%s>: ", s);
+ for (i = 1; i <= top; i++) { /* repeat for each level */
+ int t = lua_type(L, i);
+ printf("%d: ", i);
+ switch (t) {
+ case LUA_TSTRING: /* strings */
+ printf("`%s'", lua_tostring(L, i));
+ break;
+ case LUA_TBOOLEAN: /* booleans */
+ printf(lua_toboolean(L, i) ? "true" : "false");
+ break;
+ case LUA_TNUMBER: /* numbers */
+ printf("%g", lua_tonumber(L, i));
+ break;
+ default: /* other values */
+ printf("%s", lua_typename(L, t));
+ break;
+ }
+ printf(" "); /* put a separator */
+ }
+ printf("\n");
+}
+#endif
+
+/**********************************************************************/
+
+typedef enum { P__ZERO, P_ATTR, P_COLORDEPTH, P_COLORSPACE, P_DEPTH, P_FILENAME,
+ P_FILEPATH, P_HEIGHT, P_IMAGETYPE, P_INDEX, P_OBJNUM, P_PAGE, P_PAGEBOX,
+ P_TOTALPAGES, P_TRANSFORM, P_WIDTH, P_XRES, P_XSIZE, P_YRES, P_YSIZE,
+ P__SENTINEL
+} parm_idx;
+
+typedef struct {
+ const char *name; /* parameter name */
+ parm_idx idx; /* index within img_parms array */
+} parm_struct;
+
+parm_struct img_parms[] = {
+ {NULL, P__ZERO}, /* dummy; lua indices run from 1 */
+ {"attr", P_ATTR},
+ {"colordepth", P_COLORDEPTH},
+ {"colorspace", P_COLORSPACE},
+ {"depth", P_DEPTH},
+ {"filename", P_FILENAME},
+ {"filepath", P_FILEPATH},
+ {"height", P_HEIGHT},
+ {"imagetype", P_IMAGETYPE},
+ {"index", P_INDEX},
+ {"objnum", P_OBJNUM},
+ {"page", P_PAGE},
+ {"pagebox", P_PAGEBOX},
+ {"pages", P_TOTALPAGES},
+ {"transform", P_TRANSFORM},
+ {"width", P_WIDTH},
+ {"xres", P_XRES},
+ {"xsize", P_XSIZE},
+ {"yres", P_YRES},
+ {"ysize", P_YSIZE},
+ {NULL, P__SENTINEL}
+};
+
+#define imgtype_max 4
+const char *imgtype_s[] = { "none", "pdf", "png", "jpg", "jbig2", NULL };
+
+#define pagebox_max 5
+const char *pdfboxspec_s[] =
+ { "none", "media", "crop", "bleed", "trim", "art", NULL };
+
+/**********************************************************************/
+
+static void image_to_lua(lua_State * L, image * a)
+{ /* key user ... */
+ int i, j;
+ image_dict *d = img_dict(a);
+ assert(d != NULL);
+ lua_pushvalue(L, -1); /* k k u ... */
+ lua_gettable(L, LUA_ENVIRONINDEX); /* i? k u ... */
+ if (!lua_isnumber(L, -1)) /* !i k u ... */
+ luaL_error(L, "image_to_lua not a valid image key: %s",
+ lua_tostring(L, -2));
+ i = lua_tointeger(L, -1); /* i k u ... */
+ lua_pop(L, 2); /* u ... */
+ switch (i) {
+ case P_WIDTH:
+ if (is_wd_running(a))
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_width(a));
+ break;
+ case P_HEIGHT:
+ if (is_ht_running(a))
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_height(a));
+ break;
+ case P_DEPTH:
+ if (is_dp_running(a))
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_depth(a));
+ break;
+ case P_TRANSFORM:
+ lua_pushinteger(L, img_transform(a));
+ break;
+ /* now follow all image_dict entries */
+ case P_FILENAME:
+ if (img_filename(d) == NULL || strlen(img_filename(d)) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushstring(L, img_filename(d));
+ break;
+ case P_FILEPATH:
+ if (img_filepath(d) == NULL || strlen(img_filepath(d)) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushstring(L, img_filepath(d));
+ break;
+ case P_ATTR:
+ if (img_attr(d) == NULL || strlen(img_attr(d)) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushstring(L, img_attr(d));
+ break;
+ case P_PAGE:
+ if (img_pagename(d) != NULL && strlen(img_pagename(d)) != 0)
+ lua_pushstring(L, img_pagename(d));
+ else
+ lua_pushinteger(L, img_pagenum(d));
+ break;
+ case P_TOTALPAGES:
+ lua_pushinteger(L, img_totalpages(d));
+ break;
+ case P_XSIZE:
+ lua_pushinteger(L, img_xsize(d));
+ break;
+ case P_YSIZE:
+ lua_pushinteger(L, img_ysize(d));
+ break;
+ case P_XRES:
+ lua_pushinteger(L, img_xres(d));
+ break;
+ case P_YRES:
+ lua_pushinteger(L, img_yres(d));
+ break;
+ case P_COLORSPACE:
+ if (img_colorspace(d) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_colorspace(d));
+ break;
+ case P_COLORDEPTH:
+ if (img_colordepth(d) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_colordepth(d));
+ break;
+ case P_IMAGETYPE:
+ j = img_type(d);
+ if (j >= 0 && j <= imgtype_max) {
+ if (j == IMAGE_TYPE_NONE)
+ lua_pushnil(L);
+ else
+ lua_pushstring(L, imgtype_s[j]);
+ } else
+ assert(0);
+ break;
+ case P_PAGEBOX:
+ j = img_pagebox(d);
+ if (j >= 0 && j <= pagebox_max) {
+ if (j == PDF_BOX_SPEC_NONE)
+ lua_pushnil(L);
+ else
+ lua_pushstring(L, pdfboxspec_s[j]);
+ } else
+ assert(0);
+ break;
+ case P_OBJNUM:
+ if (img_objnum(d) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_objnum(d));
+ break;
+ case P_INDEX:
+ if (img_index(d) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushinteger(L, img_index(d));
+ break;
+ default:
+ assert(0);
+ } /* v u ... */
+}
+
+static void lua_to_image(lua_State * L, image * a)
+{ /* value key table ... */
+ int i;
+ image_dict *d = img_dict(a);
+ assert(d != NULL);
+ lua_pushvalue(L, -2); /* k v k t ... */
+ lua_gettable(L, LUA_ENVIRONINDEX); /* i? v k t ... */
+ if (!lua_isnumber(L, -1)) /* !i v k t ... */
+ luaL_error(L, "lua_to_image not a valid image key: %s",
+ lua_tostring(L, -3));
+ i = lua_tointeger(L, -1); /* i v k t ... */
+ lua_pop(L, 1); /* v k t ... */
+ switch (i) {
+ case P_WIDTH:
+ if (img_is_refered(a))
+ luaL_error(L, "image.width is now read-only");
+ if (lua_isnil(L, -1))
+ set_wd_running(a);
+ else if (lua_type(L, -1) == LUA_TNUMBER)
+ img_width(a) = lua_tointeger(L, -1);
+ else if (lua_type(L, -1) == LUA_TSTRING)
+ img_width(a) = dimen_to_number(L, (char *) lua_tostring(L, -1));
+ else
+ luaL_error(L,
+ "image.width needs integer or nil value or dimension string");
+ img_unset_scaled(a);
+ break;
+ case P_HEIGHT:
+ if (img_is_refered(a))
+ luaL_error(L, "image.height is now read-only");
+ if (lua_isnil(L, -1))
+ set_ht_running(a);
+ else if (lua_type(L, -1) == LUA_TNUMBER)
+ img_height(a) = lua_tointeger(L, -1);
+ else if (lua_type(L, -1) == LUA_TSTRING)
+ img_height(a) = dimen_to_number(L, (char *) lua_tostring(L, -1));
+ else
+ luaL_error(L,
+ "image.height needs integer or nil value or dimension string");
+ img_unset_scaled(a);
+ break;
+ case P_DEPTH:
+ if (img_is_refered(a))
+ luaL_error(L, "image.depth is now read-only");
+ if (lua_isnil(L, -1))
+ set_dp_running(a);
+ else if (lua_type(L, -1) == LUA_TNUMBER)
+ img_depth(a) = lua_tointeger(L, -1);
+ else if (lua_type(L, -1) == LUA_TSTRING)
+ img_depth(a) = dimen_to_number(L, (char *) lua_tostring(L, -1));
+ else
+ luaL_error(L,
+ "image.depth needs integer or nil value or dimension string");
+ img_unset_scaled(a);
+ break;
+ case P_TRANSFORM:
+ if (img_is_refered(a))
+ luaL_error(L, "image.transform is now read-only");
+ if (lua_isnumber(L, -1))
+ img_transform(a) = lua_tointeger(L, -1);
+ else
+ luaL_error(L, "image.transform needs integer value");
+ img_unset_scaled(a);
+ break;
+ /* now follow all image_dict entries */
+ case P_FILENAME:
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.filename is now read-only");
+ if (lua_isstring(L, -1)) {
+ if (img_filename(d) != NULL)
+ xfree(img_filename(d));
+ img_filename(d) = xstrdup(lua_tostring(L, -1));
+ } else
+ luaL_error(L, "image.filename needs string value");
+ break;
+ case P_ATTR:
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.attr is now read-only");
+ if (lua_isstring(L, -1) || lua_isnil(L, -1)) {
+ if (img_attr(d) != NULL)
+ xfree(img_attr(d));
+ if (lua_isstring(L, -1))
+ img_attr(d) = xstrdup(lua_tostring(L, -1));
+ } else
+ luaL_error(L, "image.attr needs string or nil value");
+ break;
+ case P_PAGE:
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.page is now read-only");
+ if (lua_type(L, -1) == LUA_TSTRING) {
+ if (img_pagename(d) != NULL)
+ xfree(img_pagename(d));
+ img_pagename(d) = xstrdup(lua_tostring(L, -1));
+ img_pagenum(d) = 0;
+ } else if (lua_type(L, -1) == LUA_TNUMBER) {
+ img_pagenum(d) = lua_tointeger(L, -1);
+ if (img_pagename(d) != NULL)
+ xfree(img_pagename(d));
+ img_pagename(d) = NULL;
+ } else
+ luaL_error(L, "image.page needs integer or string value");
+ break;
+ case P_COLORSPACE:
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.colorspace is now read-only");
+ if (lua_isnil(L, -1))
+ img_colorspace(d) = 0;
+ else if (lua_isnumber(L, -1))
+ img_colorspace(d) = lua_tointeger(L, -1);
+ else
+ luaL_error(L, "image.colorspace needs integer or nil value");
+ break;
+ case P_PAGEBOX:
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.pagebox is now read-only");
+ if (lua_isnil(L, -1))
+ img_pagebox(d) = PDF_BOX_SPEC_NONE;
+ else if (lua_isstring(L, -1))
+ img_pagebox(d) = luaL_checkoption(L, -1, "none", pdfboxspec_s);
+ else
+ luaL_error(L, "image.pagebox needs string or nil value");
+ break;
+ case P_FILEPATH:
+ case P_TOTALPAGES:
+ case P_XSIZE:
+ case P_YSIZE:
+ case P_XRES:
+ case P_YRES:
+ case P_IMAGETYPE:
+ case P_OBJNUM:
+ case P_INDEX:
+ case P_COLORDEPTH:
+ luaL_error(L, "image.%s is a read-only variable", img_parms[i].name);
+ break;
+ default:
+ assert(0);
+ } /* v k t ... */
+}
+
+/**********************************************************************/
+
+void fix_image_size(lua_State * L, image * a)
+{
+ if (!img_is_scaled(a) || is_wd_running(a) || is_ht_running(a)
+ || is_dp_running(a)) {
+ if (img_is_refered(a))
+ luaL_error(L, "image is read-only");
+ scale_img(a);
+ }
+}
+
+void copy_image(lua_State * L, lua_Number scale)
+{
+ image *a, **aa, *b, **bb;
+ if (lua_gettop(L) != 1)
+ luaL_error(L, "img.copy() needs exactly 1 argument");
+ aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* a */
+ lua_pop(L, 1); /* - */
+ a = *aa;
+ bb = (image **) lua_newuserdata(L, sizeof(image *)); /* b */
+ luaL_getmetatable(L, TYPE_IMG); /* m b */
+ lua_setmetatable(L, -2); /* b */
+ b = *bb = new_image();
+ if (!is_wd_running(a))
+ img_width(b) = zround(img_width(a) * scale);
+ if (!is_ht_running(a))
+ img_height(b) = zround(img_height(a) * scale);
+ if (!is_dp_running(a))
+ img_depth(b) = zround(img_depth(a) * scale);
+ img_transform(b) = img_transform(a);
+ img_dict(b) = img_dict(a);
+ if (img_dictref(a) != LUA_NOREF) {
+ lua_rawgeti(L, LUA_GLOBALSINDEX, img_dictref(a)); /* ad b */
+ img_dictref(b) = luaL_ref(L, LUA_GLOBALSINDEX); /* b */
+ } else
+ assert(img_state(img_dict(a)) >= DICT_REFERED);
+}
+
+/**********************************************************************/
+
+static int l_new_image(lua_State * L)
+{
+ image *a, **aa;
+ if (lua_gettop(L) > 1)
+ luaL_error(L, "img.new() needs maximum 1 argument");
+ if (lua_gettop(L) == 1 && !lua_istable(L, 1))
+ luaL_error(L, "img.new() needs table as optional argument"); /* (t) */
+ aa = (image **) lua_newuserdata(L, sizeof(image *)); /* i (t) */
+ luaL_getmetatable(L, TYPE_IMG); /* m i (t) */
+ lua_setmetatable(L, -2); /* i (t) */
+ a = *aa = new_image();
+ image_dict **add = (image_dict **) lua_newuserdata(L, sizeof(image_dict *)); /* ad i (t) */
+ luaL_getmetatable(L, TYPE_IMG_DICT); /* m ad i (t) */
+ lua_setmetatable(L, -2); /* ad i (t) */
+ img_dict(a) = *add = new_image_dict();
+ img_dictref(a) = luaL_ref(L, LUA_GLOBALSINDEX); /* i (t) */
+ if (lua_gettop(L) != 1) { /* i t, else just i */
+ lua_insert(L, -2); /* t i */
+ lua_pushnil(L); /* n t i (1st key for iterator) */
+ while (lua_next(L, -2) != 0) { /* v k t i */
+ lua_to_image(L, a); /* v k t i */
+ lua_pop(L, 1); /* k t i */
+ } /* t i */
+ lua_pop(L, 1); /* i */
+ } /* i */
+ return 1; /* i */
+}
+
+static int l_copy_image(lua_State * L)
+{
+ if (lua_gettop(L) != 1)
+ luaL_error(L, "img.copy() needs exactly 1 argument");
+ if (lua_istable(L, 1))
+ l_new_image(L); /* image --- if everything worked well */
+ else
+ copy_image(L, 1.0); /* image */
+ return 1; /* image */
+}
+
+static int l_scan_image(lua_State * L)
+{
+ image *a, **aa;
+ if (lua_gettop(L) != 1)
+ luaL_error(L, "img.scan() needs exactly 1 argument");
+ if (lua_istable(L, 1))
+ l_new_image(L); /* image --- if everything worked well */
+ aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* image */
+ a = *aa;
+ image_dict *ad = img_dict(a);
+ if (img_state(ad) == DICT_NEW) {
+ read_img(ad, get_pdf_minor_version(), get_pdf_inclusion_errorlevel());
+ img_unset_scaled(a);
+ }
+ fix_image_size(L, a);
+ return 1; /* image */
+}
+
+/* these should go into some header file... */
+#define obj_type_ximage 8
+#define obj_aux(a) obj_tab[a].int4 /* auxiliary pointer */
+#define obj_data_ptr obj_aux /* pointer to |pdf_mem| */
+
+static halfword img_to_node(image * a, integer ref)
+{
+ image_dict *ad = img_dict(a);
+ assert(ad != NULL);
+ assert(img_objnum(ad) != 0);
+ halfword n = new_node(whatsit_node, pdf_refximage_node);
+ pdf_ximage_ref(n) = ref;
+ pdf_width(n) = img_width(a);
+ pdf_height(n) = img_height(a);
+ pdf_depth(n) = img_depth(a);
+ return n;
+}
+
+typedef enum { WR_WRITE, WR_IMMEDIATEWRITE, WR_NODE } wrtype_e;
+const char *wrtype_s[] =
+ { "img.write()", "img.immediatewrite()", "img.node()" };
+
+extern void lua_nodelib_push_fast(lua_State * L, halfword n);
+
+static void write_image_or_node(lua_State * L, wrtype_e writetype)
+{
+ image *a, **aa;
+ halfword n;
+ if (lua_gettop(L) != 1)
+ luaL_error(L, "%s needs exactly 1 argument", wrtype_s[writetype]);
+ if (lua_istable(L, 1))
+ l_new_image(L); /* image --- if everything worked well */
+ aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* image */
+ a = *aa;
+ image_dict *ad = img_dict(a);
+ assert(ad != NULL);
+ if (img_state(ad) == DICT_NEW) {
+ read_img(ad, get_pdf_minor_version(), get_pdf_inclusion_errorlevel());
+ img_unset_scaled(a);
+ }
+ fix_image_size(L, a);
+ check_pdfoutput(maketexstring(wrtype_s[writetype]), true);
+ flush_str(last_tex_string);
+ integer ref = img_to_array(a);
+ if (img_objnum(ad) == 0) { /* not strictly needed here, could be delayed until out_image() */
+ pdf_ximage_count++;
+ pdf_create_obj(obj_type_ximage, pdf_ximage_count);
+ img_objnum(ad) = obj_ptr;
+ img_index(ad) = pdf_ximage_count;
+ obj_data_ptr(obj_ptr) = ref;
+ }
+ switch (writetype) {
+ case WR_WRITE:
+ n = img_to_node(a, ref);
+ new_tail_append(n);
+ break; /* image */
+ case WR_IMMEDIATEWRITE:
+ check_pdfminorversion(); /* does initialization stuff */
+ pdf_begin_dict(img_objnum(ad), 0);
+ write_img(ad);
+ break; /* image */
+ case WR_NODE: /* image */
+ lua_pop(L, 1); /* - */
+ n = img_to_node(a, ref);
+ lua_nodelib_push_fast(L, n);
+ break; /* node */
+ default:
+ assert(0);
+ }
+ if (img_state(ad) < DICT_REFERED)
+ img_state(ad) = DICT_REFERED;
+ img_set_refered(a); /* now image may not be freed by gc */
+}
+
+static int l_write_image(lua_State * L)
+{
+ write_image_or_node(L, WR_WRITE);
+ return 1; /* image */
+}
+
+static int l_immediatewrite_image(lua_State * L)
+{
+ write_image_or_node(L, WR_IMMEDIATEWRITE);
+ return 1; /* image */
+}
+
+static int l_image_node(lua_State * L)
+{
+ write_image_or_node(L, WR_NODE);
+ return 1; /* node */
+}
+
+static int l_image_keys(lua_State * L)
+{
+ parm_struct *p = img_parms + 1;
+ if (lua_gettop(L) != 0)
+ luaL_error(L, "img.keys() goes without argument");
+ lua_newtable(L); /* t */
+ for (; p->name != NULL; p++) {
+ lua_pushinteger(L, (int) p->idx); /* k t */
+ lua_pushstring(L, p->name); /* v k t */
+ lua_settable(L, -3); /* t */
+ }
+ return 1;
+}
+
+static int l_image_types(lua_State * L)
+{
+ int i;
+ char **p;
+ if (lua_gettop(L) != 0)
+ luaL_error(L, "img.types() goes without argument");
+ lua_newtable(L); /* t */
+ for (i = 1, p = (char **) (imgtype_s + 1); *p != NULL; p++, i++) {
+ lua_pushinteger(L, (int) i); /* k t */
+ lua_pushstring(L, *p); /* v k t */
+ lua_settable(L, -3); /* t */
+ }
+ return 1;
+}
+
+static int l_image_boxes(lua_State * L)
+{
+ int i;
+ char **p;
+ if (lua_gettop(L) != 0)
+ luaL_error(L, "img.boxes() goes without argument");
+ lua_newtable(L); /* t */
+ for (i = 1, p = (char **) (pdfboxspec_s + 1); *p != NULL; p++, i++) {
+ lua_pushinteger(L, (int) i); /* k t */
+ lua_pushstring(L, *p); /* v k t */
+ lua_settable(L, -3); /* t */
+ }
+ return 1;
+}
+
+static const struct luaL_Reg imglib[] = {
+ {"new", l_new_image},
+ {"copy", l_copy_image},
+ {"scan", l_scan_image},
+ {"write", l_write_image},
+ {"immediatewrite", l_immediatewrite_image},
+ {"node", l_image_node},
+ {"keys", l_image_keys},
+ {"types", l_image_types},
+ {"boxes", l_image_boxes},
+ {NULL, NULL} /* sentinel */
+};
+
+/**********************************************************************/
+/* Metamethods for image */
+
+static int m_img_get(lua_State * L)
+{
+ image **aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* k u */
+ image_to_lua(L, *aa); /* v u */
+ return 1;
+}
+
+static int m_img_set(lua_State * L)
+{
+ image **aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* value key user */
+ lua_to_image(L, *aa); /* v k u */
+ return 0;
+}
+
+static int m_img_mul(lua_State * L)
+{
+ image **aa;
+ lua_Number scale;
+ if (lua_isnumber(L, 1)) { /* u? n */
+ aa = (image **) luaL_checkudata(L, 2, TYPE_IMG); /* u n */
+ lua_insert(L, -2); /* n a */
+ } else if (lua_isnumber(L, 2)) { /* n u? */
+ aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* n a */
+ } /* n a */
+ scale = lua_tonumber(L, 2); /* n a */
+ lua_pop(L, 1); /* a */
+ copy_image(L, scale); /* b */
+ return 1;
+}
+
+static int m_img_print(lua_State * L)
+{
+ image **aa = (image **) luaL_checkudata(L, 1, TYPE_IMG);
+ image_dict *d = img_dict(*aa);
+ if (img_pagename(d) != NULL && strlen(img_pagename(d)) != 0)
+ lua_pushfstring(L, "<img{filename=\"%s\", page=\"%s\"}>",
+ img_filename(d), img_pagename(d));
+ else
+ lua_pushfstring(L, "<img{filename=\"%s\", page=%d}>", img_filename(d),
+ img_pagenum(d));
+ return 1;
+}
+
+static int m_img_gc(lua_State * L)
+{
+ image *a, **aa;
+ aa = (image **) luaL_checkudata(L, 1, TYPE_IMG);
+ a = *aa;
+#ifdef DEBUG
+ printf("\n===== IMG GC ===== a=%d ad=%d\n", a, img_dict(a));
+#endif
+ luaL_unref(L, LUA_GLOBALSINDEX, img_dictref(a));
+ if (!img_is_refered(a))
+ xfree(a);
+ return 0;
+}
+
+static const struct luaL_Reg img_m[] = {
+ {"__index", m_img_get},
+ {"__newindex", m_img_set},
+ {"__mul", m_img_mul},
+ {"__tostring", m_img_print},
+ {"__gc", m_img_gc}, /* finalizer */
+ {NULL, NULL} /* sentinel */
+};
+
+/**********************************************************************/
+/* Metamethods for image_dict */
+
+static int m_img_dict_gc(lua_State * L)
+{
+ image_dict *ad, **add;
+ add = (image_dict **) luaL_checkudata(L, 1, TYPE_IMG_DICT);
+ ad = *add;
+#ifdef DEBUG
+ printf("\n===== IMG_DICT GC FREE ===== ad=%d\n", ad);
+#endif
+ if (img_state(ad) < DICT_REFERED)
+ free_image_dict(ad);
+ return 0;
+}
+
+static const struct luaL_Reg img_dict_m[] = {
+ {"__gc", m_img_dict_gc}, /* finalizer */
+ {NULL, NULL} /* sentinel */
+};
+
+/**********************************************************************/
+
+void preset_environment(lua_State * L, parm_struct * p)
+{
+ int i;
+ lua_newtable(L); /* t */
+ for (i = 1, ++p; p->name != NULL; i++, p++) {
+ assert(i == (int) p->idx);
+ lua_pushstring(L, p->name); /* k t */
+ lua_pushinteger(L, (int) p->idx); /* v k t */
+ lua_settable(L, -3); /* t */
+ }
+ lua_replace(L, LUA_ENVIRONINDEX); /* - */
+}
+
+int luaopen_img(lua_State * L)
+{
+ preset_environment(L, img_parms);
+ luaL_newmetatable(L, TYPE_IMG);
+ luaL_register(L, NULL, img_m);
+ luaL_newmetatable(L, TYPE_IMG_DICT);
+ luaL_register(L, NULL, img_dict_m);
+ luaL_register(L, "img", imglib);
+ return 1;
+}
+
+/**********************************************************************/
diff --git a/Build/source/texk/web2c/luatexdir/lua/lkpselib.c b/Build/source/texk/web2c/luatexdir/lua/lkpselib.c
new file mode 100644
index 00000000000..5ec4dfed869
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lkpselib.c
@@ -0,0 +1,272 @@
+/* $Id: lkpselib.c 1061 2008-02-20 09:51:04Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include <kpathsea/expand.h>
+#include <kpathsea/variable.h>
+#include <kpathsea/tex-glyph.h>
+#include <kpathsea/readable.h>
+
+static const int filetypes[] = {
+ kpse_gf_format,
+ kpse_pk_format,
+ kpse_any_glyph_format,
+ kpse_tfm_format,
+ kpse_afm_format,
+ kpse_base_format,
+ kpse_bib_format,
+ kpse_bst_format,
+ kpse_cnf_format,
+ kpse_db_format,
+ kpse_fmt_format,
+ kpse_fontmap_format,
+ kpse_mem_format,
+ kpse_mf_format,
+ kpse_mfpool_format,
+ kpse_mft_format,
+ kpse_mp_format,
+ kpse_mppool_format,
+ kpse_mpsupport_format,
+ kpse_ocp_format,
+ kpse_ofm_format,
+ kpse_opl_format,
+ kpse_otp_format,
+ kpse_ovf_format,
+ kpse_ovp_format,
+ kpse_pict_format,
+ kpse_tex_format,
+ kpse_texdoc_format,
+ kpse_texpool_format,
+ kpse_texsource_format,
+ kpse_tex_ps_header_format,
+ kpse_troff_font_format,
+ kpse_type1_format,
+ kpse_vf_format,
+ kpse_dvips_config_format,
+ kpse_ist_format,
+ kpse_truetype_format,
+ kpse_type42_format,
+ kpse_web2c_format,
+ kpse_program_text_format,
+ kpse_program_binary_format,
+ kpse_miscfonts_format,
+ kpse_web_format,
+ kpse_cweb_format,
+ kpse_enc_format,
+ kpse_cmap_format,
+ kpse_sfd_format,
+ kpse_opentype_format,
+ kpse_pdftex_config_format,
+ kpse_lig_format,
+ kpse_texmfscripts_format };
+
+static const char *const filetypenames[] = {
+ "gf",
+ "pk",
+ "bitmap font",
+ "tfm",
+ "afm",
+ "base",
+ "bib",
+ "bst",
+ "cnf",
+ "ls-R",
+ "fmt",
+ "map",
+ "mem",
+ "mf",
+ "mfpool",
+ "mft",
+ "mp",
+ "mppool",
+ "MetaPost support",
+ "ocp",
+ "ofm",
+ "opl",
+ "otp",
+ "ovf",
+ "ovp",
+ "graphic/figure",
+ "tex",
+ "TeX system documentation",
+ "texpool",
+ "TeX system sources",
+ "PostScript header",
+ "Troff fonts",
+ "type1 fonts",
+ "vf",
+ "dvips config",
+ "ist",
+ "truetype fonts",
+ "type42 fonts",
+ "web2c files",
+ "other text files",
+ "other binary files",
+ "misc fonts",
+ "web",
+ "cweb",
+ "enc files",
+ "cmap files",
+ "subfont definition files",
+ "opentype fonts",
+ "pdftex config",
+ "lig files",
+ "texmfscripts",
+ NULL };
+
+/* set to 1 by the |program_name| function */
+
+int program_name_set = 0;
+
+#define TEST_PROGRAM_NAME_SET do { \
+ if (! program_name_set) { \
+ lua_pushstring(L, "Please call kpse.set_program_name() before using the library"); \
+ return lua_error(L); \
+ } \
+ } while (0)
+
+static int find_file (lua_State *L) {
+ int i;
+ char *st;
+ int ftype = kpse_tex_format;
+ int mexist = 0;
+ TEST_PROGRAM_NAME_SET;
+ if (!lua_isstring(L,1)) {
+ lua_pushstring(L, "not a file name");
+ lua_error(L);
+ }
+ st = (char *)lua_tostring(L,1);
+ i = lua_gettop(L);
+ while (i>1) {
+ if (lua_isboolean (L,i)) {
+ mexist = lua_toboolean (L,i);
+ } else if (lua_isnumber (L,i)) {
+ mexist = lua_tonumber (L,i) ;
+ } else if (lua_isstring(L,i)) {
+ int op = luaL_checkoption(L, i, NULL, filetypenames);
+ ftype = filetypes[op];
+ }
+ i--;
+ }
+ if (ftype==kpse_pk_format ||
+ ftype==kpse_gf_format ||
+ ftype==kpse_any_glyph_format) {
+ /* ret.format, ret.name, ret.dpi */
+ kpse_glyph_file_type ret;
+ lua_pushstring(L, kpse_find_glyph (st,mexist, ftype, &ret));
+ } else {
+ if (mexist>0)
+ mexist = 1;
+ if (mexist<0)
+ mexist = 0;
+ lua_pushstring(L, kpse_find_file (st,ftype,mexist));
+ }
+ return 1;
+}
+
+static int show_path (lua_State *L) {
+ int op = luaL_checkoption(L, -1, "tex", filetypenames);
+ int user_format = filetypes[op];
+ TEST_PROGRAM_NAME_SET;
+ if (!kpse_format_info[user_format].type) /* needed if arg was numeric */
+ kpse_init_format (user_format);
+ lua_pushstring (L, kpse_format_info[user_format].path);
+ return 1;
+}
+
+
+static int expand_path (lua_State *L) {
+ const char *st = luaL_checkstring(L,1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_path_expand(st));
+ return 1;
+}
+
+static int expand_braces (lua_State *L) {
+ const char *st = luaL_checkstring(L,1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_brace_expand(st));
+ return 1;
+}
+
+static int expand_var (lua_State *L) {
+ const char *st = luaL_checkstring(L,1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_var_expand(st));
+ return 1;
+}
+
+static int var_value (lua_State *L) {
+ const char *st = luaL_checkstring(L,1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_var_value(st));
+ return 1;
+}
+
+/* Engine support is a bit of a problem, because we do not want
+ * to interfere with the normal format discovery of |luatex|.
+ * Current approach: run |os.setenv()| if you have to.
+ */
+
+extern int luainit;
+
+static int set_program_name (lua_State *L) {
+ const char *exe_name = luaL_checkstring(L,1);
+ const char *prog_name = luaL_optstring(L,2,exe_name);
+ if (! program_name_set) {
+ kpse_set_program_name(exe_name, prog_name);
+ program_name_set = 1;
+ } else {
+ kpse_reset_program_name(prog_name);
+ }
+ /* fix up the texconfig entry */
+ lua_checkstack(L,3);
+ lua_getglobal(L,"texconfig");
+ if (lua_istable(L,-1)) {
+ lua_pushstring(L,"kpse_init");
+ lua_pushboolean(L,0);
+ lua_rawset(L,-3);
+ }
+ lua_pop(L,1);
+ return 0;
+}
+
+static int init_prog (lua_State *L) {
+ const char *prefix = luaL_checkstring(L,1);
+ unsigned dpi = luaL_checkinteger(L,2);
+ const char *mode = luaL_checkstring(L,3);
+ const char *fallback = luaL_optstring(L,4,NULL);
+ TEST_PROGRAM_NAME_SET;
+ kpse_init_prog(prefix,dpi,mode,fallback);
+ return 0;
+}
+
+static int readable_file (lua_State *L) {
+ const char *name = luaL_checkstring(L,1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L,(char *)kpse_readable_file (name));
+ return 1;
+}
+
+
+static const struct luaL_reg kpselib [] = {
+ {"set_program_name", set_program_name},
+ {"init_prog", init_prog},
+ {"readable_file", readable_file},
+ {"find_file", find_file},
+ {"expand_path", expand_path},
+ {"expand_var", expand_var},
+ {"expand_braces",expand_braces},
+ {"var_value",var_value},
+ {"show_path",show_path},
+ {NULL, NULL} /* sentinel */
+};
+
+
+int
+luaopen_kpse (lua_State *L)
+{
+ luaL_register(L,"kpse",kpselib);
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/llanglib.c b/Build/source/texk/web2c/luatexdir/lua/llanglib.c
new file mode 100644
index 00000000000..63e8c45dec8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/llanglib.c
@@ -0,0 +1,219 @@
+/*
+Copyright (c) 2007 Taco Hoekwater <taco@latex.org>
+
+This file is part of luatex.
+
+luatex is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+luatex is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with luatex; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+This is llanglib.c
+*/
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include "nodes.h"
+
+#define LANG_METATABLE "luatex.lang"
+
+#define check_islang(L,b) (struct tex_language **)luaL_checkudata(L,b,LANG_METATABLE)
+
+static int
+lang_new (lua_State *L) {
+ struct tex_language **lang;
+ if (lua_gettop(L)==0) {
+ lang = lua_newuserdata(L, sizeof(struct tex_language *));
+ *lang = new_language();
+ if (!*lang) {
+ lua_pushstring(L,"lang.new(): no room for a new language");
+ return lua_error(L);
+ }
+ } else {
+ lang = lua_newuserdata(L, sizeof(struct tex_language *));
+ *lang = get_language(lua_tonumber(L,1));
+ }
+ luaL_getmetatable(L,LANG_METATABLE);
+ lua_setmetatable(L,-2);
+ return 1;
+}
+
+static int
+lang_id (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ lua_pushnumber(L,(*lang_ptr)->id);
+ return 1;
+}
+
+static int
+lang_patterns (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ if (lua_gettop(L)!=1) {
+ if (!lua_isstring(L,2)) {
+ lua_pushstring(L,"lang.patterns(): argument should be a string");
+ return lua_error(L);
+ }
+ load_patterns(*lang_ptr, (unsigned char *)lua_tostring(L,2));
+ return 0;
+ } else {
+ if ((*lang_ptr)->patterns!=NULL) {
+ lua_pushstring(L,(char *)hnj_serialize((*lang_ptr)->patterns));
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ }
+}
+
+static int
+lang_clear_patterns (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ clear_patterns(*lang_ptr);
+ return 0;
+}
+
+
+static int
+lang_hyphenation (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ if (lua_gettop(L)!=1) {
+ if(!lua_isstring(L,2)) {
+ lua_pushstring(L,"lang.hyphenation(): argument should be a string");
+ return lua_error(L);
+ }
+ load_hyphenation(*lang_ptr,(unsigned char *)lua_tostring(L,2));
+ return 0;
+ } else {
+ if ((*lang_ptr)->exceptions!=0) {
+ lua_pushstring(L,exception_strings(*lang_ptr));
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ }
+}
+
+static int
+lang_pre_hyphen_char (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ if (lua_gettop(L)!=1) {
+ if(!lua_isnumber(L,2)) {
+ lua_pushstring(L,"lang.prehyphenchar(): argument should be a character number");
+ return lua_error(L);
+ }
+ (*lang_ptr)->pre_hyphen_char = lua_tonumber(L,2);
+ return 0;
+ } else {
+ lua_pushnumber(L,(*lang_ptr)->pre_hyphen_char);
+ return 1;
+ }
+}
+
+static int
+lang_post_hyphen_char (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ if (lua_gettop(L)!=1) {
+ if(!lua_isnumber(L,2)) {
+ lua_pushstring(L,"lang.posthyphenchar(): argument should be a character number");
+ return lua_error(L);
+ }
+ (*lang_ptr)->post_hyphen_char = lua_tonumber(L,2);
+ return 0;
+ } else {
+ lua_pushnumber(L,(*lang_ptr)->post_hyphen_char);
+ return 1;
+ }
+}
+
+static int
+lang_clear_hyphenation (lua_State *L) {
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L,1);
+ clear_hyphenation(*lang_ptr);
+ return 0;
+}
+
+
+static int
+do_lang_clean (lua_State *L) {
+ char *cleaned;
+ if (!lua_isstring(L,1)) {
+ lua_pushstring(L,"lang.clean(): argument should be a string");
+ return lua_error(L);
+ }
+ (void)clean_hyphenation((char *)lua_tostring(L,1),&cleaned);
+ lua_pushstring(L,cleaned);
+ return 1;
+}
+
+static int
+do_lang_hyphenate (lua_State *L) {
+ halfword *h,*t;
+ h = check_isnode(L,1);
+ if (lua_isuserdata(L,2)) {
+ t = check_isnode(L,2);
+ lua_pop(L,1);
+ } else {
+ t = h;
+ while (vlink(*t)!=null)
+ *t = vlink(*t);
+ }
+ hnj_hyphenation(*h,*t);
+ lua_pushboolean(L,1);
+ return 1;
+}
+
+
+static const struct luaL_reg langlib_d [] = {
+ {"clear_patterns", lang_clear_patterns},
+ {"clear_hyphenation", lang_clear_hyphenation},
+ {"patterns", lang_patterns},
+ {"hyphenation", lang_hyphenation},
+ {"prehyphenchar", lang_pre_hyphen_char},
+ {"posthyphenchar", lang_post_hyphen_char},
+ {"id", lang_id},
+ {NULL, NULL} /* sentinel */
+};
+
+
+static const struct luaL_reg langlib[] = {
+ {"clear_patterns", lang_clear_patterns},
+ {"clear_hyphenation", lang_clear_hyphenation},
+ {"patterns", lang_patterns},
+ {"hyphenation", lang_hyphenation},
+ {"prehyphenchar", lang_pre_hyphen_char},
+ {"posthyphenchar", lang_post_hyphen_char},
+ {"id", lang_id},
+ {"clean", do_lang_clean},
+ {"hyphenate", do_lang_hyphenate},
+ {"new", lang_new},
+ {NULL, NULL} /* sentinel */
+};
+
+
+int
+luaopen_lang (lua_State *L) {
+ luaL_newmetatable(L,LANG_METATABLE);
+ lua_pushvalue(L, -1); /* push metatable */
+ lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
+ luaL_register(L, NULL, langlib_d); /* dict methods */
+ luaL_register(L, "lang", langlib);
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/llualib.c b/Build/source/texk/web2c/luatexdir/lua/llualib.c
new file mode 100644
index 00000000000..0d13500a9b7
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/llualib.c
@@ -0,0 +1,229 @@
+
+/* $Id: llualib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#define LOAD_BUF_SIZE 256
+#define UINT_MAX32 0xFFFFFFFF
+
+typedef struct {
+ unsigned char* buf;
+ int size;
+ int done;
+ int alloc;
+} bytecode;
+
+static bytecode *lua_bytecode_registers = NULL;
+
+int luabytecode_max = -1;
+unsigned int luabytecode_bytes = 0;
+
+void dump_luac_registers (void) {
+ int k,n;
+ bytecode b;
+ dump_int(luabytecode_max);
+ if (lua_bytecode_registers != NULL) {
+ n = 0;
+ for (k=0;k<=luabytecode_max;k++) {
+ if (lua_bytecode_registers[k].size != 0)
+ n++;
+ }
+ dump_int(n);
+ for (k=0;k<=luabytecode_max;k++) {
+ b = lua_bytecode_registers[k];
+ if (b.size != 0) {
+ dump_int(k);
+ dump_int(b.size);
+ do_zdump ((char *)b.buf,1,(b.size), DUMP_FILE);
+ }
+ }
+ }
+}
+
+void undump_luac_registers (void) {
+ int k,n;
+ unsigned int i;
+ bytecode b;
+ undump_int(luabytecode_max);
+ if (luabytecode_max>=0) {
+ i = (luabytecode_max+1);
+ if ((int)(UINT_MAX32/sizeof(bytecode)+1)<=i) {
+ lua_fatal_error("Corrupt format file");
+ }
+ lua_bytecode_registers = xmalloc(i*sizeof(bytecode));
+ luabytecode_bytes = i*sizeof(bytecode);
+ for (i=0;i<=luabytecode_max;i++) {
+ lua_bytecode_registers[i].done = 0;
+ lua_bytecode_registers[i].size = 0;
+ lua_bytecode_registers[i].buf = NULL;
+ }
+ undump_int(n);
+ for (i=0;i<n;i++) {
+ undump_int(k);
+ undump_int(b.size);
+ b.buf=xmalloc(b.size);
+ luabytecode_bytes += b.size;
+ memset(b.buf, 0, b.size);
+ do_zundump ((char *)b.buf,1, b.size, DUMP_FILE);
+ lua_bytecode_registers[k].size = b.size;
+ lua_bytecode_registers[k].alloc = b.size;
+ lua_bytecode_registers[k].buf = b.buf;
+ }
+ }
+}
+
+static void
+bytecode_register_shadow_set (lua_State* L, int k){
+ /* the stack holds the value to be set */
+ lua_pushstring(L,"bytecode_shadow"); /* lua.bytecode_shadow */
+ lua_rawget(L,LUA_REGISTRYINDEX);
+ if (lua_istable(L, -1)) {
+ lua_pushvalue(L,-2);
+ lua_rawseti(L,-2,k);
+ }
+ lua_pop(L,1); /* pop table or nil */
+ lua_pop(L,1); /* pop value */
+}
+
+
+static int
+bytecode_register_shadow_get (lua_State* L, int k){
+ /* the stack holds the value to be set */
+ int ret = 0;
+ lua_pushstring(L,"bytecode_shadow");
+ lua_rawget(L,LUA_REGISTRYINDEX);
+ if (lua_istable(L, -1)) {
+ lua_rawgeti(L,-1,k);
+ if (!lua_isnil(L,-1))
+ ret = 1;
+ lua_insert(L,-3); /* store the value or nil, deeper down */
+ lua_pop(L,1); /* pop the value or nil at top */
+ }
+ lua_pop(L,1); /* pop table or nil */
+ return ret;
+}
+
+
+int writer(lua_State* L, const void* b, size_t size, void* B) {
+ bytecode* buf = (bytecode*)B;
+ if (buf->size + size > buf->alloc) {
+ buf->buf = xrealloc(buf->buf,buf->alloc+size+LOAD_BUF_SIZE);
+ buf->alloc = buf->alloc+size+LOAD_BUF_SIZE;
+ }
+ memcpy(buf->buf+buf->size, b, size);
+ buf->size += size;
+ luabytecode_bytes += size;
+ return 0;
+}
+
+const char* reader(lua_State* L, void* ud, size_t* size) {
+ bytecode* buf = (bytecode*)ud;
+ if (buf->done == buf->size) {
+ *size = 0;
+ buf->done = 0;
+ return NULL;
+ }
+ *size = buf->size;
+ buf->done = buf->size;
+ return (const char*)buf->buf;
+}
+
+int get_bytecode (lua_State *L) {
+ int k;
+ k = (int)luaL_checkinteger(L,-1);
+ if (k<0) {
+ lua_pushnil(L);
+ } else if (!bytecode_register_shadow_get(L,k)) {
+ if (k<=luabytecode_max && lua_bytecode_registers[k].buf != NULL) {
+ if(lua_load(L,reader,(void *)(lua_bytecode_registers+k),"bytecode")) {
+ lua_error(L);
+ lua_pushnil(L);
+ } else {
+ lua_pushvalue(L,-1);
+ bytecode_register_shadow_set(L,k);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ }
+ return 1;
+}
+
+int set_bytecode (lua_State *L) {
+ int k, ltype;
+ unsigned int i;
+ k = (int)luaL_checkinteger(L,-2);
+ i = k+1;
+ if ((int)(UINT_MAX32/sizeof(bytecode)+1)<i) {
+ lua_pushstring(L, "value too large");
+ lua_error(L);
+ }
+ if (k<0) {
+ lua_pushstring(L, "negative values not allowed");
+ lua_error(L);
+ }
+ ltype = lua_type(L,-1);
+ if (ltype != LUA_TFUNCTION && ltype != LUA_TNIL){
+ lua_pushstring(L, "unsupported type");
+ lua_error(L);
+ }
+ if (k>luabytecode_max) {
+ i = sizeof(bytecode)*(k+1);
+ lua_bytecode_registers = xrealloc(lua_bytecode_registers,i);
+ if (luabytecode_max==-1) {
+ luabytecode_bytes += sizeof(bytecode)*(k+1);
+ } else {
+ luabytecode_bytes += sizeof(bytecode)*(k+1-luabytecode_max);
+ }
+ for (i=(luabytecode_max+1);i<=k;i++) {
+ lua_bytecode_registers[i].buf=NULL;
+ lua_bytecode_registers[i].size=0;
+ lua_bytecode_registers[i].done=0;
+ }
+ luabytecode_max = k;
+ }
+ if (lua_bytecode_registers[k].buf != NULL) {
+ xfree(lua_bytecode_registers[k].buf);
+ luabytecode_bytes -= lua_bytecode_registers[k].size;
+ lua_bytecode_registers[k].buf = NULL;
+ lua_bytecode_registers[k].size=0;
+ lua_bytecode_registers[k].done=0;
+ lua_pushnil(L);
+ bytecode_register_shadow_set(L,k);
+ }
+ if (ltype == LUA_TFUNCTION) {
+ lua_bytecode_registers[k].buf=xmalloc(LOAD_BUF_SIZE);
+ lua_bytecode_registers[k].alloc = LOAD_BUF_SIZE;
+ memset(lua_bytecode_registers[k].buf, 0, LOAD_BUF_SIZE);
+ lua_dump(L,writer,(void *)(lua_bytecode_registers+k));
+ }
+ lua_pop(L,1);
+ return 0;
+}
+
+static const struct luaL_reg lualib [] = {
+ {"getbytecode", get_bytecode},
+ {"setbytecode", set_bytecode},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_lua (lua_State *L, int n, char *fname)
+{
+ luaL_register(L, "lua", lualib);
+ make_table(L,"bytecode","getbytecode","setbytecode");
+ lua_newtable(L);
+ lua_setfield(L, LUA_REGISTRYINDEX, "bytecode_shadow");
+ lua_pushinteger(L, n);
+ lua_setfield(L, -2, "id");
+ lua_pushstring(L, "0.1");
+ lua_setfield(L, -2, "version");
+ if (fname == NULL) {
+ lua_pushnil(L);
+ } else {
+ lua_pushstring(L, fname);
+ }
+ lua_setfield(L, -2, "startupfile");
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/lmplib.c b/Build/source/texk/web2c/luatexdir/lua/lmplib.c
new file mode 100644
index 00000000000..a194f9a55d8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lmplib.c
@@ -0,0 +1,1251 @@
+/* $Id$ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+
+#ifndef pdfTeX
+#include <lua.h>
+#include <lauxlib.h>
+#include <lualib.h>
+#else
+#include <../lua51/lua.h>
+#include <../lua51/lauxlib.h>
+#include <../lua51/lualib.h>
+#endif
+
+#include "mplib.h"
+#include "mpmp.h"
+#include "mppsout.h" /* for mp_edge_object */
+
+#define MPLIB_METATABLE "MPlib"
+#define MPLIB_FIG_METATABLE "MPlib.fig"
+#define MPLIB_GR_METATABLE "MPlib.gr"
+
+#define mplib_init_S(a) do { \
+ lua_pushliteral(L,#a); \
+ mplib_##a##_ptr = (char *)lua_tostring(L,-1); \
+ mplib_##a##_index = luaL_ref (L,LUA_REGISTRYINDEX); \
+ } while (0)
+
+#define mplib_push_S(a) do { \
+ lua_rawgeti(L,LUA_REGISTRYINDEX,mplib_##a##_index); \
+ } while (0)
+
+#define mplib_is_S(a,i) (mplib_##a##_ptr==(char *)lua_tostring(L,i))
+
+#define mplib_make_S(a) \
+ static int mplib_##a##_index = 0; \
+ static char *mplib_##a##_ptr = NULL
+
+static int mplib_type_Ses[mp_special_code+1] = {0}; /* [0] is not used */
+
+mplib_make_S(fill);
+mplib_make_S(outline);
+mplib_make_S(text);
+mplib_make_S(special);
+mplib_make_S(start_bounds);
+mplib_make_S(stop_bounds);
+mplib_make_S(start_clip);
+mplib_make_S(stop_clip);
+
+mplib_make_S(left_type);
+mplib_make_S(right_type);
+mplib_make_S(x_coord);
+mplib_make_S(y_coord);
+mplib_make_S(left_x);
+mplib_make_S(left_y);
+mplib_make_S(right_x);
+mplib_make_S(right_y);
+
+mplib_make_S(color);
+mplib_make_S(dash);
+mplib_make_S(depth);
+mplib_make_S(dsize);
+mplib_make_S(font);
+mplib_make_S(height);
+mplib_make_S(htap);
+mplib_make_S(linecap);
+mplib_make_S(linejoin);
+mplib_make_S(miterlimit);
+mplib_make_S(path);
+mplib_make_S(pen);
+mplib_make_S(postscript);
+mplib_make_S(prescript);
+mplib_make_S(transform);
+mplib_make_S(type);
+mplib_make_S(width);
+
+void mplib_init_Ses(lua_State *L) {
+ mplib_init_S(fill);
+ mplib_init_S(outline);
+ mplib_init_S(text);
+ mplib_init_S(start_bounds);
+ mplib_init_S(stop_bounds);
+ mplib_init_S(start_clip);
+ mplib_init_S(stop_clip);
+ mplib_init_S(special);
+
+ mplib_type_Ses[mp_fill_code] = mplib_fill_index;
+ mplib_type_Ses[mp_stroked_code] = mplib_outline_index;
+ mplib_type_Ses[mp_text_code] = mplib_text_index;
+ mplib_type_Ses[mp_start_bounds_code] = mplib_start_bounds_index;
+ mplib_type_Ses[mp_stop_bounds_code] = mplib_stop_bounds_index;
+ mplib_type_Ses[mp_start_clip_code] = mplib_start_clip_index;
+ mplib_type_Ses[mp_stop_clip_code] = mplib_stop_clip_index;
+ mplib_type_Ses[mp_special_code] = mplib_special_index;
+
+ mplib_init_S(left_type);
+ mplib_init_S(right_type);
+ mplib_init_S(x_coord);
+ mplib_init_S(y_coord);
+ mplib_init_S(left_x);
+ mplib_init_S(left_y);
+ mplib_init_S(right_x);
+ mplib_init_S(right_y);
+
+ mplib_init_S(color);
+ mplib_init_S(dash);
+ mplib_init_S(depth);
+ mplib_init_S(dsize);
+ mplib_init_S(font);
+ mplib_init_S(height);
+ mplib_init_S(htap);
+ mplib_init_S(linecap);
+ mplib_init_S(linejoin);
+ mplib_init_S(miterlimit);
+ mplib_init_S(path);
+ mplib_init_S(pen);
+ mplib_init_S(postscript);
+ mplib_init_S(prescript);
+ mplib_init_S(transform);
+ mplib_init_S(type);
+ mplib_init_S(width);
+}
+
+
+
+
+#define xfree(A) if ((A)!=NULL) { free((A)); A = NULL; }
+
+#define is_mp(L,b) (MP *)luaL_checkudata(L,b,MPLIB_METATABLE)
+#define is_fig(L,b) (struct mp_edge_object **)luaL_checkudata(L,b,MPLIB_FIG_METATABLE)
+#define is_gr_object(L,b) (struct mp_graphic_object **)luaL_checkudata(L,b,MPLIB_GR_METATABLE)
+
+/* Enumeration string arrays */
+
+static const char *interaction_options[] =
+ { "unknown","batch","nonstop","scroll","errorstop", NULL};
+
+static const char *mplib_filetype_names[] =
+ {"term", "error", "mp", "log", "ps", "mem", "tfm", "map", "pfb", "enc", NULL};
+
+/* only "endpoint" and "explicit" actually happen in paths,
+ as well as "open" in elliptical pens */
+
+static const char *knot_type_enum[] =
+ { "endpoint", "explicit", "given", "curl", "open", "end_cycle" };
+
+/* object fields */
+
+static const char *fill_fields[] =
+ { "type", "path", "htap", "pen", "color", "linejoin", "miterlimit",
+ "prescript", "postscript", NULL };
+
+static const char *stroked_fields[] =
+ { "type", "path", "pen", "color", "linejoin", "miterlimit", "linecap", "dash",
+ "prescript", "postscript", NULL };
+
+static const char *text_fields[] =
+ { "type", "text", "dsize", "font", "color", "width", "height", "depth", "transform",
+ "prescript", "postscript", NULL };
+
+static const char *special_fields[] =
+ { "type", "prescript", NULL };
+
+static const char *start_bounds_fields[] =
+ { "type", "path", NULL };
+
+static const char *start_clip_fields[] =
+ { "type", "path", NULL };
+
+static const char *stop_bounds_fields[] =
+ { "type", NULL };
+
+static const char *stop_clip_fields[] =
+ { "type", NULL };
+
+static const char *no_fields[] =
+ { NULL };
+
+typedef enum {
+ P_ERROR_LINE, P_HALF_LINE, P_MAX_LINE, P_MAIN_MEMORY,
+ P_HASH_SIZE, P_HASH_PRIME, P_PARAM_SIZE, P_IN_OPEN, P_RANDOM_SEED,
+ P_INTERACTION, P_INI_VERSION, P_TROFF_MODE, P_PRINT_NAMES, P_MEM_NAME,
+ P_JOB_NAME, P_FIND_FILE, P__SENTINEL
+} mplib_parm_idx;
+
+typedef struct {
+ const char *name; /* parameter name */
+ mplib_parm_idx idx; /* parameter index */
+} mplib_parm_struct;
+
+static mplib_parm_struct mplib_parms[] = {
+ {"error_line", P_ERROR_LINE },
+ {"half_error_line", P_HALF_LINE },
+ {"max_print_line", P_MAX_LINE },
+ {"main_memory", P_MAIN_MEMORY },
+ {"hash_size", P_HASH_SIZE },
+ {"hash_prime", P_HASH_PRIME },
+ {"param_size", P_PARAM_SIZE },
+ {"max_in_open", P_IN_OPEN },
+ {"random_seed", P_RANDOM_SEED },
+ {"interaction", P_INTERACTION },
+ {"ini_version", P_INI_VERSION },
+ {"troff_mode", P_TROFF_MODE },
+ {"print_found_names", P_PRINT_NAMES },
+ {"mem_name", P_MEM_NAME },
+ {"job_name", P_JOB_NAME },
+ {"find_file", P_FIND_FILE },
+ {NULL, P__SENTINEL }
+};
+
+typedef struct _FILE_ITEM {
+ FILE *f;
+} _FILE_ITEM ;
+
+typedef struct _FILE_ITEM File;
+
+#define make_stream_buf(A) char *A; size_t A##_size; size_t A##_used
+
+#define free_stream_buf(A) xfree(mplib_data->A); mplib_data->A##_size = 0; mplib_data->A##_used = 0
+
+typedef struct _MPLIB_INSTANCE_DATA {
+ void *term_file_ptr;
+ void *err_file_ptr;
+ void *log_file_ptr;
+ void *ps_file_ptr;
+ make_stream_buf(term_out);
+ make_stream_buf(error_out);
+ make_stream_buf(log_out);
+ make_stream_buf(ps_out);
+ char *input_data;
+ char *input_data_ptr;
+ size_t input_data_len;
+ struct mp_edge_object *edges ;
+ lua_State *LL;
+} _MPLIB_INSTANCE_DATA;
+
+typedef struct _MPLIB_INSTANCE_DATA mplib_instance;
+
+static mplib_instance *mplib_get_data (MP mp) {
+ return (mplib_instance *)mp->userdata;
+}
+
+static mplib_instance *mplib_make_data (void) {
+ mplib_instance *mplib_data = malloc(sizeof(mplib_instance));
+ memset(mplib_data,0,sizeof(mplib_instance));
+ return mplib_data ;
+}
+
+
+/* Start by defining all the callback routines for the library
+ * except |run_make_mpx| and |run_editor|.
+ */
+
+
+char *mplib_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ lua_State *L = mplib_data->LL;
+ lua_checkstack(L,4);
+ lua_getfield(L,LUA_REGISTRYINDEX,"mplib_file_finder");
+ if (lua_isfunction(L,-1)) {
+ char *s = NULL, *x = NULL;
+ lua_pushstring(L, fname);
+ lua_pushstring(L, fmode);
+ if (ftype >= mp_filetype_text) {
+ lua_pushnumber(L, ftype-mp_filetype_text);
+ } else {
+ lua_pushstring(L, mplib_filetype_names[ftype]);
+ }
+ if(lua_pcall(L,3,1,0) != 0) {
+ fprintf(stdout,"Error in mp.find_file: %s\n", (char *)lua_tostring(L,-1));
+ return NULL;
+ }
+ x = (char *)lua_tostring(L,-1);
+ if (x!=NULL)
+ s = strdup(x);
+ lua_pop(L,1); /* pop the string */
+ return s;
+ } else {
+ lua_pop(L,1);
+ }
+ if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
+ return strdup(fname);
+ }
+ return NULL;
+}
+
+static int
+mplib_find_file_function (lua_State *L) {
+ if (! (lua_isfunction(L,-1)|| lua_isnil(L,-1) )) {
+ return 1; /* error */
+ }
+ lua_pushstring(L, "mplib_file_finder");
+ lua_pushvalue(L,-2);
+ lua_rawset(L,LUA_REGISTRYINDEX);
+ return 0;
+}
+
+void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
+ File *ff = malloc(sizeof (File));
+ if (ff) {
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ ff->f = NULL;
+ if (ftype==mp_filetype_terminal) {
+ if (fmode[0] == 'r') {
+ ff->f = stdin;
+ } else {
+ xfree(mplib_data->term_file_ptr);
+ ff->f = malloc(1);
+ mplib_data->term_file_ptr = ff->f;
+ }
+ } else if (ftype==mp_filetype_error) {
+ xfree(mplib_data->err_file_ptr);
+ ff->f = malloc(1);
+ mplib_data->err_file_ptr = ff->f;
+ } else if (ftype == mp_filetype_log) {
+ xfree(mplib_data->log_file_ptr);
+ ff->f = malloc(1);
+ mplib_data->log_file_ptr = ff->f;
+ } else if (ftype == mp_filetype_postscript) {
+ xfree(mplib_data->ps_file_ptr);
+ ff->f = malloc(1);
+ mplib_data->ps_file_ptr = ff->f;
+ } else {
+ char realmode[3];
+ char *f = mplib_find_file(mp, fname,fmode,ftype);
+ if (f==NULL)
+ return NULL;
+ realmode[0] = *fmode;
+ realmode[1] = 'b';
+ realmode[2] = 0;
+ ff->f = fopen(f, realmode);
+ if ((fmode[0] == 'r') && (ff->f == NULL)) {
+ free(ff);
+ return NULL;
+ }
+ }
+ return ff;
+ }
+ return NULL;
+}
+
+static int
+mplib_get_char (void *f, mplib_instance *mplib_data) {
+ int c;
+ if (f==stdin && mplib_data->input_data != NULL) {
+ if (mplib_data->input_data_len==0) {
+ if (mplib_data->input_data_ptr!=NULL)
+ mplib_data->input_data_ptr = NULL;
+ else
+ mplib_data->input_data = NULL;
+ c = EOF;
+ } else {
+ mplib_data->input_data_len--;
+ c = *(mplib_data->input_data_ptr)++;
+ }
+ } else {
+ c = fgetc(f);
+ }
+ return c;
+}
+
+static void
+mplib_unget_char (void *f, mplib_instance *mplib_data, int c) {
+ if (f==stdin && mplib_data->input_data_ptr != NULL) {
+ mplib_data->input_data_len++;
+ mplib_data->input_data_ptr--;
+ } else {
+ ungetc(c,f);
+ }
+}
+
+
+char *mplib_read_ascii_file (MP mp, void *ff, size_t *size) {
+ char *s = NULL;
+ if (ff!=NULL) {
+ int c;
+ size_t len = 0, lim = 128;
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ FILE *f = ((File *)ff)->f;
+ if (f==NULL)
+ return NULL;
+ *size = 0;
+ c = mplib_get_char(f,mplib_data);
+ if (c==EOF)
+ return NULL;
+ s = malloc(lim);
+ if (s==NULL) return NULL;
+ while (c!=EOF && c!='\n' && c!='\r') {
+ if (len==lim) {
+ s =realloc(s, (lim+(lim>>2)));
+ if (s==NULL) return NULL;
+ lim+=(lim>>2);
+ }
+ s[len++] = c;
+ c = mplib_get_char(f,mplib_data);
+ }
+ if (c=='\r') {
+ c = mplib_get_char(f,mplib_data);
+ if (c!=EOF && c!='\n')
+ mplib_unget_char(f,mplib_data,c);
+ }
+ s[len] = 0;
+ *size = len;
+ }
+ return s;
+}
+
+#define APPEND_STRING(a,b) do { \
+ if ((mplib_data->a##_used+strlen(b))>=mplib_data->a##_size) { \
+ mplib_data->a##_size += 256+(mplib_data->a##_size)/5+strlen(b); \
+ mplib_data->a = realloc(mplib_data->a,mplib_data->a##_size); \
+ } \
+ (void)strcpy(mplib_data->a+mplib_data->a##_used,b); \
+ mplib_data->a##_used += strlen(b); \
+ } while (0)
+
+void mplib_write_ascii_file (MP mp, void *ff, const char *s) {
+ if (ff!=NULL) {
+ void *f = ((File *)ff)->f;
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ if (f!=NULL) {
+ if (f==mplib_data->term_file_ptr) {
+ APPEND_STRING(term_out,s);
+ } else if (f==mplib_data->err_file_ptr) {
+ APPEND_STRING(error_out,s);
+ } else if (f==mplib_data->log_file_ptr) {
+ APPEND_STRING(log_out,s);
+ } else if (f==mplib_data->ps_file_ptr) {
+ APPEND_STRING(ps_out,s);
+ } else {
+ fprintf((FILE *)f,s);
+ }
+ }
+ }
+}
+
+void mplib_read_binary_file (MP mp, void *ff, void **data, size_t *size) {
+ (void)mp;
+ if (ff!=NULL) {
+ size_t len = 0;
+ FILE *f = ((File *)ff)->f;
+ if (f!=NULL)
+ len = fread(*data,1,*size,f);
+ *size = len;
+ }
+}
+
+void mplib_write_binary_file (MP mp, void *ff, void *s, size_t size) {
+ (void)mp;
+ if (ff!=NULL) {
+ FILE *f = ((File *)ff)->f;
+ if (f!=NULL)
+ fwrite(s,size,1,f);
+ }
+}
+
+
+void mplib_close_file (MP mp, void *ff) {
+ if (ff!=NULL) {
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ void *f = ((File *)ff)->f;
+ if (f != NULL && f != mplib_data->term_file_ptr && f != mplib_data->err_file_ptr
+ && f != mplib_data->log_file_ptr && f != mplib_data->ps_file_ptr) {
+ fclose(f);
+ }
+ free(ff);
+ }
+}
+
+int mplib_eof_file (MP mp, void *ff) {
+ if (ff!=NULL) {
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ FILE *f = ((File *)ff)->f;
+ if (f==NULL)
+ return 1;
+ if (f==stdin && mplib_data->input_data != NULL) {
+ return (mplib_data->input_data_len==0);
+ }
+ return feof(f);
+ }
+ return 1;
+}
+
+void mplib_flush_file (MP mp, void *ff) {
+ (void)mp;
+ (void)ff;
+ return ;
+}
+
+#define APPEND_TO_EDGES(a) do { \
+ if (mplib_data->edges==NULL) { \
+ mplib_data->edges = hh; \
+ } else { \
+ struct mp_edge_object *p = mplib_data->edges; \
+ while (p->_next!=NULL) { p = p->_next; } \
+ p->_next = hh; \
+ } \
+} while (0)
+
+void mplib_shipout_backend (MP mp, int h) {
+ struct mp_edge_object *hh = mp_gr_export(mp, h);
+ if (hh) {
+ mplib_instance *mplib_data = mplib_get_data(mp);
+ APPEND_TO_EDGES(hh);
+ }
+}
+
+
+static void
+mplib_setup_file_ops(struct MP_options * options) {
+ options->find_file = mplib_find_file;
+ options->open_file = mplib_open_file;
+ options->close_file = mplib_close_file;
+ options->eof_file = mplib_eof_file;
+ options->flush_file = mplib_flush_file;
+ options->write_ascii_file = mplib_write_ascii_file;
+ options->read_ascii_file = mplib_read_ascii_file;
+ options->write_binary_file = mplib_write_binary_file;
+ options->read_binary_file = mplib_read_binary_file;
+ options->shipout_backend = mplib_shipout_backend;
+}
+
+static int
+mplib_new (lua_State *L) {
+ MP *mp_ptr;
+ mp_ptr = lua_newuserdata(L, sizeof(MP *));
+ if (mp_ptr) {
+ int i;
+ mplib_instance *mplib_data;
+ struct MP_options * options; /* instance options */
+ options = mp_options();
+ mplib_setup_file_ops(options);
+ mplib_data = mplib_make_data();
+ mplib_data->LL = L;
+ options->userdata = (void *)mplib_data;
+ options->noninteractive = 1; /* required ! */
+ options->print_found_names = 0;
+ if (lua_type(L,1)==LUA_TTABLE) {
+ for (i=0;mplib_parms[i].name!=NULL;i++) {
+ lua_getfield(L,1,mplib_parms[i].name);
+ if (lua_isnil(L,-1)) {
+ lua_pop(L,1);
+ continue; /* skip unset */
+ }
+ switch(mplib_parms[i].idx) {
+ case P_ERROR_LINE:
+ options->error_line = lua_tointeger(L,-1);
+ break;
+ case P_HALF_LINE:
+ options->half_error_line = lua_tointeger(L,-1);
+ break;
+ case P_MAX_LINE:
+ options->max_print_line = lua_tointeger(L,-1);
+ break;
+ case P_MAIN_MEMORY:
+ options->main_memory = lua_tointeger(L,-1);
+ break;
+ case P_HASH_SIZE:
+ options->hash_size = lua_tointeger(L,-1);
+ break;
+ case P_HASH_PRIME:
+ options->hash_prime = lua_tointeger(L,-1);
+ break;
+ case P_PARAM_SIZE:
+ options->param_size = lua_tointeger(L,-1);
+ break;
+ case P_IN_OPEN:
+ options->max_in_open = lua_tointeger(L,-1);
+ break;
+ case P_RANDOM_SEED:
+ options->random_seed = lua_tointeger(L,-1);
+ break;
+ case P_INTERACTION:
+ options->interaction = luaL_checkoption(L,-1,"errorstopmode", interaction_options);
+ break;
+ case P_INI_VERSION:
+ options->ini_version = lua_toboolean(L,-1);
+ break;
+ case P_TROFF_MODE:
+ options->troff_mode = lua_toboolean(L,-1);
+ break;
+ case P_PRINT_NAMES:
+ options->print_found_names = lua_toboolean(L,-1);
+ break;
+ /*
+ case P_COMMAND_LINE:
+ options->command_line = strdup((char *)lua_tostring(L,-1));
+ break;
+ */
+ case P_MEM_NAME:
+ options->mem_name = strdup((char *)lua_tostring(L,-1));
+ break;
+ case P_JOB_NAME:
+ options->job_name = strdup((char *)lua_tostring(L,-1));
+ break;
+ case P_FIND_FILE:
+ if(mplib_find_file_function(L)) { /* error here */
+ fprintf(stdout,"Invalid arguments to mp.new({find_file=...})\n");
+ }
+ break;
+ default:
+ break;
+ }
+ lua_pop(L,1);
+ }
+ }
+ *mp_ptr = mp_new(options);
+ xfree(options->command_line);
+ xfree(options->mem_name);
+ xfree(options->job_name);
+ free(options);
+ if (*mp_ptr) {
+ luaL_getmetatable(L,MPLIB_METATABLE);
+ lua_setmetatable(L,-2);
+ return 1;
+ }
+ }
+ lua_pushnil(L);
+ return 1;
+}
+
+static int
+mplib_collect (lua_State *L) {
+ MP *mp_ptr = is_mp(L,1);
+ xfree(*mp_ptr);
+ return 0;
+}
+
+static int
+mplib_tostring (lua_State *L) {
+ MP *mp_ptr = is_mp(L,1);
+ if (*mp_ptr!=NULL) {
+ lua_pushfstring(L,"<MP %p>",*mp_ptr);
+ return 1;
+ }
+ return 0;
+}
+
+static int
+mplib_wrapresults(lua_State *L, mplib_instance *mplib_data, int h) {
+ lua_checkstack(L,5);
+ lua_newtable(L);
+ if (mplib_data->term_out != NULL) {
+ lua_pushstring(L,mplib_data->term_out);
+ lua_setfield(L,-2,"term");
+ free_stream_buf(term_out);
+ }
+ if (mplib_data->error_out != NULL) {
+ lua_pushstring(L,mplib_data->error_out);
+ lua_setfield(L,-2,"error");
+ free_stream_buf(error_out);
+ }
+ if (mplib_data->log_out != NULL ) {
+ lua_pushstring(L,mplib_data->log_out);
+ lua_setfield(L,-2,"log");
+ free_stream_buf(log_out);
+ }
+ if (mplib_data->edges != NULL ) {
+ struct mp_edge_object **v;
+ struct mp_edge_object *p = mplib_data->edges;
+ int i = 1;
+ lua_newtable(L);
+ while (p!=NULL) {
+ v = lua_newuserdata (L, sizeof(struct mp_edge_object *));
+ *v = p;
+ luaL_getmetatable(L,MPLIB_FIG_METATABLE);
+ lua_setmetatable(L,-2);
+ lua_rawseti(L,-2,i); i++;
+ p = p->_next;
+ }
+ lua_setfield(L,-2,"fig");
+ mplib_data->edges = NULL;
+ }
+ lua_pushnumber(L,h);
+ lua_setfield(L,-2,"status");
+ return 1;
+}
+
+static int
+mplib_execute (lua_State *L) {
+ MP *mp_ptr = is_mp(L,1);
+ if (*mp_ptr!=NULL && lua_isstring(L,2)) {
+ int h;
+ mplib_instance *mplib_data = mplib_get_data(*mp_ptr);
+ mplib_data->input_data = (char *)lua_tolstring(L,2, &(mplib_data->input_data_len));
+ mplib_data->input_data_ptr = mplib_data->input_data;
+ if ((*mp_ptr)->run_state==0) {
+ h = mp_initialize(*mp_ptr);
+ }
+ h = mp_execute(*mp_ptr);
+ if (mplib_data->input_data_len!=0) {
+ mplib_data->input_data = NULL;
+ mplib_data->input_data_ptr = NULL;
+ mplib_data->input_data_len=0;
+ }
+ return mplib_wrapresults(L, mplib_data, h);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int
+mplib_finish (lua_State *L) {
+ MP *mp_ptr = is_mp(L,1);
+ if (*mp_ptr!=NULL) {
+ mplib_instance *mplib_data = mplib_get_data(*mp_ptr);
+ int h = mp_finish(*mp_ptr);
+ return mplib_wrapresults(L, mplib_data, h);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int
+mplib_statistics (lua_State *L) {
+ MP *mp_ptr = is_mp(L,1);
+ if (*mp_ptr!=NULL) {
+ lua_newtable(L);
+ lua_pushnumber(L, mp_memory_usage (*mp_ptr));
+ lua_setfield(L,-2,"main_memory");
+ lua_pushnumber(L, mp_hash_usage (*mp_ptr));
+ lua_setfield(L,-2,"hash_size");
+ lua_pushnumber(L, mp_param_usage (*mp_ptr));
+ lua_setfield(L,-2,"param_size");
+ lua_pushnumber(L, mp_open_usage (*mp_ptr));
+ lua_setfield(L,-2,"max_in_open");
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+/* figure methods */
+
+static int
+mplib_fig_collect (lua_State *L) {
+ struct mp_edge_object **hh = is_fig(L,1);
+ if (*hh!=NULL) {
+ mp_gr_toss_objects (*hh);
+ *hh=NULL;
+ }
+ return 0;
+}
+
+static int
+mplib_fig_body (lua_State *L) {
+ int i = 1;
+ struct mp_graphic_object **v;
+ struct mp_graphic_object *p;
+ struct mp_edge_object **hh = is_fig(L,1);
+ lua_newtable(L);
+ p = (*hh)->body;
+ while (p!=NULL) {
+ v = lua_newuserdata (L, sizeof(struct mp_graphic_object *));
+ *v = p;
+ luaL_getmetatable(L,MPLIB_GR_METATABLE);
+ lua_setmetatable(L,-2);
+ lua_rawseti(L,-2,i); i++;
+ p = p->_link_field;
+ }
+ (*hh)->body = NULL; /* prevent double free */
+ return 1;
+}
+
+static int
+mplib_fig_copy_body (lua_State *L) {
+ int i = 1;
+ struct mp_graphic_object **v;
+ struct mp_graphic_object *p;
+ struct mp_edge_object **hh = is_fig(L,1);
+ lua_newtable(L);
+ p = (*hh)->body;
+ while (p!=NULL) {
+ v = lua_newuserdata (L, sizeof(struct mp_graphic_object *));
+ *v = mp_gr_copy_object((*hh)->_parent,p);
+ luaL_getmetatable(L,MPLIB_GR_METATABLE);
+ lua_setmetatable(L,-2);
+ lua_rawseti(L,-2,i); i++;
+ p = p->_link_field;
+ }
+ return 1;
+}
+
+
+static int
+mplib_fig_tostring (lua_State *L) {
+ struct mp_edge_object **hh = is_fig(L,1);
+ lua_pushfstring(L,"<figure %p>",*hh);
+ return 1;
+}
+
+
+
+static int
+mp_wrapped_shipout (struct mp_edge_object *hh, int prologues, int procset) {
+ MP mp = hh->_parent;
+ if (setjmp(mp->jump_buf)) {
+ return 0;
+ }
+ mp_gr_ship_out(hh,prologues,procset);
+ return 1;
+}
+
+static int
+mplib_fig_postscript (lua_State *L) {
+ struct mp_edge_object **hh = is_fig(L,1);
+ int prologues = luaL_optnumber(L,2,-1);
+ int procset = luaL_optnumber(L,3,-1);
+ mplib_instance *mplib_data = mplib_get_data((*hh)->_parent);
+ if (mplib_data->ps_out == NULL) {
+ if (mp_wrapped_shipout(*hh,prologues, procset)) {
+ if (mplib_data->ps_out!=NULL ) {
+ lua_pushstring(L, mplib_data->ps_out);
+ free_stream_buf(ps_out);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ } else {
+ lua_pushnil(L);
+ lua_pushstring(L,mplib_data->log_out);
+ xfree(mplib_data->ps_out);
+ return 2;
+ }
+ }
+ lua_pushnil(L);
+ return 1;
+}
+
+static int
+mplib_fig_filename (lua_State *L) {
+ struct mp_edge_object **hh = is_fig(L,1);
+ if (*hh!= NULL) {
+ char *s = (*hh)->_filename;
+ lua_pushstring(L,s);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+static int
+mplib_fig_bb (lua_State *L) {
+ struct mp_edge_object **hh = is_fig(L,1);
+ lua_newtable(L);
+ lua_pushnumber(L, (double)(*hh)->_minx/65536.0);
+ lua_rawseti(L,-2,1);
+ lua_pushnumber(L, (double)(*hh)->_miny/65536.0);
+ lua_rawseti(L,-2,2);
+ lua_pushnumber(L, (double)(*hh)->_maxx/65536.0);
+ lua_rawseti(L,-2,3);
+ lua_pushnumber(L, (double)(*hh)->_maxy/65536.0);
+ lua_rawseti(L,-2,4);
+ return 1;
+}
+
+/* object methods */
+
+static int
+mplib_gr_collect (lua_State *L) {
+ struct mp_graphic_object **hh = is_gr_object(L,1);
+ if (*hh!=NULL) {
+ mp_gr_toss_object(*hh);
+ *hh=NULL;
+ }
+ return 0;
+}
+
+static int
+mplib_gr_tostring (lua_State *L) {
+ struct mp_graphic_object **hh = is_gr_object(L,1);
+ lua_pushfstring(L,"<object %p>",*hh);
+ return 1;
+}
+
+
+static int
+mplib_gr_fields (lua_State *L) {
+ const char **fields;
+ const char *f;
+ int i = 1;
+ struct mp_graphic_object **hh = is_gr_object(L,1);
+ if (*hh) {
+ switch ((*hh)->_type_field) {
+ case mp_fill_code: fields = fill_fields; break;
+ case mp_stroked_code: fields = stroked_fields; break;
+ case mp_text_code: fields = text_fields; break;
+ case mp_special_code: fields = special_fields; break;
+ case mp_start_clip_code: fields = start_clip_fields; break;
+ case mp_start_bounds_code: fields = start_bounds_fields; break;
+ case mp_stop_clip_code: fields = stop_clip_fields; break;
+ case mp_stop_bounds_code: fields = stop_bounds_fields; break;
+ default: fields = no_fields;
+ }
+ lua_newtable(L);
+ for (f = *fields; f != NULL; f++) {
+ lua_pushstring(L,f);
+ lua_rawseti(L,-2,i); i++;
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+#define mplib_push_number(L,x) lua_pushnumber(L,(lua_Number)(x)/65536.0)
+
+#define MPLIB_PATH 0
+#define MPLIB_PEN 1
+
+static void
+mplib_push_path (lua_State *L, struct mp_knot *h, int is_pen) {
+ struct mp_knot *p; /* for scanning the path */
+ int i=1;
+ p=h;
+ if (p!=NULL) {
+ lua_newtable(L);
+ do {
+ lua_createtable(L,0,6);
+ if (!is_pen) {
+ if (p->left_type_field != mp_explicit) {
+ mplib_push_S(left_type);
+ lua_pushstring(L,knot_type_enum[p->left_type_field]);
+ lua_rawset(L,-3);
+ }
+ if (p->right_type_field != mp_explicit) {
+ mplib_push_S(right_type);
+ lua_pushstring(L,knot_type_enum[p->right_type_field]);
+ lua_rawset(L,-3);
+ }
+ }
+ mplib_push_S(x_coord);
+ mplib_push_number(L,p->x_coord_field);
+ lua_rawset(L,-3);
+ mplib_push_S(y_coord);
+ mplib_push_number(L,p->y_coord_field);
+ lua_rawset(L,-3);
+ mplib_push_S(left_x);
+ mplib_push_number(L,p->left_x_field);
+ lua_rawset(L,-3);
+ mplib_push_S(left_y);
+ mplib_push_number(L,p->left_y_field);
+ lua_rawset(L,-3);
+ mplib_push_S(right_x);
+ mplib_push_number(L,p->right_x_field);
+ lua_rawset(L,-3);
+ mplib_push_S(right_y);
+ mplib_push_number(L,p->right_y_field);
+ lua_rawset(L,-3);
+ lua_rawseti(L,-2,i); i++;
+ if ( p->right_type_field==mp_endpoint ) {
+ return;
+ }
+ p=p->next_field;
+ } while (p!=h) ;
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+#define set_color_objects(pq) \
+ object_color_model = pq->color_model_field; \
+ object_color_a = pq->color_field._a_val; \
+ object_color_b = pq->color_field._b_val; \
+ object_color_c = pq->color_field._c_val; \
+ object_color_d = pq->color_field._d_val;
+
+
+static void
+mplib_push_color (lua_State *L, struct mp_graphic_object *p ) {
+ int object_color_model;
+ int object_color_a, object_color_b, object_color_c, object_color_d ;
+ if (p!=NULL) {
+ if (p->_type_field == mp_fill_code) {
+ mp_fill_object *h = (mp_fill_object *)p;
+ set_color_objects(h);
+ } else if (p->_type_field == mp_stroked_code) {
+ mp_stroked_object *h = (mp_stroked_object *)p;
+ set_color_objects(h);
+ } else {
+ mp_text_object *h = (mp_text_object *)p;
+ set_color_objects(h);
+ }
+ lua_newtable(L);
+ if (object_color_model >= mp_grey_model) {
+ mplib_push_number(L,object_color_a);
+ lua_rawseti(L,-2,1);
+ if (object_color_model >= mp_rgb_model) {
+ mplib_push_number(L,object_color_b);
+ lua_rawseti(L,-2,2);
+ mplib_push_number(L,object_color_c);
+ lua_rawseti(L,-2,3);
+ if (object_color_model == mp_cmyk_model) {
+ mplib_push_number(L,object_color_d);
+ lua_rawseti(L,-2,4);
+ }
+ }
+ }
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+/* the dash scale is not exported, the field has no external value */
+static void
+mplib_push_dash (lua_State *L, struct mp_stroked_object *h ) {
+ mp_dash_object *d;
+ if (h!=NULL && h->dash_p_field != NULL) {
+ d = h->dash_p_field;
+ lua_newtable(L);
+ mplib_push_number(L,d->offset_field);
+ lua_setfield(L,-2,"offset");
+ if (d->array_field!=NULL ) {
+ int i = 0;
+ lua_newtable(L);
+ while (*(d->array_field+i) != -1) {
+ mplib_push_number(L, *(d->array_field+1));
+ i++;
+ lua_rawseti(L,-2,i);
+ }
+ lua_setfield(L,-2,"dashes");
+ }
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void
+mplib_push_transform (lua_State *L, struct mp_text_object *h ) {
+ int i = 1;
+ if (h!=NULL) {
+ lua_createtable(L,6,0);
+ mplib_push_number(L,h->tx_field);
+ lua_rawseti(L,-2,i); i++;
+ mplib_push_number(L,h->ty_field);
+ lua_rawseti(L,-2,i); i++;
+ mplib_push_number(L,h->txx_field);
+ lua_rawseti(L,-2,i); i++;
+ mplib_push_number(L,h->tyx_field);
+ lua_rawseti(L,-2,i); i++;
+ mplib_push_number(L,h->txy_field);
+ lua_rawseti(L,-2,i); i++;
+ mplib_push_number(L,h->tyy_field);
+ lua_rawseti(L,-2,i); i++;
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+#define FIELD(A) (mplib_is_S(A,2))
+
+static void
+mplib_fill_field (lua_State *L, struct mp_fill_object *h) {
+ if (FIELD(path)) {
+ mplib_push_path(L, h->path_p_field, MPLIB_PATH);
+ } else if (FIELD(htap)) {
+ mplib_push_path(L, h->htap_p_field, MPLIB_PATH);
+ } else if (FIELD(pen)) {
+ mplib_push_path(L, h->pen_p_field, MPLIB_PEN);
+ } else if (FIELD(color)) {
+ mplib_push_color(L,(mp_graphic_object *)h);
+ } else if (FIELD(linejoin)) {
+ lua_pushnumber(L,h->ljoin_field);
+ } else if (FIELD(miterlimit)) {
+ mplib_push_number(L,h->miterlim_field);
+ } else if (FIELD(prescript)) {
+ lua_pushstring(L,h->pre_script_field);
+ } else if (FIELD(postscript)) {
+ lua_pushstring(L,h->post_script_field);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void
+mplib_stroked_field (lua_State *L, struct mp_stroked_object *h) {
+ if (FIELD(path)) {
+ mplib_push_path(L, h->path_p_field, MPLIB_PATH);
+ } else if (FIELD(pen)) {
+ mplib_push_path(L, h->pen_p_field, MPLIB_PEN);
+ } else if (FIELD(color)) {
+ mplib_push_color(L, (mp_graphic_object *)h);
+ } else if (FIELD(dash)) {
+ mplib_push_dash(L,h);
+ } else if (FIELD(linecap)) {
+ lua_pushnumber(L,h->lcap_field);
+ } else if (FIELD(linejoin)) {
+ lua_pushnumber(L,h->ljoin_field);
+ } else if (FIELD(miterlimit)) {
+ mplib_push_number(L,h->miterlim_field);
+ } else if (FIELD(prescript)) {
+ lua_pushstring(L,h->pre_script_field);
+ } else if (FIELD(postscript)) {
+ lua_pushstring(L,h->post_script_field);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void
+mplib_text_field (lua_State *L, struct mp_text_object *h) {
+ if (FIELD(text)) {
+ lua_pushstring(L,h->text_p_field);
+ } else if (FIELD(dsize)) {
+ mplib_push_number(L,(h->font_dsize_field/16));
+ } else if (FIELD(font)) {
+ lua_pushstring(L,h->font_name_field);
+ } else if (FIELD(color)) {
+ mplib_push_color(L,(mp_graphic_object *)h);
+ } else if (FIELD(width)) {
+ mplib_push_number(L,h->width_field);
+ } else if (FIELD(height)) {
+ mplib_push_number(L,h->height_field);
+ } else if (FIELD(depth)) {
+ mplib_push_number(L,h->depth_field);
+ } else if (FIELD(transform)) {
+ mplib_push_transform(L,h);
+ } else if (FIELD(prescript)) {
+ lua_pushstring(L,h->pre_script_field);
+ } else if (FIELD(postscript)) {
+ lua_pushstring(L,h->post_script_field);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void
+mplib_special_field (lua_State *L, struct mp_special_object *h) {
+ if (FIELD(prescript)) {
+ lua_pushstring(L,h->pre_script_field);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void
+mplib_start_bounds_field (lua_State *L, struct mp_bounds_object *h) {
+ if (FIELD(path)) {
+ mplib_push_path(L,h->path_p_field, MPLIB_PATH);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void
+mplib_start_clip_field (lua_State *L, struct mp_clip_object *h) {
+ if (FIELD(path)) {
+ mplib_push_path(L,h->path_p_field, MPLIB_PATH);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static int
+mplib_gr_index (lua_State *L) {
+ struct mp_graphic_object **hh = is_gr_object(L,1);
+ if (*hh) {
+ struct mp_graphic_object *h = *hh;
+ if (mplib_is_S(type,2)) {
+ lua_rawgeti(L,LUA_REGISTRYINDEX,mplib_type_Ses[h->_type_field]);
+ } else {
+ switch (h->_type_field) {
+ case mp_fill_code: mplib_fill_field(L,(mp_fill_object *)h); break;
+ case mp_stroked_code: mplib_stroked_field(L,(mp_stroked_object *)h); break;
+ case mp_text_code: mplib_text_field(L,(mp_text_object *)h); break;
+ case mp_special_code: mplib_special_field(L,(mp_special_object *)h); break;
+ case mp_start_clip_code: mplib_start_clip_field(L,(mp_clip_object *)h); break;
+ case mp_start_bounds_code: mplib_start_bounds_field(L,(mp_bounds_object *)h); break;
+ /* case mp_stop_clip_code: */
+ /* case mp_stop_bounds_code: */
+ default: lua_pushnil(L);
+ }
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+static const struct luaL_reg mplib_meta[] = {
+ {"__gc", mplib_collect},
+ {"__tostring", mplib_tostring},
+ {NULL, NULL} /* sentinel */
+};
+
+static const struct luaL_reg mplib_fig_meta[] = {
+ {"__gc", mplib_fig_collect },
+ {"__tostring", mplib_fig_tostring },
+ {"objects", mplib_fig_body },
+ {"copy_objects", mplib_fig_copy_body },
+ {"filename", mplib_fig_filename },
+ {"postscript", mplib_fig_postscript },
+ {"boundingbox", mplib_fig_bb },
+ {NULL, NULL} /* sentinel */
+};
+
+static const struct luaL_reg mplib_gr_meta[] = {
+ {"__gc", mplib_gr_collect },
+ {"__tostring", mplib_gr_tostring },
+ {"__index", mplib_gr_index },
+ {"fields", mplib_gr_fields },
+ {NULL, NULL} /* sentinel */
+};
+
+
+static const struct luaL_reg mplib_d [] = {
+ {"execute", mplib_execute },
+ {"finish", mplib_finish },
+ {"statistics", mplib_statistics },
+ {NULL, NULL} /* sentinel */
+};
+
+
+static const struct luaL_reg mplib_m[] = {
+ {"new", mplib_new},
+ {NULL, NULL} /* sentinel */
+};
+
+
+int
+luaopen_mp (lua_State *L) {
+ mplib_init_Ses(L);
+ luaL_newmetatable(L,MPLIB_GR_METATABLE);
+ lua_pushvalue(L, -1); /* push metatable */
+ lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
+ luaL_register(L, NULL, mplib_gr_meta); /* object meta methods */
+ lua_pop(L,1);
+
+ luaL_newmetatable(L,MPLIB_FIG_METATABLE);
+ lua_pushvalue(L, -1); /* push metatable */
+ lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
+ luaL_register(L, NULL, mplib_fig_meta); /* figure meta methods */
+ lua_pop(L,1);
+
+ luaL_newmetatable(L,MPLIB_METATABLE);
+ lua_pushvalue(L, -1); /* push metatable */
+ lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
+ luaL_register(L, NULL, mplib_meta); /* meta methods */
+ luaL_register(L, NULL, mplib_d); /* dict methods */
+ luaL_register(L, "mplib", mplib_m); /* module functions */
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/lnodelib.c b/Build/source/texk/web2c/luatexdir/lua/lnodelib.c
new file mode 100644
index 00000000000..de269d5d9c8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lnodelib.c
@@ -0,0 +1,1967 @@
+/* $Id: lnodelib.c 1056 2008-02-19 15:42:17Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include "nodes.h"
+
+#define init_luaS_index(a) do { \
+ lua_pushliteral(L,#a); \
+ luaS_##a##_ptr = (char *)lua_tostring(L,-1); \
+ luaS_##a##_index = luaL_ref (L,LUA_REGISTRYINDEX); \
+ } while (0)
+
+#define make_luaS_index(a) \
+ static int luaS_##a##_index = 0; \
+ static char * luaS_##a##_ptr = NULL
+
+#define luaS_index(a) luaS_##a##_index
+
+#define luaS_ptr_eq(a,b) (a==luaS_##b##_ptr)
+
+#define NODE_METATABLE "luatex_node"
+
+make_luaS_index(luatex_node);
+
+halfword *check_isnode (lua_State *L, int ud) {
+ register halfword *p = lua_touserdata(L, ud);
+ if (p != NULL) {
+ if (lua_getmetatable(L, ud)) {
+ lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(luatex_node));
+ lua_gettable(L, LUA_REGISTRYINDEX);
+ if (lua_rawequal(L, -1, -2)) {
+ lua_pop(L, 2);
+ return p;
+ }
+ }
+ }
+ luaL_typerror(L, ud, NODE_METATABLE);
+ return NULL;
+}
+
+/* This routine finds the numerical value of a string (or number) at
+ lua stack index |n|. If it is not a valid node type, returns -1 */
+
+static
+int do_get_node_type_id (lua_State *L, int n, node_info *data) {
+ register int j;
+ if (lua_type(L,n)==LUA_TSTRING) {
+ char *s = (char *)lua_tostring(L,n);
+ for (j=0;data[j].id!=-1;j++) {
+ if (strcmp(s,data[j].name)==0)
+ return j;
+ }
+ } else if (lua_type(L,n)==LUA_TNUMBER) {
+ register int i = lua_tointeger(L,n);
+ if (data[i].id==i)
+ return i;
+ for (j=0;data[j].id!=-1;j++) {
+ if (data[j].id==i)
+ return j;
+ }
+ }
+ return -1;
+}
+
+#define get_node_type_id(L,n) do_get_node_type_id(L,n,node_data)
+#define get_node_subtype_id(L,n) do_get_node_type_id(L,n,whatsit_node_data)
+
+static
+int get_valid_node_type_id (lua_State *L, int n) {
+ int i = get_node_type_id(L,n);
+ if (i==-1) {
+ if (lua_type(L,n)==LUA_TSTRING) {
+ lua_pushfstring(L, "Invalid node type id: %s",(char *)lua_tostring(L,n));
+ } else {
+ lua_pushfstring(L, "Invalid node type id: %d",(int)lua_tonumber(L,n));
+ }
+ return lua_error(L);
+ }
+ return i;
+}
+
+static
+int get_valid_node_subtype_id (lua_State *L, int n) {
+ int i = get_node_subtype_id(L,n);
+ if (i==-1) {
+ if (lua_type(L,n)==LUA_TSTRING) {
+ lua_pushfstring(L, "Invalid whatsit node id: %s",(char *)lua_tostring(L,n));
+ } else {
+ lua_pushfstring(L, "Invalid whatsit node id: %d",(int)lua_tonumber(L,n));
+ }
+ return lua_error(L);
+ }
+ return i;
+}
+
+
+
+/* Creates a userdata object for a number found at the stack top,
+ if it is representing a node (i.e. an pointer into |varmem|).
+ It replaces the stack entry with the new userdata, or pushes
+ |nil| if the number is |null|, or if the index is definately out of
+ range. This test could be improved.
+*/
+
+void
+lua_nodelib_push(lua_State *L) {
+ halfword n;
+ halfword *a;
+ n = -1;
+ if (lua_isnumber(L,-1)) {
+ n = lua_tointeger(L,-1);
+ }
+ lua_pop(L,1);
+ if ((n==null) || (n<0) || (n>var_mem_max)) {
+ lua_pushnil(L);
+ } else {
+ a = lua_newuserdata(L, sizeof(halfword));
+ *a = n;
+ lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(luatex_node));
+ lua_gettable(L, LUA_REGISTRYINDEX);
+ lua_setmetatable(L,-2);
+ }
+ return;
+}
+
+void
+lua_nodelib_push_fast(lua_State *L, halfword n) {
+ halfword *a;
+ a = lua_newuserdata(L, sizeof(halfword));
+ *a = n;
+ lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(luatex_node));
+ lua_gettable(L, LUA_REGISTRYINDEX);
+ lua_setmetatable(L,-2);
+ return;
+}
+
+
+/* converts type strings to type ids */
+
+static int
+lua_nodelib_id (lua_State *L) {
+ integer i = get_node_type_id(L,1);
+ if (i>=0) {
+ lua_pushnumber(L,i);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+static int
+lua_nodelib_subtype (lua_State *L) {
+ integer i = get_node_subtype_id(L,1);
+ if (i>=0) {
+ lua_pushnumber(L,i);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+/* converts id numbers to type names */
+
+static int
+lua_nodelib_type (lua_State *L) {
+ integer i = get_node_type_id(L,1);
+ if (i>=0) {
+ lua_pushstring(L,node_data[i].name);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+/* allocate a new node */
+
+static int
+lua_nodelib_new(lua_State *L) {
+ int i,j;
+ halfword n = null;
+ i = get_valid_node_type_id(L,1);
+
+ if (i==whatsit_node) {
+ j = -1;
+ if (lua_gettop(L)>1) { j = get_valid_node_subtype_id(L,2); }
+ if (j<0) {
+ lua_pushstring(L, "Creating a whatsit requires the subtype number as a second argument");
+ lua_error(L);
+ }
+ } else {
+ j = 0;
+ if (lua_gettop(L)>1) { j = lua_tointeger(L,2); }
+ }
+ n = new_node(i,j);
+ lua_nodelib_push_fast(L,n);
+ return 1;
+}
+
+
+/* Free a node.
+ This function returns the 'next' node, because that may be helpful */
+
+static int
+lua_nodelib_free(lua_State *L) {
+ halfword *n;
+ halfword p;
+ if (lua_gettop(L)<1) {
+ lua_pushnil(L);
+ return 1;
+ } else if(lua_isnil(L,1)) {
+ return 1; /* the nil itself */
+ }
+ n = check_isnode(L,1);
+ p = vlink(*n);
+ flush_node(*n);
+ lua_pushnumber(L,p);
+ lua_nodelib_push(L);
+ return 1;
+}
+
+/* Free a node list */
+
+static int
+lua_nodelib_flush_list(lua_State *L) {
+ halfword *n_ptr;
+ if ((lua_gettop(L)<1) || lua_isnil(L,1))
+ return 0;
+ n_ptr = check_isnode(L,1);
+ flush_node_list(*n_ptr);
+ return 0;
+}
+
+/* find prev, and fix backlinks */
+
+#define set_t_to_prev(head,current) \
+ t = head; \
+ while (vlink(t)!=current && t != null) { \
+ if (vlink(t)!=null) \
+ alink(vlink(t)) = t; \
+ t = vlink(t); \
+ }
+
+/* remove a node from a list */
+
+
+static int
+lua_nodelib_remove (lua_State *L) {
+ halfword head, current, t;
+ if (lua_gettop(L)<2) {
+ lua_pushstring(L,"Not enough arguments for node.remove()");
+ lua_error(L);
+ }
+ head = *(check_isnode(L,1));
+ if (lua_isnil(L,2)) {
+ return 2; /* the arguments, as they are */
+ }
+ current = *(check_isnode(L,2));
+
+ if (head == current) {
+ if (alink(head)!=null && vlink(current)!=null) {
+ alink(vlink(current)) = alink(head);
+ }
+ head = vlink(current);
+ current = head;
+ } else { /* head != current */
+ t = alink(current);
+ if (t==null || vlink(t)!=current) {
+ set_t_to_prev(head,current);
+ if (t==null) { /* error! */
+ lua_pushstring(L,"Attempt to node.remove() a non-existing node");
+ lua_error(L);
+ }
+ }
+ /* t is now the previous node */
+ vlink(t) = vlink(current);
+ if (vlink(current)!=null) {
+ alink(vlink(current)) = t;
+ }
+ current = vlink(current);
+ }
+ lua_pushnumber(L,head);
+ lua_nodelib_push(L);
+ lua_pushnumber(L,current);
+ lua_nodelib_push(L);
+ return 2;
+}
+
+/* Insert a node in a list */
+
+static int
+lua_nodelib_insert_before (lua_State *L) {
+ halfword head, current, n, t;
+ if (lua_gettop(L)<3) {
+ lua_pushstring(L,"Not enough arguments for node.insert_before()");
+ lua_error(L);
+ }
+ if (lua_isnil(L,3)) {
+ lua_pop(L,1);
+ return 2;
+ } else {
+ n = *(check_isnode(L,3));
+ }
+ if (lua_isnil(L,1)) { /* no head */
+ vlink(n) = null;
+ alink(n) = null;
+ lua_nodelib_push_fast(L,n);
+ lua_pushvalue(L,-1);
+ return 2;
+ } else {
+ head = *(check_isnode(L,1));
+ }
+ if (lua_isnil(L,2)) {
+ current = tail_of_list(head);
+ } else {
+ current = *(check_isnode(L,2));
+ }
+ t = alink(current);
+ if (t==null || vlink(t)!=current) {
+ set_t_to_prev(head,current);
+ if (t==null) { /* error! */
+ lua_pushstring(L,"Attempt to node.insert_before() a non-existing node");
+ lua_error(L);
+ }
+ }
+ couple_nodes(t,n);
+ couple_nodes(n,current);
+ if (head==current) {
+ lua_nodelib_push_fast(L,n);
+ } else {
+ lua_nodelib_push_fast(L,head);
+ }
+ lua_nodelib_push_fast(L,n);
+ return 2;
+}
+
+
+static int
+lua_nodelib_insert_after (lua_State *L) {
+ halfword head, current, n;
+ if (lua_gettop(L)<3) {
+ lua_pushstring(L,"Not enough arguments for node.insert_after()");
+ lua_error(L);
+ }
+ if (lua_isnil(L,3)) {
+ lua_pop(L,1);
+ return 2;
+ } else {
+ n = *(check_isnode(L,3));
+ }
+ if (lua_isnil(L,1)) { /* no head */
+ vlink(n) = null;
+ alink(n) = null;
+ lua_nodelib_push_fast(L,n);
+ lua_pushvalue(L,-1);
+ return 2;
+ } else {
+ head = *(check_isnode(L,1));
+ }
+ if (lua_isnil(L,2)) {
+ current = head;
+ while (vlink(current)!=null)
+ current = vlink(current);
+ } else {
+ current = *(check_isnode(L,2));
+ }
+ try_couple_nodes(n,vlink(current));
+ couple_nodes(current, n);
+
+ lua_pop(L,2);
+ lua_nodelib_push_fast(L,n);
+ return 2;
+}
+
+
+/* Copy a node list */
+
+static int
+lua_nodelib_copy_list (lua_State *L) {
+ halfword *n;
+ halfword m;
+ if (lua_isnil(L,1))
+ return 1; /* the nil itself */
+ n = check_isnode(L,1);
+ m = copy_node_list(*n);
+ lua_nodelib_push_fast(L,m);
+ return 1;
+}
+
+/* (Deep) copy a node */
+
+static int
+lua_nodelib_copy(lua_State *L) {
+ halfword *n;
+ halfword m;
+ if (lua_isnil(L,1))
+ return 1; /* the nil itself */
+ n = check_isnode(L,1);
+ m = copy_node(*n);
+ lua_nodelib_push_fast(L,m);
+ return 1;
+}
+
+/* output (write) a node to tex's processor */
+
+static int
+lua_nodelib_append(lua_State *L) {
+ halfword *n;
+ halfword m;
+ int i, j;
+ j = lua_gettop(L);
+ for (i=1;i<=j;i++) {
+ n = check_isnode(L,i);
+ m = copy_node_list(*n);
+ new_tail_append(m);
+ while (vlink(m)!= null) {
+ m = vlink(m);
+ new_tail_append(m);
+ }
+ }
+ return 0;
+}
+
+static int
+lua_nodelib_last_node(lua_State *L) {
+ halfword m;
+ m = pop_tail();
+ lua_pushnumber(L,m);
+ lua_nodelib_push(L);
+ return 1;
+}
+
+
+
+/* build a hbox */
+
+static int
+lua_nodelib_hpack(lua_State *L) {
+ halfword n, p;
+ char *s;
+ integer w = 0;
+ int m = 1;
+ n = *(check_isnode(L,1));
+ if (lua_gettop(L)>1) {
+ w = lua_tointeger(L,2);
+ if (lua_gettop(L)>2 && lua_type(L,3)==LUA_TSTRING) {
+ s = (char *)lua_tostring(L,3);
+ if (strcmp(s,"additional")==0) {
+ m = 1;
+ } else {
+ m = lua_tonumber(L,3);
+ }
+ }
+ }
+ p = hpack(n,w,m);
+ lua_nodelib_push_fast(L,p);
+ return 1;
+}
+
+/* This function is similar to |get_node_type_id|, for field
+ identifiers. It has to do some more work, because not all
+ identifiers are valid for all types of nodes.
+*/
+
+/* this inlining is an optimisation trick. it would be even faster to
+ compare string pointers on the lua stack, but that would require a
+ lot of code reworking that I don't have time for right now.
+*/
+
+
+make_luaS_index(id);
+make_luaS_index(next);
+make_luaS_index(char);
+make_luaS_index(font);
+make_luaS_index(attr);
+make_luaS_index(prev);
+make_luaS_index(lang);
+make_luaS_index(subtype);
+make_luaS_index(left);
+make_luaS_index(right);
+make_luaS_index(uchyph);
+make_luaS_index(components);
+make_luaS_index(xoffset);
+make_luaS_index(yoffset);
+
+
+void initialize_luaS_indexes(lua_State *L) {
+ init_luaS_index(id);
+ init_luaS_index(next);
+ init_luaS_index(char);
+ init_luaS_index(font);
+ init_luaS_index(attr);
+ init_luaS_index(prev);
+ init_luaS_index(lang);
+ init_luaS_index(subtype);
+ init_luaS_index(left);
+ init_luaS_index(right);
+ init_luaS_index(uchyph);
+ init_luaS_index(components);
+ init_luaS_index(xoffset);
+ init_luaS_index(yoffset);
+}
+
+static int
+get_node_field_id (lua_State *L, int n, int node ) {
+ register int t = type(node);
+ register char *s = (char *)lua_tostring(L,n);
+ if (luaS_ptr_eq(s,next)) { return 0; }
+ else if (luaS_ptr_eq(s,id)) { return 1; }
+ else if (luaS_ptr_eq(s,attr) &&
+ nodetype_has_attributes(t)) { return 3 ; }
+ else if (t==glyph_node) {
+ if (luaS_ptr_eq(s,subtype)) { return 2; }
+ else if (luaS_ptr_eq(s,font)) { return 5; }
+ else if (luaS_ptr_eq(s,char)) { return 4; }
+ else if (luaS_ptr_eq(s,prev)) { return -1; }
+ else if (luaS_ptr_eq(s,lang)) { return 6; }
+ else if (luaS_ptr_eq(s,left)) { return 7; }
+ else if (luaS_ptr_eq(s,right)) { return 8; }
+ else if (luaS_ptr_eq(s,uchyph)) { return 9; }
+ else if (luaS_ptr_eq(s,components)) { return 10; }
+ else if (luaS_ptr_eq(s,xoffset)) { return 11; }
+ else if (luaS_ptr_eq(s,yoffset)) { return 12; }
+ }
+ else if (luaS_ptr_eq(s,prev)) { return -1; }
+ else if (luaS_ptr_eq(s,subtype)) { return 2; }
+ else {
+ int j;
+ char **fields = node_data[t].fields;
+ if (t==whatsit_node)
+ fields = whatsit_node_data[subtype(node)].fields;
+ for (j=0;fields[j]!=NULL;j++) {
+ if (strcmp(s,fields[j])==0) {
+ return j+3;
+ }
+ }
+ }
+ return -2;
+}
+
+
+static int
+get_valid_node_field_id (lua_State *L, int n, int node ) {
+ int i = get_node_field_id(L,n,node);
+ if (i==-2) {
+ char *s = (char *)lua_tostring(L,n);
+ lua_pushfstring(L, "Invalid field id %s for node type %s (%d)" , s, node_data[type(node)].name,subtype(node));
+ lua_error(L);
+ }
+ return i;
+}
+
+static int
+lua_nodelib_has_field (lua_State *L) {
+ int i= -2;
+ if (!lua_isnil(L,1)) {
+ i = get_node_field_id(L,2,*(check_isnode(L,1)));
+ }
+ lua_pushboolean(L,(i!=-2));
+ return 1;
+}
+
+
+/* fetch the list of valid node types */
+
+static int
+do_lua_nodelib_types (lua_State *L, node_info *data) {
+ int i;
+ lua_newtable(L);
+ for (i=0;data[i].id!=-1;i++) {
+ lua_pushstring(L,data[i].name);
+ lua_rawseti(L,-2,data[i].id);
+ }
+ return 1;
+}
+
+static int
+lua_nodelib_types (lua_State *L) {
+ return do_lua_nodelib_types (L, node_data);
+}
+
+static int
+lua_nodelib_whatsits (lua_State *L) {
+ return do_lua_nodelib_types (L, whatsit_node_data);
+}
+
+
+/* fetch the list of valid fields */
+
+static int
+lua_nodelib_fields (lua_State *L) {
+ int i = -1;
+ char ** fields;
+ int t = get_valid_node_type_id(L,1);
+ if (t==whatsit_node ) {
+ t = get_valid_node_subtype_id(L,2);
+ fields = whatsit_node_data[t].fields;
+ } else {
+ fields = node_data[t].fields;
+ }
+ lua_checkstack(L,2);
+ lua_newtable(L);
+ lua_pushstring(L,"next");
+ lua_rawseti(L,-2,0);
+ lua_pushstring(L,"id");
+ lua_rawseti(L,-2,1);
+ lua_pushstring(L,"subtype");
+ lua_rawseti(L,-2,2);
+ if (fields!=NULL) {
+ lua_pushstring(L,"prev");
+ lua_rawseti(L,-2,-1);
+ for (i=0;fields[i]!=NULL;i++) {
+ lua_pushstring(L,fields[i]);
+ lua_rawseti(L,-2,(i+3));
+ }
+ }
+ return 1;
+}
+
+/* find the end of a list */
+
+static int
+lua_nodelib_tail (lua_State *L) {
+ halfword *n;
+ halfword t;
+ if (lua_isnil(L,1))
+ return 1; /* the nil itself */
+ n = check_isnode(L,1);
+ t=*n;
+ if (t==null)
+ return 1; /* the old userdata */
+ alink(t) = null;
+ while (vlink(t)!=null) {
+ alink(vlink(t)) = t;
+ t = vlink(t);
+ }
+ lua_nodelib_push_fast(L,t);
+ return 1;
+}
+
+/* a few utility functions for attribute stuff */
+
+static int
+lua_nodelib_has_attribute (lua_State *L) {
+ halfword *n;
+ int i, val ;
+ if (lua_isnil(L,1))
+ return 1; /* the nil itself */
+ n = check_isnode(L,1);
+ i = lua_tointeger(L,2);
+ val = luaL_optinteger(L,3,-1);
+ if((val = has_attribute(*n,i,val))>=0) {
+ lua_pushnumber(L,val);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int
+lua_nodelib_set_attribute (lua_State *L) {
+ halfword *n;
+ int i, val;
+ if (lua_gettop(L)==3) {
+ i = lua_tointeger(L,2);
+ val = lua_tointeger(L,3);
+ n = check_isnode(L,1);
+ if (val<0) {
+ (void)unset_attribute(*n,i,val);
+ } else {
+ set_attribute(*n,i,val);
+ }
+ } else {
+ lua_pushstring(L,"incorrect number of arguments");
+ lua_error(L);
+ }
+ return 0;
+}
+
+
+static int
+lua_nodelib_unset_attribute (lua_State *L) {
+ halfword *n;
+ int i, val, ret;
+ if (lua_gettop(L)<=3) {
+ i = luaL_checknumber(L,2);
+ val = luaL_optnumber(L,3,-1);
+ n = check_isnode(L,1);
+ ret = unset_attribute(*n,i,val);
+ if(ret>=0) {
+ lua_pushnumber(L,ret);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ } else {
+ lua_pushstring(L,"incorrect number of arguments");
+ return lua_error(L);
+ }
+}
+
+
+/* iteration */
+
+static int nodelib_aux_nil (lua_State *L) {
+ lua_pushnil(L);
+ return 1;
+}
+
+static int
+nodelib_aux_next_filtered (lua_State *L) {
+ register halfword t; /* traverser */
+ register int i = lua_tointeger(L,lua_upvalueindex(1));
+ if (lua_isnil(L,2)) { /* first call */
+ t = *check_isnode(L,1);
+ } else {
+ t = *check_isnode(L,2);
+ t = vlink(t);
+ }
+ while (t!=null && type(t)!=i) { t = vlink(t); }
+ if (t==null) {
+ lua_pushnil(L);
+ } else {
+ lua_nodelib_push_fast(L,t);
+ }
+ return 1;
+}
+
+
+static int
+lua_nodelib_traverse_filtered (lua_State *L) {
+ halfword n;
+ if (lua_isnil(L,2)) {
+ lua_pushcclosure(L, nodelib_aux_nil, 0);
+ return 1;
+ }
+ n = *(check_isnode(L,2));
+ lua_pop(L,1); /* the node, integer remains */
+ lua_pushcclosure(L, nodelib_aux_next_filtered, 1);
+ lua_nodelib_push_fast(L,n);
+ lua_pushnil(L);
+ return 3;
+}
+
+static int
+nodelib_aux_next (lua_State *L) {
+ register halfword t; /* traverser */
+ if (lua_isnil(L,2)) { /* first call */
+ t = *check_isnode(L,1);
+ } else {
+ t = *check_isnode(L,2);
+ t = vlink(t);
+ }
+ if (t==null) {
+ lua_pushnil(L);
+ } else {
+ lua_nodelib_push_fast(L,t);
+ }
+ return 1;
+}
+
+static int
+lua_nodelib_traverse (lua_State *L) {
+ halfword n;
+ if (lua_isnil(L,1)) {
+ lua_pushcclosure(L, nodelib_aux_nil, 0);
+ return 1;
+ }
+ n = *(check_isnode(L,1));
+ lua_pushcclosure(L, nodelib_aux_next, 0);
+ lua_nodelib_push_fast(L,n);
+ lua_pushnil(L);
+ return 3;
+;
+}
+
+
+
+static int
+do_lua_nodelib_count (lua_State *L, halfword match, int i, halfword first) {
+ int count = 0;
+ int t = first;
+ while (t!=match) {
+ if (i<0 || type(t)==i) { count++; }
+ t = vlink(t);
+ }
+ lua_pushnumber(L,count);
+ return 1;
+}
+
+static int lua_nodelib_length (lua_State *L) {
+ halfword n;
+ halfword m = null;
+ if (lua_isnil(L,1)) {
+ lua_pushnumber(L,0);
+ return 1;
+ }
+ n = *(check_isnode(L,1));
+ if (lua_gettop(L)==2) {
+ m = *(check_isnode(L,2));
+ }
+ return do_lua_nodelib_count(L,m,-1,n);
+}
+
+
+static int lua_nodelib_count (lua_State *L) {
+ halfword n;
+ halfword m = null;
+ int i = -1;
+ i = lua_tointeger(L,1);
+ if (lua_isnil(L,2)) {
+ lua_pushnumber(L,0);
+ return 1;
+ }
+ n = *(check_isnode(L,2));
+ if (lua_gettop(L)==3)
+ m = *(check_isnode(L,3));
+ return do_lua_nodelib_count(L,m,i,n);
+}
+
+/* fetching a field from a node */
+
+#define nodelib_pushlist(L,n) { lua_pushnumber(L,n); lua_nodelib_push(L); }
+#define nodelib_pushattr(L,n) { lua_pushnumber(L,n); lua_nodelib_push(L); }
+#define nodelib_pushspec(L,n) { lua_pushnumber(L,n); lua_nodelib_push(L); }
+#define nodelib_pushaction(L,n) { lua_pushnumber(L,n); lua_nodelib_push(L); }
+#define nodelib_pushstring(L,n) { lua_pushstring(L,makecstring(n)); }
+
+static void
+lua_nodelib_getfield_whatsit (lua_State *L, int n, int field) {
+ if (field==2) {
+ lua_pushnumber(L,subtype(n));
+ } else {
+ switch (subtype(n)) {
+ case open_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,write_stream(n)); break;
+ case 5: nodelib_pushstring(L,open_name(n)); break;
+ case 6: nodelib_pushstring(L,open_area(n)); break;
+ case 7: nodelib_pushstring(L,open_ext(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case write_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,write_stream(n)); break;
+ case 5: tokenlist_to_lua(L,write_tokens(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case close_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,write_stream(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case special_node:
+ switch (field) {
+ case 4: tokenlist_to_luastring(L,write_tokens(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case local_par_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,local_pen_inter(n)); break;
+ case 5: lua_pushnumber(L,local_pen_broken(n)); break;
+ case 6: lua_pushnumber(L,local_par_dir(n)); break;
+ case 7: nodelib_pushlist(L,local_box_left(n)); break;
+ case 8: lua_pushnumber(L,local_box_left_width(n)); break;
+ case 9: nodelib_pushlist(L,local_box_right(n)); break;
+ case 10: lua_pushnumber(L,local_box_right_width(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case dir_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,dir_dir(n)); break;
+ case 5: lua_pushnumber(L,dir_level(n)); break;
+ case 6: lua_pushnumber(L,dir_dvi_ptr(n)); break;
+ case 7: lua_pushnumber(L,dir_dvi_h(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_literal_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_literal_mode(n)); break;
+ case 5: tokenlist_to_luastring(L,pdf_literal_data(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_refobj_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_obj_objnum(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_refxform_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_width(n)); break;
+ case 5: lua_pushnumber(L,pdf_height(n)); break;
+ case 6: lua_pushnumber(L,pdf_depth(n)); break;
+ case 7: lua_pushnumber(L,pdf_xform_objnum(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_refximage_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_width(n)); break;
+ case 5: lua_pushnumber(L,pdf_height(n)); break;
+ case 6: lua_pushnumber(L,pdf_depth(n)); break;
+ case 7: lua_pushnumber(L,pdf_ximage_objnum(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_annot_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_width(n)); break;
+ case 5: lua_pushnumber(L,pdf_height(n)); break;
+ case 6: lua_pushnumber(L,pdf_depth(n)); break;
+ case 7: lua_pushnumber(L,pdf_annot_objnum(n)); break;
+ case 8: tokenlist_to_luastring(L,pdf_annot_data(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_start_link_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_width(n)); break;
+ case 5: lua_pushnumber(L,pdf_height(n)); break;
+ case 6: lua_pushnumber(L,pdf_depth(n)); break;
+ case 7: lua_pushnumber(L,pdf_link_objnum(n)); break;
+ case 8: tokenlist_to_luastring(L,pdf_link_attr(n)); break;
+ case 9: nodelib_pushaction(L,pdf_link_action(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_dest_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_width(n)); break;
+ case 5: lua_pushnumber(L,pdf_height(n)); break;
+ case 6: lua_pushnumber(L,pdf_depth(n)); break;
+ case 7: lua_pushnumber(L,pdf_dest_named_id(n)); break;
+ case 8: if (pdf_dest_named_id(n) == 1)
+ tokenlist_to_luastring(L,pdf_dest_id(n));
+ else
+ lua_pushnumber(L,pdf_dest_id(n)); break;
+ case 9: lua_pushnumber(L,pdf_dest_type(n)); break;
+ case 10: lua_pushnumber(L,pdf_dest_xyz_zoom(n)); break;
+ case 11: lua_pushnumber(L,pdf_dest_objnum(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_width(n)); break;
+ case 5: lua_pushnumber(L,pdf_height(n)); break;
+ case 6: lua_pushnumber(L,pdf_depth(n)); break;
+ case 7: lua_pushnumber(L,pdf_thread_named_id(n)); break;
+ case 8: if (pdf_thread_named_id(n) == 1)
+ tokenlist_to_luastring(L,pdf_thread_id(n));
+ else
+ lua_pushnumber(L,pdf_thread_id(n)); break;
+ case 9: tokenlist_to_luastring(L,pdf_thread_attr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case late_lua_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,late_lua_reg(n)); break;
+ case 5: tokenlist_to_luastring(L,late_lua_data(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case close_lua_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,late_lua_reg(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_colorstack_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,pdf_colorstack_stack(n)); break;
+ case 5: lua_pushnumber(L,pdf_colorstack_cmd(n)); break;
+ case 6: tokenlist_to_luastring(L,pdf_colorstack_data(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case pdf_setmatrix_node:
+ switch (field) {
+ case 4: tokenlist_to_luastring(L,pdf_setmatrix_data(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case user_defined_node:
+ switch (field) {
+ case 4: lua_pushnumber(L,user_node_id(n)); break;
+ case 5: lua_pushnumber(L,user_node_type(n)); break;
+ case 6:
+ switch (user_node_type(n)) {
+ case 'a': nodelib_pushlist(L,user_node_value(n)); break;
+ case 'd': lua_pushnumber(L,user_node_value(n)); break;
+ case 'n': nodelib_pushlist(L,user_node_value(n)); break;
+ case 's': nodelib_pushstring(L,user_node_value(n)); break;
+ case 't': tokenlist_to_lua(L,user_node_value(n)); break;
+ default: lua_pushnumber(L,user_node_value(n)); break;
+ } break;
+ default: lua_pushnil(L);
+ }
+ break;
+ default:
+ lua_pushnil(L);
+ break;
+ }
+ }
+}
+
+
+static int
+lua_nodelib_getfield (lua_State *L) {
+ halfword *n_ptr, n;
+ int field;
+ if (lua_isnil(L,1))
+ return 1; /* a nil */
+ n_ptr = check_isnode(L,1);
+ n = *n_ptr;
+ field = get_valid_node_field_id(L,2, n);
+
+ if (field<-1)
+ return 0;
+ if (field==0) {
+ lua_pushnumber(L,vlink(n));
+ lua_nodelib_push(L);
+ } else if (field==1) {
+ lua_pushnumber(L,type(n));
+ } else if (field==-1) {
+ lua_pushnumber(L,alink(n));
+ lua_nodelib_push(L);
+ } else if (field==3 && nodetype_has_attributes(type(n))) {
+ nodelib_pushattr(L,node_attr(n));
+ } else {
+ switch (type(n)) {
+ case hlist_node:
+ case vlist_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: lua_pushnumber(L,width(n)); break;
+ case 5: lua_pushnumber(L,depth(n)); break;
+ case 6: lua_pushnumber(L,height(n)); break;
+ case 7: lua_pushnumber(L,box_dir(n)); break;
+ case 8: lua_pushnumber(L,shift_amount(n)); break;
+ case 9: lua_pushnumber(L,glue_order(n)); break;
+ case 10: lua_pushnumber(L,glue_sign(n)); break;
+ case 11: lua_pushnumber(L,(double)glue_set(n)); break;
+ case 12: nodelib_pushlist(L,list_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case unset_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,0); break;
+ case 4: lua_pushnumber(L,width(n)); break;
+ case 5: lua_pushnumber(L,depth(n)); break;
+ case 6: lua_pushnumber(L,height(n)); break;
+ case 7: lua_pushnumber(L,box_dir(n)); break;
+ case 8: lua_pushnumber(L,glue_shrink(n)); break;
+ case 9: lua_pushnumber(L,glue_order(n)); break;
+ case 10: lua_pushnumber(L,glue_sign(n)); break;
+ case 11: lua_pushnumber(L,glue_stretch(n)); break;
+ case 12: lua_pushnumber(L,span_count(n)); break;
+ case 13: nodelib_pushlist(L,list_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case rule_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,0); break;
+ case 4: lua_pushnumber(L,width(n)); break;
+ case 5: lua_pushnumber(L,depth(n)); break;
+ case 6: lua_pushnumber(L,height(n)); break;
+ case 7: lua_pushnumber(L,rule_dir(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case ins_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: lua_pushnumber(L,float_cost(n)); break;
+ case 5: lua_pushnumber(L,depth(n)); break;
+ case 6: lua_pushnumber(L,height(n)); break;
+ case 7: nodelib_pushspec(L,split_top_ptr(n)); break;
+ case 8: nodelib_pushlist(L,ins_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case mark_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: lua_pushnumber(L,mark_class(n)); break;
+ case 5: tokenlist_to_lua(L,mark_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case adjust_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: nodelib_pushlist(L,adjust_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case disc_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: nodelib_pushlist(L,vlink(pre_break(n))); break;
+ case 5: nodelib_pushlist(L,vlink(post_break(n))); break;
+ case 6: nodelib_pushlist(L,vlink(no_break(n))); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case math_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: lua_pushnumber(L,surround(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case glue_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: nodelib_pushspec(L,glue_ptr(n)); break;
+ case 5: nodelib_pushlist(L,leader_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case glue_spec_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,0); break;
+ case 3: lua_pushnumber(L,width(n)); break;
+ case 4: lua_pushnumber(L,stretch(n)); break;
+ case 5: lua_pushnumber(L,shrink(n)); break;
+ case 6: lua_pushnumber(L,stretch_order(n)); break;
+ case 7: lua_pushnumber(L,shrink_order(n)); break;
+ case 8: lua_pushnumber(L,glue_ref_count(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case kern_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: lua_pushnumber(L,width(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case penalty_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,0); break;
+ case 4: lua_pushnumber(L,penalty(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case glyph_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 4: lua_pushnumber(L,character(n)); break;
+ case 5: lua_pushnumber(L,font(n)); break;
+ case 6: lua_pushnumber(L,char_lang(n)); break;
+ case 7: lua_pushnumber(L,char_lhmin(n)); break;
+ case 8: lua_pushnumber(L,char_rhmin(n)); break;
+ case 9: lua_pushnumber(L,char_uchyph(n)); break;
+ case 10: nodelib_pushlist(L,lig_ptr(n)); break;
+ case 11: lua_pushnumber(L,x_displace(n)); break;
+ case 12: lua_pushnumber(L,y_displace(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case inserting_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 3: nodelib_pushlist(L,last_ins_ptr(n)); break;
+ case 4: nodelib_pushlist(L,best_ins_ptr(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case split_up_node:
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 3: nodelib_pushlist(L,last_ins_ptr(n)); break;
+ case 4: nodelib_pushlist(L,best_ins_ptr(n)); break;
+ case 5: nodelib_pushlist(L,broken_ptr(n)); break;
+ case 6: nodelib_pushlist(L,broken_ins(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case margin_kern_node :
+ switch (field) {
+ case 2: lua_pushnumber(L,subtype(n)); break;
+ case 3: lua_pushnumber(L,width(n)); break;
+ case 4: nodelib_pushlist(L,margin_char(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case action_node:
+ switch (field) {
+ case 2: lua_pushnil(L); /* dummy subtype */ break;
+ case 3: lua_pushnumber(L,pdf_action_type(n)); break;
+ case 4: lua_pushnumber(L,pdf_action_named_id(n)); break;
+ case 5: if (pdf_action_named_id(n)==1) {
+ tokenlist_to_luastring(L,pdf_action_id(n));
+ } else {
+ lua_pushnumber(L,pdf_action_id(n));
+ } break;
+ case 6: tokenlist_to_luastring(L,pdf_action_file(n)); break;
+ case 7: lua_pushnumber(L,pdf_action_new_window(n)); break;
+ case 8: tokenlist_to_luastring(L,pdf_action_tokens(n));break;
+ case 9: lua_pushnumber(L,pdf_action_refcount(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case attribute_list_node :
+ switch (field) {
+ case 2: lua_pushnumber(L,0); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case attribute_node :
+ switch (field) {
+ case 2: lua_pushnumber(L,0); break;
+ case 3: lua_pushnumber(L,attribute_id(n)); break;
+ case 4: lua_pushnumber(L,attribute_value(n)); break;
+ default: lua_pushnil(L);
+ }
+ break;
+ case whatsit_node:
+ lua_nodelib_getfield_whatsit(L,n,field);
+ break;
+ default:
+ lua_pushnil(L);
+ break;
+ }
+ }
+ return 1;
+}
+
+
+static int nodelib_getlist(lua_State *L, int n) {
+ halfword *m;
+ if (lua_isuserdata(L,n)) {
+ m = check_isnode(L,n);
+ return *m;
+ } else {
+ return null ;
+ }
+}
+
+#define nodelib_getspec nodelib_getlist
+#define nodelib_getaction nodelib_getlist
+
+
+static str_number
+nodelib_getstring(lua_State *L, int a) {
+ size_t k;
+ char *s=(char *)lua_tolstring(L,a, &k);
+ return maketexlstring(s,k);
+}
+
+#define nodelib_gettoks(L,a) tokenlist_from_lua(L)
+
+static void nodelib_setattr (lua_State *L, int stackindex, halfword n) {
+ halfword p;
+ p = nodelib_getlist(L,stackindex);
+ if (node_attr(n) != p) {
+ if (node_attr(n)!=null)
+ delete_attribute_ref(node_attr(n));
+ node_attr(n) = p;
+ attr_list_ref(p)++;
+ }
+}
+
+static int nodelib_cantset (lua_State *L, int field, int n) {
+ lua_pushfstring(L,"You cannot set field %d in a node of type %s",
+ field, node_data[type(n)].name);
+ lua_error(L);
+ return 0;
+}
+
+static int
+lua_nodelib_setfield_whatsit(lua_State *L, int n, int field) {
+ switch (subtype(n)) {
+ case open_node:
+ switch (field) {
+ case 4: write_stream(n) = lua_tointeger(L,3); break;
+ case 5: open_name(n) = nodelib_getstring(L,3); break;
+ case 6: open_area(n) = nodelib_getstring(L,3); break;
+ case 7: open_ext(n) = nodelib_getstring(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case write_node:
+ switch (field) {
+ case 4: write_stream(n) = lua_tointeger(L,3); break;
+ case 5: write_tokens(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case close_node:
+ switch (field) {
+ case 4: write_stream(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case special_node:
+ switch (field) {
+ case 4: write_tokens(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case local_par_node:
+ switch (field) {
+ case 4: local_pen_inter(n) = lua_tointeger(L,3); break;
+ case 5: local_pen_broken(n) = lua_tointeger(L,3); break;
+ case 6: local_par_dir(n) = lua_tointeger(L,3); break;
+ case 7: local_box_left(n) = nodelib_getlist(L,3); break;
+ case 8: local_box_left_width(n) = lua_tointeger(L,3); break;
+ case 9: local_box_right(n) = nodelib_getlist(L,3); break;
+ case 10: local_box_right_width(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case dir_node:
+ switch (field) {
+ case 4: dir_dir(n) = lua_tointeger(L,3); break;
+ case 5: dir_level(n) = lua_tointeger(L,3); break;
+ case 6: dir_dvi_ptr(n) = lua_tointeger(L,3); break;
+ case 7: dir_dvi_h(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_literal_node:
+ switch (field) {
+ case 4: pdf_literal_mode(n) = lua_tointeger(L,3); break;
+ case 5: pdf_literal_data(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_refobj_node:
+ switch (field) {
+ case 4: pdf_obj_objnum(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_refxform_node:
+ switch (field) {
+ case 4: pdf_width(n) = lua_tointeger(L,3); break;
+ case 5: pdf_height(n) = lua_tointeger(L,3); break;
+ case 6: pdf_depth(n) = lua_tointeger(L,3); break;
+ case 7: pdf_xform_objnum(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_refximage_node:
+ switch (field) {
+ case 4: pdf_width(n) = lua_tointeger(L,3); break;
+ case 5: pdf_height(n) = lua_tointeger(L,3); break;
+ case 6: pdf_depth(n) = lua_tointeger(L,3); break;
+ case 7: pdf_ximage_objnum(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_annot_node:
+ switch (field) {
+ case 4: pdf_width(n) = lua_tointeger(L,3); break;
+ case 5: pdf_height(n) = lua_tointeger(L,3); break;
+ case 6: pdf_depth(n) = lua_tointeger(L,3); break;
+ case 7: pdf_annot_objnum(n) = lua_tointeger(L,3); break;
+ case 8: pdf_annot_data(n) = nodelib_getstring(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_start_link_node:
+ switch (field) {
+ case 4: pdf_width(n) = lua_tointeger(L,3); break;
+ case 5: pdf_height(n) = lua_tointeger(L,3); break;
+ case 6: pdf_depth(n) = lua_tointeger(L,3); break;
+ case 7: pdf_link_objnum(n) = lua_tointeger(L,3); break;
+ case 8: pdf_link_attr(n) = nodelib_getstring(L,3); break;
+ case 9: pdf_link_action(n) = nodelib_getaction(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_end_link_node:
+ switch (field) {
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_dest_node:
+ switch (field) {
+ case 4: pdf_width(n) = lua_tointeger(L,3); break;
+ case 5: pdf_height(n) = lua_tointeger(L,3); break;
+ case 6: pdf_depth(n) = lua_tointeger(L,3); break;
+ case 7: pdf_dest_named_id(n) = lua_tointeger(L,3); break;
+ case 8: if (pdf_dest_named_id(n)==1)
+ pdf_dest_id(n) = nodelib_gettoks(L,3);
+ else
+ pdf_dest_id(n) = lua_tointeger(L,3); break;
+ case 9: pdf_dest_type(n) = lua_tointeger(L,3); break;
+ case 10: pdf_dest_xyz_zoom(n) = lua_tointeger(L,3); break;
+ case 11: pdf_dest_objnum(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ switch (field) {
+ case 4: pdf_width(n) = lua_tointeger(L,3); break;
+ case 5: pdf_height(n) = lua_tointeger(L,3); break;
+ case 6: pdf_depth(n) = lua_tointeger(L,3); break;
+ case 7: pdf_thread_named_id(n) = lua_tointeger(L,3); break;
+ case 8: if (pdf_thread_named_id(n)==1)
+ pdf_thread_id(n) = nodelib_gettoks(L,3);
+ else
+ pdf_thread_id(n) = lua_tointeger(L,3); break;
+ case 9: pdf_thread_attr(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_end_thread_node:
+ case pdf_save_pos_node:
+ return nodelib_cantset(L,field,n);
+ break;
+ case late_lua_node:
+ switch (field) {
+ case 4: late_lua_reg(n) = lua_tointeger(L,3); break;
+ case 5: late_lua_data(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case close_lua_node:
+ switch (field) {
+ case 4: late_lua_reg(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_colorstack_node:
+ switch (field) {
+ case 4: pdf_colorstack_stack(n) = lua_tointeger(L,3); break;
+ case 5: pdf_colorstack_cmd(n) = lua_tointeger(L,3); break;
+ case 6: pdf_colorstack_data(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_setmatrix_node:
+ switch (field) {
+ case 4: pdf_setmatrix_data(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case pdf_save_node:
+ case pdf_restore_node:
+ case cancel_boundary_node:
+ return nodelib_cantset(L,field,n);
+ break;
+ case user_defined_node:
+ switch (field) {
+ case 4: user_node_id(n) = lua_tointeger(L,3); break;
+ case 5: user_node_type(n) = lua_tointeger(L,3); break;
+ case 6:
+ switch(user_node_type(n)) {
+ case 'a': user_node_value(n) = nodelib_getlist(L,3); break;
+ case 'd': user_node_value(n) = lua_tointeger(L,3); break;
+ case 'n': user_node_value(n) = nodelib_getlist(L,3); break;
+ case 's': user_node_value(n) = nodelib_getstring(L,3); break;
+ case 't': user_node_value(n) = nodelib_gettoks(L,3); break;
+ default: user_node_value(n) = lua_tointeger(L,3); break;
+ } break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ default:
+ /* do nothing */
+ break;
+ }
+ return 0;
+}
+
+static int
+lua_nodelib_setfield (lua_State *L) {
+ register halfword n;
+ register int field;
+ n = *check_isnode(L,1);
+ field = get_valid_node_field_id(L,2,n);
+ if (field<-1)
+ return 0;
+ if (field==0) {
+ vlink(n) = nodelib_getlist(L,3);
+ } else if (field==-1) {
+ alink(n) = nodelib_getlist(L,3);
+ } else if (field==3 && nodetype_has_attributes(type(n))) {
+ nodelib_setattr(L,3,n);
+ } else if (type(n)==glyph_node) {
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: character(n) = lua_tointeger(L,3); break;
+ case 5: font(n) = lua_tointeger(L,3); break;
+ case 6: set_char_lang(n,lua_tointeger(L,3)); break;
+ case 7: set_char_lhmin(n,lua_tointeger(L,3)); break;
+ case 8: set_char_rhmin(n,lua_tointeger(L,3)); break;
+ case 9: set_char_uchyph(n,lua_tointeger(L,3)); break;
+ case 10: lig_ptr(n) = nodelib_getlist(L,3); break;
+ case 11: x_displace(n) = lua_tointeger(L,3); break;
+ case 12: y_displace(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ } else {
+ switch (type(n)) {
+ case hlist_node:
+ case vlist_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: width(n) = lua_tointeger(L,3); break;
+ case 5: depth(n) = lua_tointeger(L,3); break;
+ case 6: height(n) = lua_tointeger(L,3); break;
+ case 7: box_dir(n) = lua_tointeger(L,3); break;
+ case 8: shift_amount(n) = lua_tointeger(L,3); break;
+ case 9: glue_order(n) = lua_tointeger(L,3); break;
+ case 10: glue_sign(n) = lua_tointeger(L,3); break;
+ case 11: glue_set(n) = (double)lua_tonumber(L,3); break;
+ case 12: list_ptr(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case unset_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ case 4: width(n) = lua_tointeger(L,3); break;
+ case 5: depth(n) = lua_tointeger(L,3); break;
+ case 6: height(n) = lua_tointeger(L,3); break;
+ case 7: box_dir(n) = lua_tointeger(L,3); break;
+ case 8: glue_shrink(n) = lua_tointeger(L,3); break;
+ case 9: glue_order(n) = lua_tointeger(L,3); break;
+ case 10: glue_sign(n) = lua_tointeger(L,3); break;
+ case 11: glue_stretch(n) = lua_tointeger(L,3); break;
+ case 12: span_count(n) = lua_tointeger(L,3); break;
+ case 13: list_ptr(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case rule_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ case 4: width(n) = lua_tointeger(L,3); break;
+ case 5: depth(n) = lua_tointeger(L,3); break;
+ case 6: height(n) = lua_tointeger(L,3); break;
+ case 7: rule_dir(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case ins_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: float_cost(n) = lua_tointeger(L,3); break;
+ case 5: depth(n) = lua_tointeger(L,3); break;
+ case 6: height(n) = lua_tointeger(L,3); break;
+ case 7: split_top_ptr(n) = nodelib_getspec(L,3); break;
+ case 8: ins_ptr(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case mark_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: mark_class(n) = lua_tointeger(L,3); break;
+ case 5: mark_ptr(n) = nodelib_gettoks(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case adjust_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: adjust_ptr(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case disc_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: set_disc_field(pre_break(n),nodelib_getlist(L,3)); break;
+ case 5: set_disc_field(post_break(n),nodelib_getlist(L,3)); break;
+ case 6: set_disc_field(no_break(n),nodelib_getlist(L,3)); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case math_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: surround(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case glue_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: glue_ptr(n) = nodelib_getspec(L,3); break;
+ case 5: leader_ptr(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case glue_spec_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ case 3: width(n) = lua_tointeger(L,3); break;
+ case 4: stretch(n) = lua_tointeger(L,3); break;
+ case 5: shrink(n) = lua_tointeger(L,3); break;
+ case 6: stretch_order(n) = lua_tointeger(L,3); break;
+ case 7: shrink_order(n) = lua_tointeger(L,3); break;
+ case 8: glue_ref_count(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case kern_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 4: width(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case penalty_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ case 4: penalty(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case action_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ case 3: pdf_action_type(n) = lua_tointeger(L,3); break;
+ case 4: pdf_action_named_id(n) = lua_tointeger(L,3); break;
+ case 5: if (pdf_action_named_id(n)==1) {
+ pdf_action_id(n) = nodelib_gettoks(L,3);
+ } else {
+ pdf_action_id(n) = lua_tointeger(L,3);
+ } break;
+ case 6: pdf_action_file(n) = nodelib_gettoks(L,3); break;
+ case 7: pdf_action_new_window(n) = lua_tointeger(L,3); break;
+ case 8: pdf_action_tokens(n) = nodelib_gettoks(L,3); break;
+ case 9: pdf_action_refcount(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case margin_kern_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 3: width(n) = lua_tointeger(L,3); break;
+ case 4: margin_char(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case inserting_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 3: last_ins_ptr(n) = nodelib_getlist(L,3); break;
+ case 4: best_ins_ptr(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case split_up_node:
+ switch (field) {
+ case 2: subtype(n) = lua_tointeger(L,3); break;
+ case 3: last_ins_ptr(n) = nodelib_getlist(L,3); break;
+ case 4: best_ins_ptr(n) = nodelib_getlist(L,3); break;
+ case 5: broken_ptr(n) = nodelib_getlist(L,3); break;
+ case 6: broken_ins(n) = nodelib_getlist(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case attribute_list_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case attribute_node:
+ switch (field) {
+ case 2: /* dummy subtype */ break;
+ case 3: attribute_id(n) = lua_tointeger(L,3); break;
+ case 4: attribute_value(n) = lua_tointeger(L,3); break;
+ default: return nodelib_cantset(L,field,n);
+ }
+ break;
+ case whatsit_node:
+ lua_nodelib_setfield_whatsit(L,n,field);
+ break;
+ default:
+ /* do nothing */
+ break;
+ }
+ }
+ return 0;
+}
+
+static int
+lua_nodelib_print (lua_State *L) {
+ char *msg;
+ char a[7] = {' ',' ',' ', 'n', 'i', 'l', 0};
+ char v[7] = {' ',' ',' ', 'n', 'i', 'l', 0};
+ halfword *n;
+ n = check_isnode(L,1);
+ msg = xmalloc(256);
+ if (alink(*n)!=null)
+ snprintf(a,7,"%6d",(int)alink(*n));
+ if (vlink(*n)!=null)
+ snprintf(v,7,"%6d",(int)vlink(*n));
+ snprintf(msg,255,"<node %s < %6d > %s : %s %d>", a, (int)*n, v, node_data[type(*n)].name, subtype(*n));
+ lua_pushstring(L,msg);
+ free(msg);
+ return 1;
+}
+
+
+static int
+lua_nodelib_equal (lua_State *L) {
+ halfword n, m;
+ n = *(check_isnode(L,1));
+ m = *(check_isnode(L,2));
+ lua_pushboolean(L,(n==m));
+ return 1;
+}
+
+static int
+font_tex_ligaturing (lua_State *L) {
+ /* on the stack are two nodes and a direction */
+ halfword tmp_head;
+ halfword *h;
+ halfword t =null;
+ if (lua_gettop(L)<1) {
+ lua_pushnil(L);
+ lua_pushboolean(L,0);
+ return 2;
+ }
+ h = check_isnode(L,1);
+ if (lua_gettop(L)>1) {
+ t = *(check_isnode(L,2));
+ }
+ tmp_head = new_node(nesting_node,1);
+ couple_nodes(tmp_head,*h);
+ tlink(tmp_head)=t;
+ t = handle_ligaturing(tmp_head,t);
+ lua_pushnumber(L,vlink(tmp_head));
+ flush_node(tmp_head);
+ lua_nodelib_push(L);
+ lua_pushnumber(L,t);
+ lua_nodelib_push(L);
+ lua_pushboolean(L,1);
+ return 3;
+}
+
+static int
+font_tex_kerning (lua_State *L) {
+ /* on the stack are two nodes and a direction */
+
+ halfword tmp_head;
+ halfword *h;
+ halfword t =null;
+ if (lua_gettop(L)<1) {
+ lua_pushnil(L);
+ lua_pushboolean(L,0);
+ return 2;
+ }
+ h = check_isnode(L,1);
+ if (lua_gettop(L)>1) {
+ t = *(check_isnode(L,2));
+ }
+ tmp_head = new_node(nesting_node,1);
+ couple_nodes(tmp_head,*h);
+ tlink(tmp_head)=t;
+ t = handle_kerning(tmp_head,t);
+ lua_pushnumber(L,vlink(tmp_head));
+ flush_node(tmp_head);
+ lua_nodelib_push(L);
+ lua_pushnumber(L,t);
+ lua_nodelib_push(L);
+ lua_pushboolean(L,1);
+ return 3;
+}
+
+static int
+lua_nodelib_protect_glyphs (lua_State *L) {
+ int t = 0;
+ halfword head = *(check_isnode(L,1));
+ while (head!=null) {
+ if (type(head)==glyph_node) {
+ register int s = subtype(head);
+ if (s<256) {
+ t = 1;
+ subtype(head) = ((s&0xFE) << 8);
+ }
+ }
+ head = vlink(head);
+ }
+ lua_pushboolean(L,t);
+ lua_pushvalue(L,1);
+ return 2;
+}
+
+static int
+lua_nodelib_unprotect_glyphs (lua_State *L) {
+ int t = 0;
+ halfword head = *(check_isnode(L,1));
+ while (head!=null) {
+ if (type(head)==glyph_node) {
+ register int s = subtype(head);
+ if (s>=256) {
+ t = 1;
+ subtype(head) = (s >> 8);
+ }
+ }
+ head = vlink(head);
+ }
+ lua_pushboolean(L,t);
+ lua_pushvalue(L,1);
+ return 2;
+}
+
+
+static int
+lua_nodelib_first_character (lua_State *L) {
+ /* on the stack are two nodes and a direction */
+ halfword h, savetail = null, t = null;
+ if (lua_gettop(L)<1) {
+ lua_pushnil(L);
+ lua_pushboolean(L,0);
+ return 2;
+ }
+ h = *(check_isnode(L,1));
+ if (lua_gettop(L)>1) {
+ t = *(check_isnode(L,2));
+ savetail = vlink(t);
+ vlink(t) = null;
+ }
+ while (h!=null && !is_simple_character(h)) {
+ h = vlink(h);
+ }
+ if (savetail!=null) { vlink(t) = savetail; }
+ lua_pushnumber(L,h);
+ lua_nodelib_push(L);
+ lua_pushboolean(L,(h==null? 0 : 1));
+ return 2;
+}
+
+
+/* this is too simplistic, but it helps Hans to get going */
+
+halfword
+do_ligature_n (halfword prev, halfword stop, halfword lig) {
+ vlink(lig) = vlink(stop);
+ vlink(stop) = null;
+ lig_ptr(lig) = vlink(prev);
+ vlink(prev) = lig;
+ return lig;
+}
+
+
+
+/* node.do_ligature_n(node prev, node last, node lig) */
+static int
+lua_nodelib_do_ligature_n (lua_State *L) {
+ halfword n, m, o, p, tmp_head;
+ n = *(check_isnode(L,1));
+ m = *(check_isnode(L,2));
+ o = *(check_isnode(L,3));
+ if (alink(n)==null || vlink(alink(n))!=n) {
+ tmp_head = new_node(temp_node,0);
+ couple_nodes(tmp_head,n);
+ p = do_ligature_n(tmp_head,m,o);
+ flush_node(tmp_head);
+ } else {
+ p = do_ligature_n(alink(n),m,o);
+ }
+ lua_pushnumber(L,p);
+ lua_nodelib_push(L);
+ return 1;
+}
+
+extern halfword list_node_mem_usage (void) ;
+
+static int
+lua_nodelib_usedlist (lua_State *L) {
+ lua_pushnumber(L,list_node_mem_usage());
+ lua_nodelib_push(L);
+ return 1;
+}
+
+
+static const struct luaL_reg nodelib_f [] = {
+ {"id", lua_nodelib_id},
+ {"subtype", lua_nodelib_subtype},
+ {"type", lua_nodelib_type},
+ {"new", lua_nodelib_new},
+ {"length", lua_nodelib_length},
+ {"count", lua_nodelib_count},
+ {"traverse", lua_nodelib_traverse},
+ {"traverse_id", lua_nodelib_traverse_filtered},
+ {"slide", lua_nodelib_tail},
+ {"types", lua_nodelib_types},
+ {"whatsits", lua_nodelib_whatsits},
+ {"fields", lua_nodelib_fields},
+ {"has_field", lua_nodelib_has_field},
+ {"free", lua_nodelib_free},
+ {"flush_list", lua_nodelib_flush_list},
+ {"remove", lua_nodelib_remove},
+ {"insert_before", lua_nodelib_insert_before},
+ {"insert_after", lua_nodelib_insert_after},
+ {"write", lua_nodelib_append},
+ {"last_node", lua_nodelib_last_node},
+ {"copy", lua_nodelib_copy},
+ {"copy_list", lua_nodelib_copy_list},
+ {"hpack", lua_nodelib_hpack},
+ {"has_attribute", lua_nodelib_has_attribute},
+ {"set_attribute", lua_nodelib_set_attribute},
+ {"unset_attribute", lua_nodelib_unset_attribute},
+ {"do_ligature_n", lua_nodelib_do_ligature_n},
+ {"ligaturing", font_tex_ligaturing},
+ {"kerning", font_tex_kerning},
+ {"first_character", lua_nodelib_first_character},
+ {"usedlist", lua_nodelib_usedlist},
+ {"protect_glyphs", lua_nodelib_protect_glyphs},
+ {"unprotect_glyphs", lua_nodelib_unprotect_glyphs},
+ {NULL, NULL} /* sentinel */
+};
+
+static const struct luaL_reg nodelib_m [] = {
+ {"__index", lua_nodelib_getfield},
+ {"__newindex", lua_nodelib_setfield},
+ {"__tostring", lua_nodelib_print},
+ {"__eq", lua_nodelib_equal},
+ {NULL, NULL} /* sentinel */
+};
+
+
+
+int
+luaopen_node (lua_State *L)
+{
+ luaL_newmetatable(L,NODE_METATABLE);
+ luaL_register(L, NULL, nodelib_m);
+ luaL_register(L, "node", nodelib_f);
+ init_luaS_index(luatex_node);
+ initialize_luaS_indexes(L);
+ return 1;
+}
+
+void
+nodelist_to_lua (lua_State *L, int n) {
+ lua_pushnumber(L,n);
+ lua_nodelib_push(L);
+}
+
+int
+nodelist_from_lua (lua_State *L) {
+ halfword *n;
+ if (lua_isnil(L,-1))
+ return null;
+ n = check_isnode(L,-1);
+ return *n;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/loslibext.c b/Build/source/texk/web2c/luatexdir/lua/loslibext.c
new file mode 100644
index 00000000000..003b031f627
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/loslibext.c
@@ -0,0 +1,627 @@
+/* $Id: loslibext.c 1066 2008-02-23 10:52:51Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <time.h>
+
+/* An attempt to figure out the basic platform, does not
+ care about niceties like version numbers yet,
+ and ignores platforms where luatex is unlikely to
+ successfully compile without major prorting effort
+ (amiga|mac|os2|vms) */
+
+#if defined(_WIN32) || defined(WIN32) || defined(__NT__)
+#define OS_PLATTYPE "windows"
+#define OS_PLATNAME "windows"
+#elif defined(__GO32__) || defined(__DJGPP__) || defined(__DOS__)
+#define OS_PLATTYPE "msdos"
+#define OS_PLATNAME "msdos"
+#else /* assume everything else is unix-y */
+#define OS_PLATTYPE "unix"
+/* this is just a first guess */
+#if defined(__BSD__)
+ #define OS_PLATNAME "bsd"
+#elif defined(__SYSV__)
+ #define OS_PLATNAME "sysv"
+#else
+ #define OS_PLATNAME "generic"
+#endif
+/* attempt to be more precise */
+#if defined(__LINUX__) || defined (__linux)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "linux"
+#elif defined(__FREEBSD__) || defined(__FreeBSD)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "freebsd"
+#elif defined(__OPENBSD__) || defined(__OpenBSD)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "openbsd"
+#elif defined(__SOLARIS__)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "solaris"
+#elif defined(__SUNOS__) || defined(__SUN__) || defined(sun)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "sunos"
+#elif defined(HPUX) || defined(__hpux)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "hpux"
+#elif defined(__sgi)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "irix"
+#elif defined(__MACH__) && defined(__APPLE__)
+ #undef OS_PLATNAME
+ #define OS_PLATNAME "macosx"
+#endif
+#endif
+
+
+
+
+
+/* there could be more platforms that don't have these two,
+ * but win32 and sunos are for sure.
+ * gettimeofday() for win32 is using an alternative definition
+ */
+
+#if (! defined(WIN32)) && (! defined(__SUNOS__))
+#include <sys/time.h> /* gettimeofday() */
+#include <sys/times.h> /* times() */
+#include <sys/wait.h>
+#endif
+
+/* set this to one for spawn instead of exec on windows */
+
+#define DONT_REALLY_EXIT 1
+
+#ifdef WIN32
+#include <process.h>
+#define spawn_command(a,b,c) _spawnvpe(_P_WAIT,(const char *)a,(const char* const*)b,(const char* const*)c)
+#if DONT_REALLY_EXIT
+#define exec_command(a,b,c) exit(spawn_command((a),(b),(c)))
+#else
+#define exec_command(a,b,c) _execvpe((const char *)a,(const char* const*)b,(const char* const*)c)
+#endif
+#else
+#include <unistd.h>
+#define DEFAULT_PATH "/bin:/usr/bin:."
+
+static int
+exec_command(const char *file, char *const *argv, char *const *envp)
+{
+ char path[PATH_MAX];
+ const char *searchpath, *esp;
+ size_t prefixlen, filelen, totallen;
+
+ if (strchr(file, '/')) /* Specific path */
+ return execve(file, argv, envp);
+
+ filelen = strlen(file);
+
+ searchpath = getenv("PATH");
+ if (!searchpath)
+ searchpath = DEFAULT_PATH;
+
+ errno = ENOENT; /* Default errno, if execve() doesn't change it */
+
+ do {
+ esp = strchr(searchpath, ':');
+ if (esp)
+ prefixlen = esp - searchpath;
+ else
+ prefixlen = strlen(searchpath);
+
+ if (prefixlen == 0 || searchpath[prefixlen - 1] == '/') {
+ totallen = prefixlen + filelen;
+ if (totallen >= PATH_MAX)
+ continue;
+ memcpy(path, searchpath, prefixlen);
+ memcpy(path + prefixlen, file, filelen);
+ } else {
+ totallen = prefixlen + filelen + 1;
+ if (totallen >= PATH_MAX)
+ continue;
+ memcpy(path, searchpath, prefixlen);
+ path[prefixlen] = '/';
+ memcpy(path + prefixlen + 1, file, filelen);
+ }
+ path[totallen] = '\0';
+
+ execve(path, argv, envp);
+ if (errno == E2BIG || errno == ENOEXEC ||
+ errno == ENOMEM || errno == ETXTBSY)
+ break; /* Report this as an error, no more search */
+
+ searchpath = esp + 1;
+ } while (esp);
+
+ return -1;
+}
+
+/*
+ It is not possible to mimic |spawnve()| completely. The main problem is
+ that the |fork|--|waitpid| combination cannot really do identical error
+ reporting to the parent process, because it has to pass all the possible
+ error conditions as well as the actual process return status through a
+ single 8-bit value.
+
+ The current implementation tries to give back meaningful results for |execve()|
+ errors in the child, for the cases that could also be returned by |spawnve()|,
+ and for |ETXTBSY|, because that can be triggered by our path searching routine.
+
+ This implementation does not differentiate abnormal status conditions reported
+ by |waitpid()|, but will simply return a single error indication value.
+
+ For all this, hyjacking a bunch of numbers in the range 1...255 is needed.
+ The chance of collisions is hopefully diminished by using a rather random
+ range in the 8-bit section.
+*/
+
+#define INVALID_RET_E2BIG 143
+#define INVALID_RET_ENOENT 144
+#define INVALID_RET_ENOEXEC 145
+#define INVALID_RET_ENOMEM 146
+#define INVALID_RET_ETXTBSY 147
+#define INVALID_RET_UNKNOWN 148
+#define INVALID_RET_INTR 149
+
+static int
+spawn_command(const char *file, char *const *argv, char *const *envp)
+{
+ pid_t pid, wait_pid;
+ int status;
+ pid = fork();
+ if (pid<0) {
+ return -1; /* fork failed */
+ }
+ if (pid>0) { /* parent */
+ status = 0;
+ wait_pid = waitpid (pid, &status,0);
+ if (wait_pid == pid) {
+ if (WIFEXITED(status))
+ return WEXITSTATUS(status);
+ else
+ return INVALID_RET_INTR;
+ } else {
+ return -1; /* some waitpid error */
+ }
+ } else {
+ int f;
+ /* somewhat random upper limit. ignore errors on purpose */
+ for (f = 0; f<256; f++)
+ (void)fsync(f);
+
+ if (exec_command(file, argv, envp)) {
+ /* let's hope no-one uses these values */
+ switch (errno) {
+ case E2BIG: exit(INVALID_RET_E2BIG);
+ case ETXTBSY: exit(INVALID_RET_ETXTBSY);
+ case ENOENT: exit(INVALID_RET_ENOENT);
+ case ENOEXEC: exit(INVALID_RET_ENOEXEC);
+ case ENOMEM: exit(INVALID_RET_ENOMEM);
+ default: exit(INVALID_RET_UNKNOWN);
+ }
+ return -1;
+ }
+ }
+}
+
+#endif
+
+extern char **environ;
+
+static char **
+do_split_command(char *maincmd)
+{
+ char *piece, *start_piece;
+ char *cmd;
+ char **cmdline = NULL;
+ unsigned int i, j;
+ int ret = 0;
+ int in_string = 0;
+ int quoted = 0;
+ if (strlen(maincmd) == 0)
+ return NULL;
+ /* allocate the array of options first. it will probably be
+ be a little bit too big, but better too much than to little */
+ j=2;
+ for (i = 0; i < strlen(maincmd); i++) { if (maincmd[i]==' ') j++; }
+ cmdline = malloc(sizeof(char *) * j);
+ for (i = 0; i < j; i++) { cmdline[i] = NULL; }
+ cmd = maincmd;
+ i = 0;
+ while (cmd[i] == ' ') i++; /* skip leading spaces */
+ start_piece = malloc(strlen(cmd)+1); /* a buffer */
+ piece = start_piece;
+ for (; i <= strlen(maincmd); i++) {
+ if (cmd[i]=='\\' &&
+ (cmd[i+1] == '\\' || cmd[i+1] == '\'' || cmd[i+1] == '"')) {
+ quoted =1;
+ continue;
+ }
+ if (in_string && cmd[i] == in_string && !quoted) {
+ in_string = 0;
+ continue;
+ }
+ if ((cmd[i] == '"' || cmd[i] == '\'')&& !quoted) {
+ in_string = cmd[i];
+ continue;
+ }
+ if ((in_string==0 && cmd[i] == ' ') || cmd[i]==0) {
+ *piece = 0;
+ cmdline[ret++] = xstrdup(start_piece);
+ piece = start_piece;
+ while (i < strlen(maincmd) && cmd[(i + 1)] == ' ')
+ i++;
+ continue;
+ }
+ *piece++ = cmd[i];
+ quoted=0;
+ }
+ xfree(start_piece);
+ return cmdline;
+}
+
+static char **
+do_flatten_command(lua_State *L, char **runcmd) {
+ unsigned int i, j ;
+ char *s;
+ char **cmdline = NULL;
+ *runcmd = NULL;
+
+ for (j = 1;;j++) {
+ lua_rawgeti(L,-1,j);
+ if (lua_isnil(L,-1)) {
+ lua_pop(L,1);
+ break;
+ }
+ lua_pop(L,1);
+ }
+ if (j == 1)
+ return NULL;
+ cmdline = malloc(sizeof(char *) * (j+1));
+ for (i = 1; i <= j; i++) {
+ cmdline[i] = NULL;
+ lua_rawgeti(L,-1,i);
+ if (lua_isnil(L,-1) || (s=(char *)lua_tostring(L,-1))==NULL) {
+ lua_pop(L,1);
+ if (i==1) {
+ xfree(cmdline) ;
+ return NULL;
+ } else {
+ break;
+ }
+ } else {
+ lua_pop(L,1);
+ cmdline[(i-1)] = xstrdup(s);
+ }
+ }
+ cmdline[i] = NULL;
+
+ lua_rawgeti(L,-1,0);
+ if (lua_isnil(L,-1) || (s=(char *)lua_tostring(L,-1))==NULL) {
+ *runcmd = cmdline[0];
+ } else {
+ *runcmd = xstrdup(s);
+ }
+ lua_pop(L,1);
+
+ return cmdline;
+}
+
+
+static int os_exec (lua_State *L) {
+ char * maincmd, * runcmd;
+ char ** cmdline = NULL;
+
+ if (lua_gettop(L)!=1) {
+ lua_pushnil(L);
+ lua_pushliteral(L,"invalid arguments passed");
+ return 2;
+ }
+ if (lua_type(L,1)==LUA_TSTRING) {
+ maincmd = (char *)lua_tostring(L, 1);
+ cmdline = do_split_command(maincmd);
+ runcmd = cmdline[0];
+ } else if (lua_type(L,1)==LUA_TTABLE) {
+ cmdline = do_flatten_command(L, & runcmd);
+ }
+ if (cmdline!=NULL) {
+#if defined(WIN32) && DONT_REALLY_EXIT
+ exec_command(runcmd, cmdline, environ);
+#else
+ if (exec_command(runcmd, cmdline, environ)==-1) {
+ lua_pushnil(L);
+ lua_pushfstring(L,"%s: %s",runcmd, strerror(errno));
+ lua_pushnumber(L, errno);
+ return 3;
+ }
+#endif
+ }
+ lua_pushnil(L);
+ lua_pushliteral(L,"invalid command line passed");
+ return 2;
+}
+
+#define do_error_return(A,B) do { \
+ lua_pushnil(L); \
+ lua_pushfstring(L,"%s: %s",runcmd,(A)); \
+ lua_pushnumber(L, B); \
+ return 3; \
+ } while (0)
+
+static int os_spawn (lua_State *L) {
+ char * maincmd, * runcmd;
+ char ** cmdline = NULL;
+ int i;
+
+ if (lua_gettop(L)!=1) {
+ lua_pushnil(L);
+ lua_pushliteral(L,"invalid arguments passed");
+ return 2;
+ }
+ if (lua_type(L,1)==LUA_TSTRING) {
+ maincmd = (char *)lua_tostring(L, 1);
+ cmdline = do_split_command(maincmd);
+ runcmd = cmdline[0];
+ } else if (lua_type(L,1)==LUA_TTABLE) {
+ cmdline = do_flatten_command(L, &runcmd);
+ }
+ if (cmdline!=NULL) {
+ i = spawn_command(runcmd, cmdline, environ);
+ if (i==0) {
+ lua_pushnumber(L, i);
+ return 1;
+ } else if (i==-1) {
+ /* this branch covers WIN32 as well as fork() and waitpid() errors */
+ do_error_return(strerror(errno),errno);
+#ifndef WIN32
+ } else if (i==INVALID_RET_E2BIG) { do_error_return(strerror(E2BIG),i);
+ } else if (i==INVALID_RET_ENOENT) { do_error_return(strerror(ENOENT),i);
+ } else if (i==INVALID_RET_ENOEXEC) { do_error_return(strerror(ENOEXEC),i);
+ } else if (i==INVALID_RET_ENOMEM) { do_error_return(strerror(ENOMEM),i);
+ } else if (i==INVALID_RET_ETXTBSY) { do_error_return(strerror(ETXTBSY),i);
+ } else if (i==INVALID_RET_UNKNOWN) { do_error_return("execution failed",i);
+ } else if (i==INVALID_RET_INTR) { do_error_return("execution interrupted",i);
+#endif
+ } else {
+ lua_pushnumber(L, i);
+ return 1;
+ }
+ }
+ lua_pushnil(L);
+ lua_pushliteral(L,"invalid command line passed");
+ return 2;
+}
+
+/* Hans wants to set env values */
+
+static int os_setenv (lua_State *L) {
+ char *value, *key, *val;
+ key = (char *)luaL_optstring(L, 1, NULL);
+ val = (char *)luaL_optstring(L, 2, NULL);
+ if (key) {
+ if (val) {
+ value = xmalloc(strlen(key)+strlen(val)+2);
+ sprintf(value,"%s=%s",key,val);
+ if (putenv(value)) {
+ return luaL_error(L, "unable to change environment");
+ }
+ } else {
+#if defined(WIN32) || defined(__sun__)
+ value = xmalloc(strlen(key)+2);
+ sprintf(value,"%s=",key);
+ if (putenv(value)) {
+ return luaL_error(L, "unable to change environment");
+ }
+#else
+ (void)unsetenv(key);
+#endif
+ }
+ }
+ lua_pushboolean (L, 1);
+ return 1;
+}
+
+
+void find_env (lua_State *L){
+ char *envitem, *envitem_orig;
+ char *envkey;
+ char **envpointer;
+ envpointer = environ;
+ lua_getglobal(L,"os");
+ if (envpointer!=NULL && lua_istable(L,-1)) {
+ luaL_checkstack(L,2,"out of stack space");
+ lua_pushstring(L,"env");
+ lua_newtable(L);
+ while (*envpointer) {
+ /* TODO: perhaps a memory leak here */
+ luaL_checkstack(L,2,"out of stack space");
+ envitem = xstrdup(*envpointer);
+ envitem_orig = envitem;
+ envkey=envitem;
+ while (*envitem != '=') {
+ envitem++;
+ }
+ *envitem=0;
+ envitem++;
+ lua_pushstring(L,envkey);
+ lua_pushstring(L,envitem);
+ lua_rawset(L,-3);
+ envpointer++;
+ free(envitem_orig);
+ }
+ lua_rawset(L,-3);
+ }
+ lua_pop(L,1);
+}
+
+static int ex_sleep(lua_State *L)
+{
+ lua_Number interval = luaL_checknumber(L, 1);
+ lua_Number units = luaL_optnumber(L, 2, 1);
+#ifdef WIN32
+ Sleep(1e3 * interval / units);
+#else /* assumes posix or bsd */
+ usleep(1e6 * interval / units);
+#endif
+ return 0;
+}
+
+#if (! defined (WIN32)) && (! defined (__SUNOS__))
+static int os_times (lua_State *L) {
+ struct tms r;
+ (void)times(&r);
+ lua_newtable(L);
+ lua_pushnumber(L, ((lua_Number)(r.tms_utime))/(lua_Number)sysconf(_SC_CLK_TCK));
+ lua_setfield(L,-2,"utime");
+ lua_pushnumber(L, ((lua_Number)(r.tms_stime))/(lua_Number)sysconf(_SC_CLK_TCK));
+ lua_setfield(L,-2,"stime");
+ lua_pushnumber(L, ((lua_Number)(r.tms_cutime))/(lua_Number)sysconf(_SC_CLK_TCK));
+ lua_setfield(L,-2,"cutime");
+ lua_pushnumber(L, ((lua_Number)(r.tms_cstime))/(lua_Number)sysconf(_SC_CLK_TCK));
+ lua_setfield(L,-2,"cstime");
+ return 1;
+}
+#endif
+
+#if ! defined (__SUNOS__)
+
+#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)
+ #define DELTA_EPOCH_IN_MICROSECS 11644473600000000Ui64
+#else
+ #define DELTA_EPOCH_IN_MICROSECS 11644473600000000ULL
+#endif
+
+static int os_gettimeofday (lua_State *L) {
+ double v;
+#ifndef WIN32
+ struct timeval tv;
+ gettimeofday(&tv, NULL);
+ v = (double)tv.tv_sec + (double)tv.tv_usec / 1000000.0;
+#else
+ FILETIME ft;
+ unsigned __int64 tmpres = 0;
+
+ GetSystemTimeAsFileTime(&ft);
+
+ tmpres |= ft.dwHighDateTime;
+ tmpres <<= 32;
+ tmpres |= ft.dwLowDateTime;
+ tmpres /= 10;
+ tmpres -= DELTA_EPOCH_IN_MICROSECS; /*converting file time to unix epoch*/
+ v = (double)tmpres / 1000000.0;
+#endif
+ lua_pushnumber(L, v);
+ return 1;
+}
+#endif
+
+static const char repl[] = "0123456789abcdefghijklmnopqrstuvwxyz";
+
+static int dirs_made = 0;
+
+#define MAXTRIES 36*36*36
+
+char *
+do_mkdtemp (char *tmpl)
+{
+ int count ;
+ int value ;
+ char *xes = &tmpl[strlen (tmpl) - 6];
+ /* this is not really all that random, but it will do */
+ if (dirs_made==0) {
+ srand(time(NULL));
+ }
+ value = rand();
+ for (count = 0; count < MAXTRIES; value += 8413, ++count) {
+ int v = value;
+ xes[0] = repl[v % 36]; v /= 36;
+ xes[1] = repl[v % 36]; v /= 36;
+ xes[2] = repl[v % 36]; v /= 36;
+ xes[3] = repl[v % 36]; v /= 36;
+ xes[4] = repl[v % 36]; v /= 36;
+ xes[5] = repl[v % 36];
+ if (mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR) >= 0) {
+ dirs_made++;
+ return tmpl;
+ } else if (errno != EEXIST) {
+ return NULL;
+ }
+ }
+ return NULL;
+}
+
+static int os_tmpdir (lua_State *L) {
+ char *s, *tempdir;
+ char *tmp = (char *)luaL_optstring(L, 1, "luatex.XXXXXX");
+ if (tmp==NULL ||
+ strlen(tmp)<6 ||
+ (strcmp(tmp+strlen(tmp)-6,"XXXXXX") != 0)) {
+ lua_pushnil(L);
+ lua_pushstring(L, "Invalid argument to os.tmpdir()");
+ return 2;
+ } else {
+ tempdir = xstrdup(tmp);
+ }
+#ifdef HAVE_MKDTEMP
+ s = mkdtemp(tempdir);
+#else
+ s = do_mkdtemp(tempdir);
+#endif
+ if (s==NULL) {
+ int en = errno; /* calls to Lua API may change this value */
+ lua_pushnil(L);
+ lua_pushfstring(L, "%s", strerror(en));
+ return 2;
+ } else {
+ lua_pushstring(L,s);
+ return 1;
+ }
+}
+
+
+void
+open_oslibext (lua_State *L, int safer_option) {
+
+ find_env(L);
+
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, ex_sleep);
+ lua_setfield(L,-2,"sleep");
+ lua_getglobal(L,"os");
+ lua_pushliteral(L, OS_PLATTYPE);
+ lua_setfield(L,-2,"type");
+ lua_getglobal(L,"os");
+ lua_pushliteral(L, OS_PLATNAME);
+ lua_setfield(L,-2,"name");
+#if (! defined (WIN32)) && (! defined (__SUNOS__))
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, os_times);
+ lua_setfield(L,-2,"times");
+#endif
+#if ! defined (__SUNOS__)
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, os_gettimeofday);
+ lua_setfield(L,-2,"gettimeofday");
+#endif
+ if (!safer_option) {
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, os_setenv);
+ lua_setfield(L,-2,"setenv");
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, os_exec);
+ lua_setfield(L,-2,"exec");
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, os_spawn);
+ lua_setfield(L,-2,"spawn");
+ lua_getglobal(L,"os");
+ lua_pushcfunction(L, os_tmpdir);
+ lua_setfield(L,-2,"tmpdir");
+
+ }
+
+
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/lpdflib.c b/Build/source/texk/web2c/luatexdir/lua/lpdflib.c
new file mode 100644
index 00000000000..9cf847c84c8
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lpdflib.c
@@ -0,0 +1,127 @@
+/* $Id: lpdflib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+
+static int
+findcurv (lua_State *L) {
+ int j;
+ j = get_cur_v();
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+static int
+findcurh (lua_State *L) {
+ int j;
+ j = get_cur_h();
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+
+typedef enum { set_origin, direct_page, direct_always } pdf_lit_mode;
+
+int luapdfprint(lua_State * L)
+{
+ int n;
+ unsigned i, len;
+ const char *outputstr, *st;
+ pdf_lit_mode literal_mode;
+ n = lua_gettop(L);
+ if (!lua_isstring(L, -1)) {
+ lua_pushstring(L, "no string to print");
+ lua_error(L);
+ }
+ literal_mode = set_origin;
+ if (n == 2) {
+ if (!lua_isstring(L, -2)) {
+ lua_pushstring(L, "invalid argument for print literal mode");
+ lua_error(L);
+ } else {
+ outputstr = (char *) lua_tostring(L, -2);
+ if (strcmp(outputstr, "direct") == 0)
+ literal_mode = direct_always;
+ else if (strcmp(outputstr, "page") == 0)
+ literal_mode = direct_page;
+ else {
+ lua_pushstring(L,
+ "invalid argument for print literal mode");
+ lua_error(L);
+ }
+ }
+ } else {
+ if (n != 1) {
+ lua_pushstring(L, "invalid number of arguments");
+ lua_error(L);
+ }
+ }
+ switch (literal_mode) {
+ case (set_origin):
+ pdf_end_text();
+ pdf_set_origin(cur_h, cur_v);
+ break;
+ case (direct_page):
+ pdf_end_text();
+ break;
+ case (direct_always):
+ pdf_end_string_nl();
+ break;
+ default:
+ assert(0);
+ }
+ st = lua_tolstring(L, n,&len);
+ for (i = 0; i < len; i++) {
+ if (i%16 == 0)
+ pdfroom(16);
+ pdf_buf[pdf_ptr++] = st[i];
+ }
+ return 0;
+}
+
+static int
+getpdf (lua_State *L) {
+ char *st;
+ if (lua_isstring(L,2)) {
+ st = (char *)lua_tostring(L,2);
+ if (st && *st) {
+ if (*st == 'h')
+ return findcurh(L);
+ else if (*st == 'v')
+ return findcurv(L);
+ }
+ }
+ lua_pushnil(L);
+ return 1;
+}
+
+static int
+setpdf (lua_State *L) {
+ return (L==NULL ? 0 : 0); /* for -Wall */
+}
+
+static const struct luaL_reg pdflib[] = {
+ {"print", luapdfprint},
+ {NULL, NULL} /* sentinel */
+};
+
+
+int
+luaopen_pdf (lua_State *L) {
+ luaL_register(L, "pdf", pdflib);
+ /* build meta table */
+ luaL_newmetatable(L,"pdf_meta");
+ lua_pushstring(L, "__index");
+ lua_pushcfunction(L, getpdf);
+ /* do these later, NYI */
+ if (0) {
+ lua_settable(L, -3);
+ lua_pushstring(L, "__newindex");
+ lua_pushcfunction(L, setpdf);
+ }
+ lua_settable(L, -3);
+ lua_setmetatable(L,-2); /* meta to itself */
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/lstatslib.c b/Build/source/texk/web2c/luatexdir/lua/lstatslib.c
new file mode 100644
index 00000000000..025e851e775
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/lstatslib.c
@@ -0,0 +1,211 @@
+/* $Id: lstatslib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+typedef struct statistic {
+ const char *name;
+ char type;
+ void *value;
+} statistic ;
+
+extern char *ptexbanner;
+/* extern string getcurrentfilenamestring; */
+
+typedef char * (*charfunc)(void);
+typedef integer (*intfunc)(void);
+
+char *getbanner (void) {
+ return ptexbanner;
+}
+
+/* hack, I really should implement the makecstring */
+char *getfilename (void) {
+ integer t;
+ t = get_current_name();
+ if (t>(1<<21))
+ return makecstring(t);
+ else
+ return xstrdup ("");
+}
+
+char *getlasterror (void) {
+ return makecstring(last_error);
+}
+
+
+extern int luabytecode_max;
+extern int luabytecode_bytes;
+extern int luastate_max;
+extern int luastate_bytes;
+
+static struct statistic stats[] = {
+ { "pdf_gone", 'g', &pdf_gone },
+ { "pdf_ptr", 'g', &pdf_ptr },
+ { "dvi_gone", 'g', &dvi_offset },
+ { "dvi_ptr", 'g', &dvi_ptr },
+ { "total_pages", 'g', &total_pages },
+ { "output_file_name", 's', &output_file_name },
+ { "log_name", 's', &texmf_log_name }, /* weird */
+ { "banner", 'S', &getbanner },
+ { "pdftex_banner", 's', &pdftex_banner },
+ /*
+ * mem stat
+ */
+ { "var_used", 'g', &var_used },
+ { "dyn_used", 'g', &dyn_used },
+ /*
+ * traditional tex stats
+ */
+ { "str_ptr", 'g', &str_ptr },
+ { "init_str_ptr", 'g', &init_str_ptr },
+ { "max_strings", 'g', &max_strings },
+ { "pool_ptr", 'g', &pool_ptr },
+ { "init_pool_ptr", 'g', &init_pool_ptr },
+ { "pool_size", 'g', &pool_size },
+ { "var_mem_max", 'g', &var_mem_max },
+ { "node_mem_usage", 'S', &sprint_node_mem_usage },
+ { "fix_mem_max", 'g', &fix_mem_max },
+ { "fix_mem_min", 'g', &fix_mem_min },
+ { "fix_mem_end", 'g', &fix_mem_end },
+ { "cs_count", 'g', &cs_count },
+ { "hash_size", 'G', &get_hash_size },
+ { "hash_extra", 'g', &hash_extra },
+ { "font_ptr", 'G', &max_font_id },
+ { "max_in_stack", 'g', &max_in_stack },
+ { "max_nest_stack", 'g', &max_nest_stack },
+ { "max_param_stack", 'g', &max_param_stack },
+ { "max_buf_stack", 'g', &max_buf_stack },
+ { "max_save_stack", 'g', &max_save_stack },
+ { "stack_size", 'g', &stack_size },
+ { "nest_size", 'g', &nest_size },
+ { "param_size", 'g', &param_size },
+ { "buf_size", 'g', &buf_size },
+ { "save_size", 'g', &save_size },
+ /* pdf stats */
+ { "obj_ptr", 'g', &obj_ptr },
+ { "obj_tab_size", 'g', &obj_tab_size },
+ { "pdf_os_cntr", 'g', &pdf_os_cntr },
+ { "pdf_os_objidx", 'g', &pdf_os_objidx },
+ { "pdf_dest_names_ptr", 'g', &pdf_dest_names_ptr },
+ { "dest_names_size", 'g', &dest_names_size },
+ { "pdf_mem_ptr", 'g', &pdf_mem_ptr },
+ { "pdf_mem_size", 'g', &pdf_mem_size },
+
+ { "largest_used_mark", 'g', &biggest_used_mark },
+
+ { "filename", 'S', &getfilename },
+ { "inputid", 'G', &get_current_name },
+ { "linenumber", 'g', &line },
+ { "lasterrorstring", 'S', &getlasterror },
+
+ { "luabytecodes", 'g', &luabytecode_max },
+ { "luabytecode_bytes", 'g', &luabytecode_bytes },
+ { "luastates", 'g', &luastate_max },
+ { "luastate_bytes", 'g', &luastate_bytes },
+
+ { "output_active", 'b', &output_active },
+
+ { NULL, 0 , 0 } };
+
+
+static int stats_name_to_id (char *name) {
+ int i;
+ for (i=0; stats[i].name!=NULL; i++) {
+ if (strcmp(stats[i].name, name) == 0)
+ return i;
+ }
+ return 0;
+}
+
+static int do_getstat (lua_State *L,int i) {
+ int t;
+ char *st;
+ charfunc f;
+ intfunc g;
+ int str;
+ t = stats[i].type;
+ switch(t) {
+ case 'S':
+ f = stats[i].value;
+ st = f();
+ lua_pushstring(L,st);
+ break;
+ case 's':
+ str = *(integer *)(stats[i].value);
+ if (str) {
+ lua_pushstring(L,makecstring(str));
+ } else {
+ lua_pushnil(L);
+ }
+ break;
+ case 'G':
+ g = stats[i].value;
+ lua_pushnumber(L,g());
+ break;
+ case 'g':
+ lua_pushnumber(L,*(integer *)(stats[i].value));
+ break;
+ case 'B':
+ g = stats[i].value;
+ lua_pushboolean(L,g());
+ break;
+ case 'b':
+ lua_pushboolean(L,*(integer *)(stats[i].value));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int getstats (lua_State *L) {
+ char *st;
+ int i;
+ if (lua_isstring(L,-1)) {
+ st = (char *)lua_tostring(L,-1);
+ i = stats_name_to_id(st);
+ if (i>0) {
+ return do_getstat(L,i);
+ }
+ }
+ return 0;
+}
+
+static int setstats (lua_State *L) {
+ return 0;
+}
+
+static int statslist (lua_State *L) {
+ int i;
+ luaL_checkstack(L,1,"out of stack space");
+ lua_newtable(L);
+ for (i=0; stats[i].name!=NULL; i++) {
+ luaL_checkstack(L,2,"out of stack space");
+ lua_pushstring(L,stats[i].name);
+ do_getstat(L,i);
+ lua_rawset(L,-3);
+ }
+ return 1;
+}
+
+
+
+static const struct luaL_reg statslib [] = {
+ {"list",statslist},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_stats (lua_State *L)
+{
+ luaL_register(L, "status", statslib);
+ luaL_newmetatable(L,"stats_meta");
+ lua_pushstring(L, "__index");
+ lua_pushcfunction(L, getstats);
+ lua_settable(L, -3);
+ lua_pushstring(L, "__newindex");
+ lua_pushcfunction(L, setstats);
+ lua_settable(L, -3);
+ lua_setmetatable(L,-2); /* meta to itself */
+ return 1;
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c b/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c
new file mode 100644
index 00000000000..a61409b2943
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c
@@ -0,0 +1,117 @@
+/* $Id: ltexiolib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+typedef void (*texio_printer) (strnumber s);
+
+static char *loggable_info = NULL;
+
+static int
+do_texio_print (lua_State *L, texio_printer printfunction) {
+ strnumber texs,u;
+ char *s;
+ char save_selector;
+ int n,i;
+ size_t k;
+ u = 0;
+ n = lua_gettop(L);
+ if (n==0 || !lua_isstring(L, -1)) {
+ lua_pushstring(L, "no string to print");
+ lua_error(L);
+ }
+ save_selector = selector;
+ i = 1;
+ if (n>1) {
+ s=(char *)lua_tostring(L, 1);
+ if (strcmp(s,"log") == 0) { i++; selector = log_only; }
+ else if (strcmp(s,"term") == 0) { i++; selector = term_only; }
+ else if (strcmp(s,"term and log") == 0) { i++; selector = term_and_log; }
+ }
+ if (selector!=log_only && selector!=term_only && selector != term_and_log) {
+ normalize_selector(); /* sets selector */
+ }
+ /* just in case there is a string in progress */
+ if (str_start[str_ptr-0x200000]<pool_ptr)
+ u=make_string();
+ for (;i<=n;i++) {
+ s = (char *)lua_tolstring(L, i, &k);
+ texs = maketexlstring(s,k);
+ printfunction(texs);
+ flush_str(texs);
+ }
+ selector = save_selector;
+ if (u!=0) str_ptr--;
+ return 0;
+}
+
+static void
+do_texio_ini_print (lua_State *L, char *extra) {
+ char *s;
+ int i,n,l;
+ n = lua_gettop(L);
+ i = 1;
+ l = 3;
+ if (n>1) {
+ s=(char *)lua_tostring(L, 1);
+ if (strcmp(s,"log") == 0) { i++; l = 1; }
+ else if (strcmp(s,"term") == 0) { i++; l = 2; }
+ else if (strcmp(s,"term and log") == 0) { i++; l = 3; }
+ }
+ for (;i<=n;i++) {
+ if(lua_isstring(L, i)) {
+ s = (char *)lua_tostring(L, i);
+ if (l==2||l==3)
+ fprintf(stdout,"%s%s", extra, s);
+ if (l==1||l==3) {
+ if (loggable_info==NULL) {
+ loggable_info = strdup(s);
+ } else {
+ char *v = concat3 (loggable_info,extra,s);
+ free(loggable_info);
+ loggable_info = v;
+ }
+ }
+ }
+ }
+}
+
+static int
+texio_print (lua_State *L) {
+ if (ready_already!=314159 || pool_ptr==0 || job_name==0) {
+ do_texio_ini_print(L,"");
+ return 0;
+ }
+ return do_texio_print(L,zprint);
+}
+
+static int
+texio_printnl (lua_State *L) {
+ if (ready_already!=314159 || pool_ptr==0 || job_name==0) {
+ do_texio_ini_print(L,"\n");
+ return 0;
+ }
+ return do_texio_print(L,zprint_nl);
+}
+
+/* at the point this function is called, the selector is log_only */
+void flush_loggable_info (void) {
+ if (loggable_info!=NULL) {
+ fprintf(log_file,"%s\n",loggable_info);
+ free(loggable_info);
+ loggable_info=NULL;
+ }
+}
+
+
+static const struct luaL_reg texiolib [] = {
+ {"write", texio_print},
+ {"write_nl", texio_printnl},
+ {NULL, NULL} /* sentinel */
+};
+
+int
+luaopen_texio (lua_State *L) {
+ luaL_register(L,"texio",texiolib);
+ return 1;
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/ltexlib.c b/Build/source/texk/web2c/luatexdir/lua/ltexlib.c
new file mode 100644
index 00000000000..f2258010136
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/ltexlib.c
@@ -0,0 +1,820 @@
+/* $Id: ltexlib.c 1087 2008-03-07 23:52:35Z hhenkel $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "nodes.h"
+
+typedef struct {
+ char *text;
+ unsigned int tsize;
+ void *next;
+ unsigned char partial;
+ int cattable;
+} rope;
+
+typedef struct {
+ rope *head;
+ rope *tail;
+ char complete; /* currently still writing ? */
+} spindle;
+
+#define PARTIAL_LINE 1
+#define FULL_LINE 0
+
+#define NO_CAT_TABLE -2
+#define DEFAULT_CAT_TABLE -1
+
+#define write_spindle spindles[spindle_index]
+#define read_spindle spindles[(spindle_index-1)]
+
+static int spindle_size = 0;
+static spindle *spindles = NULL;
+static int spindle_index = 0;
+
+
+static int
+do_luacprint (lua_State * L, int partial, int deftable) {
+ int i, n;
+ size_t tsize;
+ char *st, *sttemp;
+ rope *rn;
+ int cattable = deftable;
+ int startstrings = 1;
+ n = lua_gettop(L);
+ if (cattable != NO_CAT_TABLE) {
+ if (lua_type(L,1)==LUA_TNUMBER && n>1) {
+ cattable = lua_tonumber(L, 1);
+ startstrings = 2;
+ }
+ }
+ for (i = startstrings; i <= n; i++) {
+ if (!lua_isstring(L, i)) {
+ lua_pushstring(L, "no string to print");
+ lua_error(L);
+ }
+ sttemp = (char *)lua_tolstring(L, i,&tsize);
+ st = xmalloc((tsize+1));
+ memcpy(st,sttemp,(tsize+1));
+ if (st) {
+ /* fprintf(stderr,"W[%d]:=%s\n",spindle_index,st);*/
+ luacstrings++;
+ rn = (rope *)xmalloc(sizeof(rope)); /* valgrind says we leak here */
+ rn->text = st;
+ rn->tsize = tsize;
+ rn->partial = partial;
+ rn->cattable = cattable;
+ rn->next = NULL;
+ if (write_spindle.head == NULL) {
+ assert(write_spindle.tail == NULL);
+ write_spindle.head = rn;
+ } else {
+ write_spindle.tail->next = rn;
+ }
+ write_spindle.tail = rn;
+ write_spindle.complete = 0;
+ }
+ }
+ return 0;
+}
+
+int luacwrite(lua_State * L) {
+ return do_luacprint(L,FULL_LINE,NO_CAT_TABLE);
+}
+
+int luacprint(lua_State * L) {
+ return do_luacprint(L,FULL_LINE,DEFAULT_CAT_TABLE);
+}
+
+int luacsprint(lua_State * L) {
+ return do_luacprint(L,PARTIAL_LINE,DEFAULT_CAT_TABLE);
+}
+
+int
+luacstring_detokenized (void) {
+ return (read_spindle.tail->cattable == NO_CAT_TABLE);
+}
+
+int
+luacstring_defaultcattable (void) {
+ return (read_spindle.tail->cattable == DEFAULT_CAT_TABLE);
+}
+
+integer
+luacstring_cattable (void) {
+ return (integer)read_spindle.tail->cattable;
+}
+
+int
+luacstring_simple (void) {
+ return (read_spindle.tail->partial == PARTIAL_LINE);
+}
+
+int
+luacstring_penultimate (void) {
+ return (read_spindle.tail->next == NULL);
+}
+
+int
+luacstring_input (void) {
+ char *st;
+ int ret;
+ rope *t = read_spindle.head;
+ if (!read_spindle.complete) {
+ read_spindle.complete =1;
+ read_spindle.tail = NULL;
+ }
+ if (t == NULL) {
+ if(read_spindle.tail != NULL)
+ free(read_spindle.tail);
+ read_spindle.tail = NULL;
+ return 0;
+ }
+ if (t->text != NULL) {
+ st = t->text;
+ /* put that thing in the buffer */
+ last = first;
+ ret = last;
+ check_buffer_overflow (last + t->tsize);
+ while (t->tsize-->0)
+ buffer[last++] = *st++;
+ if (!t->partial) {
+ while (last-1>ret && buffer[last-1] == ' ')
+ last--;
+ }
+ free (t->text);
+ t->text = NULL;
+ }
+ if (read_spindle.tail != NULL) { /* not a one-liner */
+ free(read_spindle.tail);
+ }
+ read_spindle.tail = t;
+ read_spindle.head = t->next;
+ return 1;
+}
+
+/* open for reading, and make a new one for writing */
+void
+luacstring_start (int n) {
+ spindle_index++;
+ if(spindle_size == spindle_index) { /* add a new one */
+ spindles = xrealloc(spindles,sizeof(spindle)*(spindle_size+1));
+ spindles[spindle_index].head = NULL;
+ spindles[spindle_index].tail = NULL;
+ spindles[spindle_index].complete = 0;
+ spindle_size++;
+ }
+}
+
+/* close for reading */
+
+void
+luacstring_close (int n) {
+ rope *next, *t;
+ next = read_spindle.head;
+ while (next != NULL) {
+ if (next->text != NULL)
+ free(next->text);
+ t = next;
+ next = next->next;
+ free(t);
+ }
+ read_spindle.head = NULL;
+ if(read_spindle.tail != NULL)
+ free(read_spindle.tail);
+ read_spindle.tail = NULL;
+ read_spindle.complete = 0;
+ spindle_index--;
+}
+
+/* local (static) versions */
+
+#define width_offset 1
+#define depth_offset 2
+#define height_offset 3
+
+#define check_index_range(j) \
+ if (j<0 || j > 65535) { \
+ lua_pushstring(L, "incorrect index value"); \
+ lua_error(L); }
+
+
+int dimen_to_number (lua_State *L,char *s){
+ double v;
+ char *d;
+ int j;
+ v = strtod(s,&d);
+ if (strcmp (d,"in") == 0) { j = (int)(((v*7227)/100) *65536); }
+ else if (strcmp (d,"pc") == 0) { j = (int)((v*12) *65536); }
+ else if (strcmp (d,"cm") == 0) { j = (int)(((v*7227)/254) *65536); }
+ else if (strcmp (d,"mm") == 0) { j = (int)(((v*7227)/2540) *65536); }
+ else if (strcmp (d,"bp") == 0) { j = (int)(((v*7227)/7200) *65536); }
+ else if (strcmp (d,"dd") == 0) { j = (int)(((v*1238)/1157) *65536); }
+ else if (strcmp (d,"cc") == 0) { j = (int)(((v*14856)/1157) *65536); }
+ else if (strcmp (d,"nd") == 0) { j = (int)(((v*21681)/20320)*65536); }
+ else if (strcmp (d,"nc") == 0) { j = (int)(((v*65043)/5080) *65536); }
+ else if (strcmp (d,"pt") == 0) { j = (int)(v *65536); }
+ else if (strcmp (d,"sp") == 0) { j = (int)(v); }
+ else {
+ lua_pushstring(L, "unknown dimension specifier");
+ lua_error(L);
+ j = 0;
+ }
+ return j;
+}
+
+int setdimen (lua_State *L) {
+ int i,j;
+ size_t k;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ j = 0;
+ /* find the value*/
+ if (!lua_isnumber(L,i))
+ if (lua_isstring(L,i)) {
+ j = dimen_to_number(L,(char *)lua_tostring(L,i));
+ } else {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ }
+ else
+ j = (int)lua_tonumber(L,i);
+ /* find the index*/
+ if (lua_type(L,i-1)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i-1, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ k = zget_equiv(cur_cs)-get_scaled_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i-1);
+ }
+ check_index_range(k);
+ if(set_tex_dimen_register(k,j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getdimen (lua_State *L) {
+ int i,j;
+ size_t k;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L,i)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs)-get_scaled_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i);
+ }
+ check_index_range(k);
+ j = get_tex_dimen_register(k);
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+int setcount (lua_State *L) {
+ int i,j;
+ size_t k;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ j = (int)luaL_checkinteger(L,i);
+ if (lua_type(L,i-1)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i-1,&k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ k = zget_equiv(cur_cs)-get_count_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i-1);
+ }
+ check_index_range(k);
+ if (set_tex_count_register(k,j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getcount (lua_State *L) {
+ int i, j;
+ size_t k;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L,i)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs)-get_count_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i);
+ }
+ check_index_range(k);
+ j = get_tex_count_register(k);
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+
+int setattribute (lua_State *L) {
+ int i,j;
+ size_t k;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ j = (int)luaL_checkinteger(L,i);
+ if (lua_type(L,i-1)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i-1, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ k = zget_equiv(cur_cs)-get_attribute_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i-1);
+ }
+ check_index_range(k);
+ if (set_tex_attribute_register(k,j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getattribute (lua_State *L) {
+ int i, j;
+ size_t k;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L,i)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs)-get_attribute_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i);
+ }
+ check_index_range(k);
+ j = get_tex_attribute_register(k);
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+int settoks (lua_State *L) {
+ int i,j;
+ size_t k,len;
+ int cur_cs;
+ int texstr;
+ char *s, *st;
+ i = lua_gettop(L);
+ if (!lua_isstring(L,i)) {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ }
+ st = (char *)lua_tolstring(L,i,&len);
+
+ if (lua_type(L,i-1)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i-1, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ k = zget_equiv(cur_cs)-get_toks_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i-1);
+ }
+ check_index_range(k);
+ j = maketexlstring(st,len);
+
+ if(zset_tex_toks_register(k,j)) {
+ flush_str(j);
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int gettoks (lua_State *L) {
+ int i;
+ size_t k;
+ strnumber t;
+ int cur_cs;
+ int texstr;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L,i)==LUA_TSTRING) {
+ s = (char *)lua_tolstring(L,i, &k);
+ texstr = maketexlstring(s,k);
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs)-get_toks_base();
+ } else {
+ k = (int)luaL_checkinteger(L,i);
+ }
+
+ check_index_range(k);
+ t = get_tex_toks_register(k);
+ lua_pushstring(L, makecstring(t));
+ flush_str(t);
+ return 1;
+}
+
+int getbox (lua_State *L) {
+ int k, t;
+ k = (int)luaL_checkinteger(L,-1);
+ check_index_range(k);
+ t = get_tex_box_register(k);
+ nodelist_to_lua(L,t);
+ return 1;
+}
+
+int setbox (lua_State *L) {
+ int i,j,k;
+
+
+
+ k = (int)luaL_checkinteger(L,-2);
+ check_index_range(k);
+ i = get_tex_box_register(k);
+ if (lua_isboolean(L,-1)) {
+ j = lua_toboolean(L,-1);
+ if (j==0)
+ j = null;
+ else
+ return 0;
+ } else {
+ j = nodelist_from_lua(L);
+ }
+ if(set_tex_box_register(k,j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+
+static int getboxdim (lua_State *L, int whichdim) {
+ int i, j;
+ i = lua_gettop(L);
+ j = (int)lua_tonumber(L,(i));
+ lua_settop(L,(i-2)); /* table at -1 */
+ if (j<0 || j > 65535) {
+ lua_pushstring(L, "incorrect index");
+ lua_error(L);
+ }
+ switch (whichdim) {
+ case width_offset:
+ lua_pushnumber(L, get_tex_box_width(j));
+ break;
+ case height_offset:
+ lua_pushnumber(L, get_tex_box_height(j));
+ break;
+ case depth_offset:
+ lua_pushnumber(L, get_tex_box_depth(j));
+ }
+ return 1;
+}
+
+int getboxwd (lua_State *L) {
+ return getboxdim (L, width_offset);
+}
+
+int getboxht (lua_State *L) {
+ return getboxdim (L, height_offset);
+}
+
+int getboxdp (lua_State *L) {
+ return getboxdim (L, depth_offset);
+}
+
+static int setboxdim (lua_State *L, int whichdim) {
+ int i,j,k,err;
+ i = lua_gettop(L);
+ if (!lua_isnumber(L,i)) {
+ j = dimen_to_number(L,(char *)lua_tostring(L,i));
+ } else {
+ j = (int)lua_tonumber(L,i);
+ }
+ k = (int)lua_tonumber(L,(i-1));
+ lua_settop(L,(i-3)); /* table at -2 */
+ if (k<0 || k > 65535) {
+ lua_pushstring(L, "incorrect index");
+ lua_error(L);
+ }
+ err = 0;
+ switch (whichdim) {
+ case width_offset:
+ err = set_tex_box_width(k,j);
+ break;
+ case height_offset:
+ err = set_tex_box_height(k,j);
+ break;
+ case depth_offset:
+ err = set_tex_box_depth(k,j);
+ }
+ if (err) {
+ lua_pushstring(L, "not a box");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int setboxwd (lua_State *L) {
+ return setboxdim(L,width_offset);
+}
+
+int setboxht (lua_State *L) {
+ return setboxdim(L,height_offset);
+}
+
+int setboxdp (lua_State *L) {
+ return setboxdim(L,depth_offset);
+}
+
+int settex (lua_State *L) {
+ char *st;
+ int i,j,texstr;
+ size_t k;
+ int cur_cs, cur_cmd;
+ j = 0;
+ i = lua_gettop(L);
+ if (lua_isstring(L,(i-1))) {
+ st = (char *)lua_tolstring(L,(i-1), &k);
+ texstr = maketexlstring(st,k);
+ if (zis_primitive(texstr)) {
+ cur_cs = string_lookup(texstr);
+ flush_str(texstr);
+ cur_cmd = zget_eq_type(cur_cs);
+ if (is_int_assign(cur_cmd)) {
+ if (lua_isnumber(L,i)) {
+ assign_internal_int(zget_equiv(cur_cs),lua_tonumber(L,i));
+ } else {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ }
+ } else if (is_dim_assign(cur_cmd)) {
+ if (!lua_isnumber(L,i))
+ if (lua_isstring(L,i)) {
+ j = dimen_to_number(L,(char *)lua_tostring(L,i));
+ } else {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ }
+ else
+ j = (int)lua_tonumber(L,i);
+ assign_internal_dim(zget_equiv(cur_cs),j);
+ } else {
+ lua_pushstring(L, "unsupported tex internal assignment");
+ lua_error(L);
+ }
+ } else {
+ lua_rawset(L,(i-2));
+ }
+ } else {
+ lua_rawset(L,(i-2));
+ }
+ return 0;
+}
+
+char *
+get_something_internal (int cur_cmd, int cur_code) {
+ int texstr;
+ char *str;
+ int save_cur_val,save_cur_val_level;
+ save_cur_val = cur_val;
+ save_cur_val_level = cur_val_level;
+ zscan_something_simple(cur_cmd,cur_code);
+ texstr = the_scanned_result();
+ cur_val = save_cur_val;
+ cur_val_level = save_cur_val_level;
+ str = makecstring(texstr);
+ flush_str(texstr);
+ return str;
+}
+
+char *
+get_convert (int cur_code) {
+ int texstr;
+ char *str = NULL;
+ texstr = the_convert_string(cur_code);
+ if (texstr) {
+ str = makecstring(texstr);
+ flush_str(texstr);
+ }
+ return str;
+}
+
+
+int
+gettex (lua_State *L) {
+ char *st;
+ int i,texstr;
+ size_t k;
+ char *str;
+ int cur_cs, cur_cmd, cur_code;
+ i = lua_gettop(L);
+ if (lua_isstring(L,i)) {
+ st = (char *)lua_tolstring(L,i, &k);
+ texstr = maketexlstring(st,k);
+ cur_cs = zprim_lookup(texstr);
+ flush_str(texstr);
+ if (cur_cs) {
+ cur_cmd = zget_prim_eq_type(cur_cs);
+ cur_code = zget_prim_equiv(cur_cs);
+ if (is_convert(cur_cmd))
+ str = get_convert(cur_code);
+ else
+ str = get_something_internal(cur_cmd,cur_code);
+ if (str)
+ lua_pushstring(L,str);
+ else
+ lua_pushnil(L);
+ return 1;
+ } else {
+ lua_rawget(L,(i-1));
+ return 1;
+ }
+ } else {
+ lua_rawget(L,(i-1));
+ return 1;
+ }
+ return 0; /* not reached */
+}
+
+
+int
+getlist (lua_State *L) {
+ char *str;
+ if (lua_isstring(L,2)) {
+ str = (char *)lua_tostring(L,2);
+ if (strcmp(str,"page_ins_head")==0) {
+ lua_pushnumber(L,page_ins_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"contrib_head")==0) {
+ lua_pushnumber(L,contrib_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"page_head")==0) {
+ lua_pushnumber(L,page_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"temp_head")==0) {
+ lua_pushnumber(L,temp_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"hold_head")==0) {
+ lua_pushnumber(L,hold_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"adjust_head")==0) {
+ lua_pushnumber(L,adjust_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"pre_adjust_head")==0) {
+ lua_pushnumber(L,pre_adjust_head); lua_nodelib_push(L);
+ } else if (strcmp(str,"align_head")==0) {
+ lua_pushnumber(L,align_head); lua_nodelib_push(L);
+ } else {
+ lua_pushnil(L);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+int
+setlist (lua_State *L) {
+ return 0;
+}
+
+#define infinity 2147483647
+
+static int
+do_integer_error(double m) {
+ char *help[] = {"I can only go up to 2147483647='17777777777=""7FFFFFFF,",
+ "so I'm using that number instead of yours.",
+ NULL } ;
+ tex_error("Number too big",help);
+ return (m>0.0 ? infinity : -infinity);
+}
+
+
+static int
+tex_roundnumber (lua_State *L) {
+ double m = lua_tonumber(L, 1)+0.5;
+ if (abs(m)>(double)infinity)
+ lua_pushnumber(L,do_integer_error(m));
+ else
+ lua_pushnumber(L,floor(m));
+ return 1;
+}
+
+static int
+tex_scaletable (lua_State *L) {
+ double delta = luaL_checknumber(L, 2);
+ if (lua_istable(L,1)) {
+ lua_newtable(L); /* the new table is at index 3 */
+ lua_pushnil(L);
+ while (lua_next(L,1)!= 0 ) { /* numeric value */
+ lua_pushvalue(L,-2);
+ lua_insert(L,-2);
+ if (lua_isnumber(L,-1)) {
+ double m = lua_tonumber(L,-1)*delta + 0.5;
+ lua_pop(L,1);
+ if (abs(m)>(double)infinity)
+ lua_pushnumber(L,do_integer_error(m));
+ else
+ lua_pushnumber(L,floor(m));
+ }
+ lua_rawset(L,3);
+ }
+ } else if (lua_isnumber(L,1)) {
+ double m = lua_tonumber(L,1)*delta + 0.5;
+ if (abs(m)>(double)infinity)
+ lua_pushnumber(L,do_integer_error(m));
+ else
+ lua_pushnumber(L,floor(m));
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static const struct luaL_reg texlib [] = {
+ {"write", luacwrite},
+ {"print", luacprint},
+ {"sprint", luacsprint},
+ {"setdimen", setdimen},
+ {"getdimen", getdimen},
+ {"setattribute", setattribute},
+ {"getattribute", getattribute},
+ {"setcount", setcount},
+ {"getcount", getcount},
+ {"settoks", settoks},
+ {"gettoks", gettoks},
+ {"setbox", setbox},
+ {"getbox", getbox},
+ {"setlist", setlist},
+ {"getlist", getlist},
+ {"setboxwd", setboxwd},
+ {"getboxwd", getboxwd},
+ {"setboxht", setboxht},
+ {"getboxht", getboxht},
+ {"setboxdp", setboxdp},
+ {"getboxdp", getboxdp},
+ {"round", tex_roundnumber},
+ {"scale", tex_scaletable},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_tex (lua_State *L)
+{
+ luaL_register(L, "tex", texlib);
+ make_table(L,"attribute","getattribute","setattribute");
+ make_table(L,"dimen","getdimen","setdimen");
+ make_table(L,"count","getcount","setcount");
+ make_table(L,"toks","gettoks","settoks");
+ make_table(L,"box","getbox","setbox");
+ make_table(L,"lists","getlist","setlist");
+ make_table(L,"wd","getboxwd","setboxwd");
+ make_table(L,"ht","getboxht","setboxht");
+ make_table(L,"dp","getboxdp","setboxdp");
+ /* make the meta entries */
+ /* fetch it back */
+ luaL_newmetatable(L,"tex_meta");
+ lua_pushstring(L, "__index");
+ lua_pushcfunction(L, gettex);
+ lua_settable(L, -3);
+ lua_pushstring(L, "__newindex");
+ lua_pushcfunction(L, settex);
+ lua_settable(L, -3);
+ lua_setmetatable(L,-2); /* meta to itself */
+ /* initialize the I/O stack: */
+ spindles = xmalloc(sizeof(spindle));
+ spindle_index = 0;
+ spindles[0].head = NULL;
+ spindles[0].tail = NULL;
+ spindle_size = 1;
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c b/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c
new file mode 100644
index 00000000000..582779623cf
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c
@@ -0,0 +1,263 @@
+/* $Id: ltokenlib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+
+extern int get_command_id (char *);
+
+static int max_command = 0;
+static int hash_base = 0;
+static int active_base = 0;
+static int null_cs = 0;
+
+#define protected_token 0x1C00001
+
+#define is_valid_token(L,i) (lua_istable(L,i) && lua_objlen(L,i)==3)
+#define get_token_cmd(L,i) lua_rawgeti(L,i,1)
+#define get_token_chr(L,i) lua_rawgeti(L,i,2)
+#define get_token_cs(L,i) lua_rawgeti(L,i,3)
+
+static int
+test_expandable (lua_State *L) {
+ integer cmd = -1;
+ if (is_valid_token(L,-1)) {
+ get_token_cmd(L,-1);
+ if (lua_isnumber(L,-1)) {
+ cmd = lua_tointeger(L,-1);
+ } else if (lua_isstring(L,-1)) {
+ cmd = get_command_id((char *)lua_tostring(L,-1));
+ }
+ if (cmd>max_command) {
+ lua_pushboolean(L,1);
+ } else {
+ lua_pushboolean(L,0);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+static int
+test_protected (lua_State *L) {
+ integer chr = -1;
+ if (is_valid_token(L,-1)) {
+ get_token_chr(L,-1);
+ if (lua_isnumber(L,-1)) {
+ chr = lua_tointeger(L,-1);
+ } else if (lua_isstring(L,-1)) {
+ chr = get_command_id((char *)lua_tostring(L,-1));
+ }
+ if (fixmem[fixmem[chr].hhrh].hhlh==protected_token) {
+ lua_pushboolean(L,1);
+ } else {
+ lua_pushboolean(L,0);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int
+test_activechar (lua_State *L) {
+ integer cmd = -1;
+ if (is_valid_token(L,-1)) {
+ get_token_chr(L,-1);
+ if (lua_isnumber(L,-1)) {
+ cmd = lua_tointeger(L,-1);
+ }
+ if (cmd>0 && cmd==protected_token) {
+ lua_pushboolean(L,1);
+ } else {
+ lua_pushboolean(L,0);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+static int
+run_get_command_name (lua_State *L) {
+ int cs;
+ if (is_valid_token(L,-1)) {
+ get_token_cmd(L,-1);
+ if (lua_isnumber(L,-1)) {
+ cs = lua_tointeger(L,-1);
+ lua_pushstring(L,command_names[cs].cmd_name);
+ } else {
+ lua_pushstring(L,"");
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int
+run_get_csname_name (lua_State *L) {
+ int cs,cmd,n;
+ char *s;
+
+ if (is_valid_token(L,-1)) {
+ get_token_cmd(L,-1);
+ if (lua_isnumber(L,-1)) {
+ cmd = lua_tointeger(L,-1);
+ }
+ lua_pop(L,1);
+ cs = 0;
+ get_token_cs(L,-1);
+ if (lua_isnumber(L,-1)) {
+ cs = lua_tointeger(L,-1);
+ }
+ lua_pop(L,1);
+
+ if (cs != 0 && (n = zget_cs_text(cs)) && n>=0) {
+ s = makecstring(n);
+ lua_pushstring(L,s);
+ } else {
+ lua_pushstring(L,"");
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int
+run_get_command_id (lua_State *L) {
+ int cs = -1;
+ if (lua_isstring(L,-1)) {
+ cs = get_command_id((char *)lua_tostring(L,-1));
+ }
+ lua_pushnumber(L,cs);
+ return 1;
+}
+
+
+static int
+run_get_csname_id (lua_State *L) {
+ int texstr;
+ char *s;
+ size_t k,cs = 0;
+ if (lua_isstring(L,-1)) {
+ s = (char *)lua_tolstring(L,-1, &k);
+ texstr = maketexlstring(s,k);
+ cs = string_lookup(texstr);
+ flush_str(texstr);
+ }
+ lua_pushnumber(L,cs);
+ return 1;
+}
+
+
+void
+make_token_table (lua_State *L, int cmd, int chr, int cs) {
+ lua_createtable(L,3,0);
+ lua_pushnumber(L,cmd);
+ lua_rawseti(L,-2,1);
+ lua_pushnumber(L,chr);
+ lua_rawseti(L,-2,2);
+ lua_pushnumber(L,cs);
+ lua_rawseti(L,-2,3);
+}
+
+static int
+run_get_next (lua_State *L) {
+ int save_nncs;
+ save_nncs = no_new_control_sequence;
+ no_new_control_sequence = 0;
+ get_next();
+ no_new_control_sequence = save_nncs;
+ make_token_table(L,cur_cmd,cur_chr,cur_cs);
+ return 1;
+}
+
+static int
+run_expand (lua_State *L) {
+ expand();
+ return 0;
+}
+
+
+static int
+run_lookup (lua_State *L) {
+ char *s;
+ size_t l;
+ str_number t;
+ integer cs,cmd,chr;
+ int save_nncs;
+ if (lua_isstring(L,-1)) {
+ s = (char *)lua_tolstring(L,-1,&l);
+ if (l>0) {
+ save_nncs = no_new_control_sequence;
+ no_new_control_sequence = true;
+ cs = id_lookup((last+1),l); /* cleans up the lookup buffer */
+ t = maketexlstring(s,l);
+ cs = string_lookup(t);
+ flush_str(t);
+ cmd = zget_eq_type(cs);
+ chr = zget_equiv(cs);
+ make_token_table(L,cmd,chr,cs);
+ no_new_control_sequence = save_nncs;
+ return 1;
+ }
+ }
+ lua_newtable(L);
+ return 1;
+}
+
+static int
+run_build (lua_State *L) {
+ integer cmd,chr,cs;
+ if (lua_isnumber(L,1)) {
+ cs =0;
+ chr = lua_tointeger(L,1);
+ cmd = luaL_optinteger(L,2,zget_char_cat_code(chr));
+ if (cmd==0 || cmd == 9 || cmd == 14 || cmd == 15) {
+ fprintf(stdout, "\n\nluatex error: not a good token.\nCatcode %i can not be returned, so I replaced it by 12 (other)",(int)cmd);
+ error();
+ cmd=12;
+ }
+ if (cmd == 13) {
+ cs=chr+active_base;
+ cmd=zget_eq_type(cs);
+ chr=zget_equiv(cs);
+ }
+ make_token_table(L,cmd,chr,cs);
+ return 1;
+ } else {
+ return run_lookup(L);
+ }
+}
+
+
+static const struct luaL_reg tokenlib [] = {
+ {"get_next", run_get_next},
+ {"expand", run_expand},
+ {"lookup", run_lookup},
+ {"create", run_build},
+ {"is_expandable",test_expandable},
+ {"is_activechar",test_activechar},
+ {"is_protected", test_protected},
+ {"csname_id", run_get_csname_id},
+ {"csname_name", run_get_csname_name},
+ {"command_name", run_get_command_name},
+ {"command_id", run_get_command_id},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_token (lua_State *L)
+{
+ luaL_register(L, "token", tokenlib);
+ max_command = get_max_command();
+ hash_base = get_hash_base();
+ active_base = get_active_base();
+ null_cs = get_nullcs();
+ return 1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/luainit.c b/Build/source/texk/web2c/luatexdir/lua/luainit.c
new file mode 100644
index 00000000000..c76b676c0f4
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/luainit.c
@@ -0,0 +1,520 @@
+#include <sys/stat.h>
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include <luatexdir/luatexextra.h>
+
+#ifndef program_invocation_name
+/* char *program_invocation_name = NULL; */
+#endif
+
+extern void parse_src_specials_option (char *n) ;
+
+const_string LUATEX_IHELP[] = {
+ "Usage: luatex --lua=FILE [OPTION]... [TEXNAME[.tex]] [COMMANDS]",
+ " or: luatex --lua=FILE [OPTION]... \\FIRST-LINE",
+ " or: luatex --lua=FILE [OPTION]... &FMT ARGS",
+ " Run luaTeX on TEXNAME, usually creating TEXNAME.pdf.",
+ " Any remaining COMMANDS are processed as luatex input, after TEXNAME is read.",
+ "",
+ " Alternatively, if the first non-option argument begins with a backslash,",
+ " interpret all non-option arguments as a line of luatex input.",
+ "",
+ " Alternatively, if the first non-option argument begins with a &, the",
+ " next word is taken as the FMT to read, overriding all else. Any",
+ " remaining arguments are processed as above.",
+ "",
+ " If no arguments or options are specified, prompt for input.",
+ "",
+ " --lua=FILE the lua initialization file",
+ " --safer disable some easily exploitable lua commands",
+ " --fmt=FORMAT load the format file FORMAT",
+ " --ini be initex, for dumping formats",
+ " --help display this help and exit",
+ " --version output version information and exit",
+ "",
+ " Alternate behaviour models can be obtained by special switches",
+ "",
+ " --luaonly run a lua file, then exit",
+ " --luaconly byte-compile a lua file, then exit",
+ NULL
+};
+
+static void
+prepare_cmdline(lua_State * L, char **argv, int argc, int zero_offset)
+{
+ int i;
+ luaL_checkstack(L, argc + 3, "too many arguments to script");
+ lua_createtable(L, 0, 0);
+ for (i = 0; i < argc; i++) {
+ lua_pushstring(L, argv[i]);
+ lua_rawseti(L, -2, (i-zero_offset));
+ }
+ lua_setglobal(L, "arg");
+ return;
+}
+
+extern string dump_name;
+extern const_string c_job_name;
+extern boolean srcspecialsoption;
+extern char *last_source_name;
+extern int last_lineno;
+
+string input_name = NULL;
+
+static string user_progname = NULL;
+
+extern char *ptexbanner;
+extern int program_name_set; /* in lkpselib.c */
+
+/* for topenin() */
+extern char **argv;
+extern int argc;
+
+char *startup_filename = NULL;
+int lua_only = 0;
+int lua_offset = 0;
+
+int safer_option = 0;
+
+/* Reading the options. */
+
+/* Test whether getopt found an option ``A''.
+ Assumes the option index is in the variable `option_index', and the
+ option table in a variable `long_options'. */
+#define ARGUMENT_IS(a) STREQ (long_options[option_index].name, a)
+
+/* SunOS cc can't initialize automatic structs, so make this static. */
+static struct option long_options[]
+ = { { "fmt", 1, 0, 0},
+ { "lua", 1, 0, 0},
+ { "luaonly", 0, 0, 0},
+ { "safer", 0, &safer_option, 1},
+ { "help", 0, 0, 0 },
+ { "ini", 0, &ini_version, 1 },
+ { "interaction", 1, 0, 0 },
+ { "halt-on-error", 0, &haltonerrorp, 1 },
+ { "kpathsea-debug", 1, 0, 0 },
+ { "progname", 1, 0, 0 },
+ { "version", 0, 0, 0 },
+ { "recorder", 0, &recorder_enabled, 1 },
+ { "etex", 0, 0, 0 },
+ { "output-comment", 1, 0, 0 },
+ { "output-directory", 1, 0, 0 },
+ { "draftmode", 0, 0, 0 },
+ { "output-format", 1, 0, 0 },
+ { "shell-escape", 0, &shellenabledp, 1 },
+ { "no-shell-escape", 0, &shellenabledp, -1 },
+ { "debug-format", 0, &debug_format_file, 1 },
+ { "src-specials", 2, 0, 0 },
+ { "file-line-error-style", 0, &filelineerrorstylep, 1 },
+ { "no-file-line-error-style", 0, &filelineerrorstylep, -1 },
+ /* Shorter option names for the above. */
+ { "file-line-error", 0, &filelineerrorstylep, 1 },
+ { "no-file-line-error", 0, &filelineerrorstylep, -1 },
+ { "jobname", 1, 0, 0 },
+ { "parse-first-line", 0, &parsefirstlinep, 1 },
+ { "no-parse-first-line", 0, &parsefirstlinep, -1 },
+ { "translate-file", 1, 0, 0 },
+ { "default-translate-file", 1, 0, 0 },
+ { "8bit", 0, 0, 0 },
+ { "mktex", 1, 0, 0 },
+ { "no-mktex", 1, 0, 0 },
+{0, 0, 0, 0}
+};
+
+static void
+parse_options(int argc, char **argv)
+{
+ int g; /* `getopt' return code. */
+ int option_index;
+ char *firstfile = NULL;
+ opterr = 0; /* dont whine */
+ for (;;) {
+ g = getopt_long_only(argc, argv, "+", long_options, &option_index);
+
+ if (g == -1) /* End of arguments, exit the loop. */
+ break;
+ if (g == '?') /* Unknown option. */
+ continue;
+
+ assert(g == 0); /* We have no short option names. */
+
+ if (ARGUMENT_IS("luaonly")) {
+ lua_only = 1;
+ lua_offset = optind;
+ luainit = 1 ;
+ } else if (ARGUMENT_IS("lua")) {
+ startup_filename = optarg;
+ lua_offset = (optind-1);
+ luainit = 1 ;
+
+ } else if (ARGUMENT_IS ("kpathsea-debug")) {
+ kpathsea_debug |= atoi (optarg);
+
+ } else if (ARGUMENT_IS("progname")) {
+ user_progname = optarg;
+
+ } else if (ARGUMENT_IS ("jobname")) {
+ c_job_name = optarg;
+
+ } else if (ARGUMENT_IS("fmt")) {
+ dump_name = optarg;
+
+ } else if (ARGUMENT_IS ("output-directory")) {
+ output_directory = optarg;
+
+ } else if (ARGUMENT_IS ("output-comment")) {
+ unsigned len = strlen (optarg);
+ if (len < 256) {
+ output_comment = optarg;
+ } else {
+ WARNING2 ("Comment truncated to 255 characters from %d. (%s)",
+ len, optarg);
+ output_comment = (string)xmalloc (256);
+ strncpy (output_comment, optarg, 255);
+ output_comment[255] = 0;
+ }
+
+ } else if (ARGUMENT_IS ("src-specials")) {
+ last_source_name = xstrdup("");
+ /* Option `--src" without any value means `auto' mode. */
+ if (optarg == NULL) {
+ insertsrcspecialeverypar = true;
+ insertsrcspecialauto = true;
+ srcspecialsoption = true;
+ srcspecialsp = true;
+ } else {
+ parse_src_specials_option(optarg);
+ }
+
+ } else if (ARGUMENT_IS ("output-format")) {
+ pdf_output_option = 1;
+ if (strcmp(optarg, "dvi") == 0) {
+ pdf_output_value = 0;
+ } else if (strcmp(optarg, "pdf") == 0) {
+ pdf_output_value = 2;
+ } else {
+ WARNING1 ("Ignoring unknown value `%s' for --output-format", optarg);
+ pdf_output_option = 0;
+ }
+
+ } else if (ARGUMENT_IS ("draftmode")) {
+ pdf_draftmode_option = 1;
+ pdf_draftmode_value = 1;
+
+ } else if (ARGUMENT_IS ("mktex")) {
+ kpse_maketex_option (optarg, true);
+
+ } else if (ARGUMENT_IS ("no-mktex")) {
+ kpse_maketex_option (optarg, false);
+
+ } else if (ARGUMENT_IS ("interaction")) {
+ /* These numbers match @d's in *.ch */
+ if (STREQ (optarg, "batchmode")) {
+ interactionoption = 0;
+ } else if (STREQ (optarg, "nonstopmode")) {
+ interactionoption = 1;
+ } else if (STREQ (optarg, "scrollmode")) {
+ interactionoption = 2;
+ } else if (STREQ (optarg, "errorstopmode")) {
+ interactionoption = 3;
+ } else {
+ WARNING1 ("Ignoring unknown argument `%s' to --interaction", optarg);
+ }
+
+ } else if (ARGUMENT_IS("help")) {
+ usagehelp(LUATEX_IHELP, BUG_ADDRESS);
+
+ } else if (ARGUMENT_IS("version")) {
+ char *versions;
+ initversionstring(&versions);
+ print_version_banner();
+
+ puts(
+"\n\nLuaTeX merges and builds upon (parts of) the code from these projects:\n\n"
+"tex by Donald Knuth\n"
+"etex by Peter Breitenlohner, Phil Taylor and friends\n"
+"omega by John Plaice and Yannis Haralambous\n"
+"aleph by Giuseppe Bilotta\n"
+"pdftex by Han The Thanh and friends\n"
+"kpathsea by Karl Berry, Olaf Weber and others\n"
+"lua by Roberto Ierusalimschy, Waldemar Celes,\n"
+" Luiz Henrique de Figueiredo\n"
+"metapost by John Hobby, Taco Hoekwater and friends.\n"
+"xpdf by Derek Noonberg (partial)\n"
+"fontforge by George Williams (partial)\n\n"
+"Some extensions to lua and additional lua libraries are used, as well as\n"
+"libraries for graphic inclusion. More details can be found in the source.\n"
+"Code development was sponsored by a grant from Colorado State University\n"
+"via the 'oriental tex' project, the TeX User Groups, and donations.\n\n"
+"The LuaTeX team is Hans Hagen, Hartmut Henkel, Taco Hoekwater.\n\n"
+"There is NO warranty. Redistribution of this software is covered by\n"
+"the terms of the GNU General Public License, version 2. For more\n"
+"information about these matters, see the file named COPYING and\n"
+"the LuaTeX source.\n\n"
+"Copyright 2008 Taco Hoekwater, the LuaTeX Team.\n");
+
+ puts(versions);
+ uexit(0);
+ }
+ }
+ /* attempt to find dump_name */
+ if (argv[optind] && argv[optind][0] == '&') {
+ dump_name = strdup(argv[optind] + 1);
+ } else if (argv[optind] && argv[optind][0] != '\\') {
+ if (argv[optind][0] == '*') {
+ input_name = strdup(argv[optind] + 1);
+ } else {
+ firstfile = strdup(argv[optind]);
+ if (lua_only) {
+ startup_filename = firstfile;
+ } else {
+ if ((strstr(firstfile,".lua") == firstfile+strlen(firstfile)-4) ||
+ (strstr(firstfile,".luc") == firstfile+strlen(firstfile)-4) ||
+ (strstr(firstfile,".LUA") == firstfile+strlen(firstfile)-4) ||
+ (strstr(firstfile,".LUC") == firstfile+strlen(firstfile)-4) ||
+ (strstr(argv[0],"luatexlua") != NULL) ||
+ (strstr(argv[0],"texlua") != NULL)) {
+ startup_filename = firstfile;
+ lua_only = 1;
+ lua_offset = optind;
+ luainit = 1 ;
+ } else {
+ input_name = firstfile;
+ }
+ }
+ }
+ } else {
+ if ((strstr(argv[0],"luatexlua") != NULL)||
+ (strstr(argv[0],"texlua") != NULL)) {
+ lua_only = 1;
+ luainit = 1 ;
+ }
+ }
+}
+
+/* test for readability */
+#define is_readable(a) (stat(a,&finfo)==0) && S_ISREG(finfo.st_mode) && \
+ (f=fopen(a,"r")) != NULL && !fclose(f)
+
+char *
+find_filename(char *name, char *envkey)
+{
+ struct stat finfo;
+ char *dirname = NULL;
+ char *filename = NULL;
+ FILE *f;
+ if (is_readable(name)) {
+ return name;
+ } else {
+ dirname = getenv(envkey);
+ if ((dirname != NULL) && strlen(dirname)) {
+ dirname = strdup(getenv(envkey));
+ if (*(dirname + strlen(dirname) - 1) == '/') {
+ *(dirname + strlen(dirname) - 1) = 0;
+ }
+ filename = xmalloc(strlen(dirname) + strlen(name) + 2);
+ filename = concat3(dirname, "/", name);
+ if (is_readable(filename)) {
+ xfree(dirname);
+ return filename;
+ }
+ xfree(filename);
+ }
+ }
+ return NULL;
+}
+
+
+void
+init_kpse (void) {
+
+ if (!user_progname) {
+ user_progname = dump_name;
+ } else if (!dump_name) {
+ dump_name = user_progname;
+ }
+ if (!user_progname) {
+ if (ini_version) {
+ user_progname = input_name;
+ } else {
+ if(!startup_filename) {
+ if (!dump_name) {
+ dump_name = strdup(argv[0]);
+ user_progname = dump_name;
+ }
+ }
+ }
+ }
+ if (!user_progname) {
+ fprintf(stdout,
+ "kpathsea mode needs a --progname or --fmt switch\n");
+ exit(1);
+ }
+ kpse_set_program_name(argv[0], user_progname);
+ program_name_set=1;
+}
+
+void
+fix_dumpname (void) {
+ int dist;
+ if (dump_name) {
+ /* adjust array for Pascal and provide extension, if needed */
+ dist = strlen(dump_name) - strlen(DUMP_EXT);
+ if (strstr(dump_name, DUMP_EXT) == dump_name + dist)
+ DUMP_VAR = concat(" ", dump_name);
+ else
+ DUMP_VAR = concat3(" ", dump_name, DUMP_EXT);
+ DUMP_LENGTH_VAR = strlen(DUMP_VAR + 1);
+ } else {
+ /* For dump_name to be NULL is a bug. */
+ if (!ini_version)
+ abort();
+ }
+}
+
+void
+lua_initialize(int ac, char **av)
+{
+
+ char *given_file = NULL;
+ int kpse_init;
+ int tex_table_id;
+ int pdf_table_id;
+ int token_table_id;
+ int node_table_id;
+ /* Save to pass along to topenin. */
+ argc = ac;
+ argv = av;
+
+ ptexbanner = BANNER;
+ program_invocation_name = argv[0];
+
+ /* be 'luac' */
+ if (argc>1 &&
+ (STREQ(argv[0],"texluac") ||
+ STREQ(argv[1],"--luaconly") ||
+ STREQ(argv[1],"--luac"))) {
+ exit(luac_main(ac,av));
+ }
+
+ /* Must be initialized before options are parsed. */
+ interactionoption = 4;
+ dump_name = NULL;
+ /* parse commandline */
+ parse_options(ac, av);
+
+ /* make sure that the locale is 'sane' (for lua) */
+ putenv("LC_CTYPE=C");
+ putenv("LC_COLLATE=C");
+ putenv("LC_NUMERIC=C");
+
+ /* this is sometimes needed */
+ putenv("engine=luatex");
+
+ luainterpreter(0);
+
+ prepare_cmdline(Luas[0], argv, argc, lua_offset); /* collect arguments */
+
+ if (startup_filename != NULL) {
+ given_file = xstrdup(startup_filename);
+ startup_filename = find_filename(startup_filename, "LUATEXDIR");
+ }
+ /* now run the file */
+ if (startup_filename != NULL) {
+ /* hide the 'tex' and 'pdf' table */
+ tex_table_id = hide_lua_table(Luas[0], "tex");
+ token_table_id = hide_lua_table(Luas[0], "token");
+ node_table_id = hide_lua_table(Luas[0], "node");
+ pdf_table_id = hide_lua_table(Luas[0], "pdf");
+
+ if (luaL_loadfile(Luas[0], startup_filename)) {
+ fprintf(stdout, "%s\n",lua_tostring(Luas[0], -1));
+ exit(1);
+ }
+ if (lua_pcall(Luas[0], 0, 0, 0)) {
+ fprintf(stdout, "%s\n",lua_tostring(Luas[0], -1));
+ exit(1);
+ }
+ /* no filename? quit now! */
+ if (!input_name) {
+ get_lua_string("texconfig", "jobname", &input_name);
+ }
+ if (!dump_name) {
+ get_lua_string("texconfig", "formatname", &dump_name);
+ }
+ if ((lua_only) || ((!input_name) && (!dump_name))) {
+ exit(0);
+ }
+ /* unhide the 'tex' and 'pdf' table */
+ unhide_lua_table(Luas[0], "tex", tex_table_id);
+ unhide_lua_table(Luas[0], "pdf", pdf_table_id);
+ unhide_lua_table(Luas[0], "token", token_table_id);
+ unhide_lua_table(Luas[0], "node", node_table_id);
+
+ /* kpse_init */
+ kpse_init = -1;
+ get_lua_boolean("texconfig", "kpse_init", &kpse_init);
+
+ if (kpse_init != 0) {
+ init_kpse();
+ }
+ /* prohibit_file_trace (boolean) */
+ tracefilenames = 1;
+ get_lua_boolean("texconfig", "trace_file_names", &tracefilenames);
+
+ /* src_special_xx */
+ insertsrcspecialauto = insertsrcspecialeverypar =
+ insertsrcspecialeveryparend = insertsrcspecialeverycr =
+ insertsrcspecialeverymath = insertsrcspecialeveryhbox =
+ insertsrcspecialeveryvbox = insertsrcspecialeverydisplay =
+ false;
+ get_lua_boolean("texconfig", "src_special_auto",
+ &insertsrcspecialauto);
+ get_lua_boolean("texconfig", "src_special_everypar",
+ &insertsrcspecialeverypar);
+ get_lua_boolean("texconfig", "src_special_everyparend",
+ &insertsrcspecialeveryparend);
+ get_lua_boolean("texconfig", "src_special_everycr",
+ &insertsrcspecialeverycr);
+ get_lua_boolean("texconfig", "src_special_everymath",
+ &insertsrcspecialeverymath);
+ get_lua_boolean("texconfig", "src_special_everyhbox",
+ &insertsrcspecialeveryhbox);
+ get_lua_boolean("texconfig", "src_special_everyvbox",
+ &insertsrcspecialeveryvbox);
+ get_lua_boolean("texconfig", "src_special_everydisplay",
+ &insertsrcspecialeverydisplay);
+
+ srcspecialsp = insertsrcspecialauto | insertsrcspecialeverypar |
+ insertsrcspecialeveryparend | insertsrcspecialeverycr |
+ insertsrcspecialeverymath | insertsrcspecialeveryhbox |
+ insertsrcspecialeveryvbox | insertsrcspecialeverydisplay;
+
+ /* file_line_error */
+ filelineerrorstylep = false;
+ get_lua_boolean("texconfig", "file_line_error",
+ &filelineerrorstylep);
+
+ /* halt_on_error */
+ haltonerrorp = false;
+ get_lua_boolean("texconfig", "halt_on_error", &haltonerrorp);
+
+ fix_dumpname();
+ } else {
+ if (luainit) {
+ if (given_file) {
+ fprintf(stdout, "%s file %s not found\n", (lua_only ? "Script" : "Configuration"), given_file);
+ } else {
+ fprintf(stdout, "No %s file given\n", (lua_only ? "script" : "configuration"));
+ }
+ exit(1);
+ } else {
+ /* init */
+ init_kpse();
+ fix_dumpname();
+ }
+ }
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/luanode.c b/Build/source/texk/web2c/luatexdir/lua/luanode.c
new file mode 100644
index 00000000000..17c8e7be8e2
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/luanode.c
@@ -0,0 +1,200 @@
+/* $Id: luanode.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "nodes.h"
+
+#undef link /* defined by cpascal.h */
+#define info(a) fixmem[(a)].hhlh
+#define link(a) fixmem[(a)].hhrh
+
+
+static char *group_code_names[] = {
+ "",
+ "simple",
+ "hbox",
+ "adjusted_hbox",
+ "vbox",
+ "vtop",
+ "align",
+ "no_align",
+ "output",
+ "math",
+ "disc",
+ "insert",
+ "vcenter",
+ "math_choice",
+ "semi_simple",
+ "math_shift",
+ "math_left",
+ "local_box" ,
+ "split_off",
+ "split_keep",
+ "preamble",
+ "align_set",
+ "fin_row"};
+
+char *pack_type_name[] = { "exactly", "additional"};
+
+
+void
+lua_node_filter_s (int filterid, char *extrainfo, halfword head_node, halfword *tail_node) {
+ halfword ret;
+ int a;
+ lua_State *L = Luas[0];
+ int callback_id = callback_defined(filterid);
+ if (head_node==null || vlink(head_node)==null || callback_id==0)
+ return;
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2);
+ return;
+ }
+ nodelist_to_lua(L,vlink(head_node)); /* arg 1 */
+ lua_pushstring(L,extrainfo); /* arg 2 */
+ if (lua_pcall(L,2,1,0) != 0) { /* no arg, 1 result */
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ error();
+ return;
+ }
+ if (lua_isboolean(L,-1)) {
+ if (lua_toboolean(L,-1)!=1) {
+ flush_node_list(vlink(head_node));
+ vlink(head_node) = null;
+ }
+ } else {
+ a = nodelist_from_lua(L);
+ vlink(head_node)= a;
+ }
+ lua_pop(L,2); /* result and callback container table */
+ if (fix_node_lists)
+ fix_node_list(head_node);
+ ret = vlink(head_node);
+ if (ret!=null) {
+ while (vlink(ret)!=null)
+ ret=vlink(ret);
+ *tail_node=ret;
+ } else {
+ *tail_node=head_node;
+ }
+ return ;
+}
+
+void
+lua_node_filter (int filterid, int extrainfo, halfword head_node, halfword *tail_node) {
+ lua_node_filter_s(filterid, group_code_names[extrainfo], head_node, tail_node);
+ return ;
+}
+
+
+
+halfword
+lua_hpack_filter (halfword head_node, scaled size, int pack_type, int extrainfo) {
+ halfword ret;
+ lua_State *L = Luas[0];
+ int callback_id = callback_defined(hpack_filter_callback);
+ if (head_node==null || callback_id == 0)
+ return head_node;
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2);
+ return head_node;
+ }
+
+ nodelist_to_lua(L,head_node);
+ lua_pushstring(L,group_code_names[extrainfo]);
+ lua_pushnumber(L,size);
+ lua_pushstring(L,pack_type_name[pack_type]);
+ if (lua_pcall(L,4,1,0) != 0) { /* no arg, 1 result */
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ error();
+ return head_node;
+ }
+ ret = head_node;
+ if (lua_isboolean(L,-1)) {
+ if (lua_toboolean(L,-1)!=1) {
+ flush_node_list(head_node);
+ ret = null;
+ }
+ } else {
+ ret = nodelist_from_lua(L);
+ }
+ lua_pop(L,2); /* result and callback container table */
+ /* lua_gc(L,LUA_GCSTEP, LUA_GC_STEP_SIZE);*/
+ if (fix_node_lists)
+ fix_node_list(ret);
+ return ret;
+}
+
+halfword
+lua_vpack_filter (halfword head_node, scaled size, int pack_type, scaled maxd, int extrainfo) {
+ halfword ret;
+ integer callback_id ;
+ lua_State *L = Luas[0];
+ if (head_node==null)
+ return head_node;
+ if (strcmp("output",group_code_names[extrainfo])==0) {
+ callback_id = callback_defined(pre_output_filter_callback);
+ } else {
+ callback_id = callback_defined(vpack_filter_callback);
+ }
+ if (callback_id==0) {
+ return head_node;
+ }
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2);
+ return head_node;
+ }
+ nodelist_to_lua(L,head_node);
+ lua_pushstring(L,group_code_names[extrainfo]);
+ lua_pushnumber(L,size);
+ lua_pushstring(L,pack_type_name[pack_type]);
+ lua_pushnumber(L,maxd);
+ if (lua_pcall(L,5,1,0) != 0) { /* no arg, 1 result */
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ error();
+ return head_node;
+ }
+ ret = head_node;
+ if (lua_isboolean(L,-1)) {
+ if (lua_toboolean(L,-1)!=1) {
+ flush_node_list(head_node);
+ ret = null;
+ }
+ } else {
+ ret = nodelist_from_lua(L);
+ }
+ lua_pop(L,2); /* result and callback container table */
+ /* lua_gc(L,LUA_GCSTEP, LUA_GC_STEP_SIZE);*/
+ if (fix_node_lists)
+ fix_node_list(ret);
+ return ret;
+}
+
+
+/* This is a quick hack to fix etex's \lastnodetype now that
+ * there are many more visible node types. TODO: check the
+ * eTeX manual for the expected return values.
+ */
+
+int
+visible_last_node_type (int n) {
+ int i = type(n);
+ if ((i!=math_node) && (i<=unset_node))
+ return i+1;
+ if (i==glyph_node)
+ return -1;
+ if (i==whatsit_node && subtype(n)==local_par_node)
+ return -1;
+ if (i==255)
+ return -1 ; /* this is not right, probably dir nodes! */
+ return last_known_node +1 ;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/luastuff.c b/Build/source/texk/web2c/luatexdir/lua/luastuff.c
new file mode 100644
index 00000000000..f48bfdb0171
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/luastuff.c
@@ -0,0 +1,310 @@
+/* $Id: luastuff.c 1079 2008-03-05 15:34:41Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+lua_State *Luas[65536];
+
+extern char *startup_filename;
+extern int safer_option;
+
+int luastate_max = 0;
+int luastate_bytes = 0;
+
+void
+make_table (lua_State *L, char *tab, char *getfunc, char *setfunc) {
+ /* make the table */ /* [{<tex>}] */
+ lua_pushstring(L,tab); /* [{<tex>},"dimen"] */
+ lua_newtable(L); /* [{<tex>},"dimen",{}] */
+ lua_settable(L, -3); /* [{<tex>}] */
+ /* fetch it back */
+ lua_pushstring(L,tab); /* [{<tex>},"dimen"] */
+ lua_gettable(L, -2); /* [{<tex>},{<dimen>}] */
+ /* make the meta entries */
+ luaL_newmetatable(L,tab); /* [{<tex>},{<dimen>},{<dimen_m>}] */
+ lua_pushstring(L, "__index"); /* [{<tex>},{<dimen>},{<dimen_m>},"__index"] */
+ lua_pushstring(L, getfunc); /* [{<tex>},{<dimen>},{<dimen_m>},"__index","getdimen"] */
+ lua_gettable(L, -5); /* [{<tex>},{<dimen>},{<dimen_m>},"__index",<tex.getdimen>] */
+ lua_settable(L, -3); /* [{<tex>},{<dimen>},{<dimen_m>}] */
+ lua_pushstring(L, "__newindex");/* [{<tex>},{<dimen>},{<dimen_m>},"__newindex"] */
+ lua_pushstring(L, setfunc); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex","setdimen"] */
+ lua_gettable(L, -5); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex",<tex.setdimen>] */
+ lua_settable(L, -3); /* [{<tex>},{<dimen>},{<dimen_m>}] */
+ lua_setmetatable(L,-2); /* [{<tex>},{<dimen>}] : assign the metatable */
+ lua_pop(L,1); /* [{<tex>}] : clean the stack */
+}
+
+static
+const char *getS(lua_State * L, void *ud, size_t * size) {
+ LoadS *ls = (LoadS *) ud;
+ (void) L;
+ if (ls->size == 0)
+ return NULL;
+ *size = ls->size;
+ ls->size = 0;
+ return ls->s;
+}
+
+void *my_luaalloc (void *ud, void *ptr, size_t osize, size_t nsize) {
+ void *ret = NULL;
+ if (nsize == 0)
+ free(ptr);
+ else
+ ret = realloc(ptr, nsize);
+ luastate_bytes += (nsize-osize);
+ return ret;
+}
+
+static int my_luapanic (lua_State *L) {
+ (void)L; /* to avoid warnings */
+ fprintf(stderr, "PANIC: unprotected error in call to Lua API (%s)\n",
+ lua_tostring(L, -1));
+ return 0;
+}
+
+
+void
+luainterpreter (int n) {
+ lua_State *L;
+ L = lua_newstate(my_luaalloc, NULL);
+ if (L==NULL) {
+ fprintf(stderr,"Can't create a new Lua state (%d).",n);
+ return;
+ }
+ lua_atpanic(L, &my_luapanic);
+
+ luastate_max++;
+ luaL_openlibs(L);
+
+ open_oslibext(L,safer_option);
+
+ lua_getglobal(L,"package");
+ lua_pushstring(L,"");
+ lua_setfield(L,-2,"cpath");
+ lua_pop(L,1); /* pop the table */
+
+ /*luaopen_unicode(L);*/
+ lua_pushcfunction(L, luaopen_unicode);
+ lua_pushstring(L, "unicode");
+ lua_call(L, 1, 0);
+
+ /*luaopen_zip(L);*/
+ lua_pushcfunction(L, luaopen_zip);
+ lua_pushstring(L, "zip");
+ lua_call(L, 1, 0);
+
+ /*luaopen_lpeg(L);*/
+ lua_pushcfunction(L, luaopen_lpeg);
+ lua_pushstring(L, "lpeg");
+ lua_call(L, 1, 0);
+
+ /*luaopen_md5(L);*/
+ lua_pushcfunction(L, luaopen_md5);
+ lua_pushstring(L, "md5");
+ lua_call(L, 1, 0);
+
+ /*luaopen_lfs(L);*/
+ lua_pushcfunction(L, luaopen_lfs);
+ lua_pushstring(L, "lfs");
+ lua_call(L, 1, 0);
+
+ /* zlib. slightly odd calling convention */
+ luaopen_zlib(L);
+ lua_setglobal(L,"zlib");
+ luaopen_gzip(L);
+ /* fontforge */
+ luaopen_ff(L);
+
+ luaopen_pdf(L);
+ luaopen_tex(L);
+ luaopen_token(L);
+ luaopen_node(L);
+ luaopen_texio(L);
+ luaopen_kpse(L);
+ if (n==0) {
+ luaopen_callback(L);
+ lua_createtable(L, 0, 0);
+ lua_setglobal(L, "texconfig");
+ }
+ luaopen_lua(L,n,startup_filename);
+ luaopen_stats(L);
+ luaopen_font(L);
+ luaopen_lang(L);
+
+ /* luaopen_img(L); */
+ lua_pushcfunction(L, luaopen_img);
+ lua_pushstring(L, "img");
+ lua_call(L, 1, 0);
+
+ luaopen_mp(L);
+
+ if (safer_option) {
+ /* disable some stuff if --safer */
+ (void)hide_lua_value(L, "os","execute");
+ (void)hide_lua_value(L, "os","rename");
+ (void)hide_lua_value(L, "os","remove");
+ (void)hide_lua_value(L, "io","popen");
+ /* make io.open only read files */
+ luaL_checkstack(L,2,"out of stack space");
+ lua_getglobal(L,"io");
+ lua_getfield(L,-1,"open_ro");
+ lua_setfield(L,-2,"open");
+ (void)hide_lua_value(L, "io","tmpfile");
+ (void)hide_lua_value(L, "io","output");
+ (void)hide_lua_value(L, "lfs","chdir");
+ (void)hide_lua_value(L, "lfs","lock");
+ (void)hide_lua_value(L, "lfs","touch");
+ (void)hide_lua_value(L, "lfs","rmdir");
+ (void)hide_lua_value(L, "lfs","mkdir");
+ }
+ Luas[n] = L;
+}
+
+int hide_lua_table(lua_State *L, char *name) {
+ int r=0;
+ lua_getglobal(L,name);
+ if(lua_istable(L,-1)) {
+ r = luaL_ref(L,LUA_REGISTRYINDEX);
+ lua_pushnil(L);
+ lua_setglobal(L,name);
+ }
+ return r;
+}
+
+void unhide_lua_table(lua_State *L, char *name, int r) {
+ lua_rawgeti(L,LUA_REGISTRYINDEX,r);
+ lua_setglobal(L,name);
+ luaL_unref(L,LUA_REGISTRYINDEX,r);
+}
+
+int hide_lua_value(lua_State *L, char *name, char *item) {
+ int r=0;
+ lua_getglobal(L,name);
+ if(lua_istable(L,-1)) {
+ lua_getfield(L,-1,item);
+ r = luaL_ref(L,LUA_REGISTRYINDEX);
+ lua_pushnil(L);
+ lua_setfield(L,-2,item);
+ }
+ return r;
+}
+
+void unhide_lua_value(lua_State *L, char *name, char *item, int r) {
+ lua_getglobal(L,name);
+ if(lua_istable(L,-1)) {
+ lua_rawgeti(L,LUA_REGISTRYINDEX,r);
+ lua_setfield(L,-2,item);
+ luaL_unref(L,LUA_REGISTRYINDEX,r);
+ }
+}
+
+
+void
+luacall(int n, int s) {
+ LoadS ls;
+ int i ;
+ char lua_id[12];
+ if (Luas[n] == NULL) {
+ luainterpreter(n);
+ }
+ luatex_load_init(s,&ls);
+ if (ls.size>0) {
+ snprintf((char *)lua_id,12,"luas[%d]",n);
+ i = lua_load(Luas[n], getS, &ls, lua_id);
+ if (i != 0) {
+ Luas[n] = luatex_error(Luas[n],(i == LUA_ERRSYNTAX ? 0 : 1));
+ } else {
+ i = lua_pcall(Luas[n], 0, 0, 0);
+ if (i != 0) {
+ Luas[n] = luatex_error(Luas[n],(i == LUA_ERRRUN ? 0 : 1));
+ }
+ }
+ }
+}
+
+void
+luatokencall(int n, int p) {
+ LoadS ls;
+ int i, l;
+ char *s=NULL;
+ char lua_id[12];
+ if (Luas[n] == NULL) {
+ luainterpreter(n);
+ }
+ l = 0;
+ s = tokenlist_to_cstring(p,1,&l);
+ ls.s = s;
+ ls.size = l;
+ if (ls.size>0) {
+ snprintf((char *)lua_id,12,"luas[%d]",n);
+ i = lua_load(Luas[n], getS, &ls, lua_id);
+ xfree(s);
+ if (i != 0) {
+ Luas[n] = luatex_error(Luas[n],(i == LUA_ERRSYNTAX ? 0 : 1));
+ } else {
+ i = lua_pcall(Luas[n], 0, 0, 0);
+ if (i != 0) {
+ Luas[n] = luatex_error(Luas[n],(i == LUA_ERRRUN ? 0 : 1));
+ }
+ }
+ }
+}
+
+
+
+void
+closelua(int n) {
+ if (n!=0 && Luas[n] != NULL) {
+ lua_close(Luas[n]);
+ luastate_max--;
+ Luas[n] = NULL;
+ }
+}
+
+
+void
+luatex_load_init (int s, LoadS *ls) {
+ ls->s = (const char *)&(str_pool[str_start[s]]);
+ ls->size = str_start[s + 1] - str_start[s];
+}
+
+lua_State *
+luatex_error (lua_State * L, int is_fatal) {
+
+ size_t len;
+ char *err;
+ strnumber s;
+ const char *luaerr = lua_tolstring(L, -1,&len);
+ err = (char *)xmalloc(len+1);
+ len = snprintf(err,(len+1),"%s",luaerr);
+ if (is_fatal>0) {
+ /* Normally a memory error from lua.
+ The pool may overflow during the maketexlstring(), but we
+ are crashing anyway so we may as well abort on the pool size */
+ s = maketexlstring(err, len);
+ lua_fatal_error(s);
+ /* never reached */
+ xfree (err);
+ lua_close(L);
+ luastate_max--;
+ return (lua_State *)NULL;
+ } else {
+ /* Here, the pool could be full already, but we can possibly escape from that
+ * condition, since the lua chunk that caused the error is the current string.
+ */
+ s = str_ptr-0x200000;
+ /* fprintf(stderr,"poolinfo: %d: %d,%d out of %d\n",s,pool_ptr,str_start[(s-1)],pool_size);*/
+ pool_ptr = str_start[(s-1)];
+ str_start[s] = pool_ptr;
+ if (pool_ptr+len>=pool_size) {
+ lua_norm_error(' ');
+ } else {
+ s = maketexlstring(err,len);
+ lua_norm_error(s);
+ flush_str(s);
+ }
+ xfree (err);
+ return L;
+ }
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/luatex.c b/Build/source/texk/web2c/luatexdir/lua/luatex.c
new file mode 100644
index 00000000000..5172ca24292
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/luatex.c
@@ -0,0 +1,343 @@
+/* $Id: luatex.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include <zlib.h>
+
+/* do this aleph stuff here, for now */
+
+void
+b_test_in(void)
+{
+ string fname = kpse_find_file ((char *)(nameoffile + 1),
+ kpse_program_binary_format, true);
+
+ if (fname) {
+ libcfree(nameoffile);
+ nameoffile = xmalloc(2+strlen(fname));
+ namelength = strlen(fname);
+ strcpy((char *)nameoffile+1, fname);
+ }
+ else {
+ libcfree(nameoffile);
+ nameoffile = xmalloc(2);
+ namelength = 0;
+ nameoffile[0] = 0;
+ nameoffile[1] = 0;
+ }
+}
+
+
+int **ocp_tables;
+static int ocp_entries = 0;
+
+void
+allocate_ocp_table P2C(int, ocp_number, int, ocp_size)
+{
+ int i;
+ if (ocp_entries==0) {
+ ocp_tables = (int **) xmalloc(256*sizeof(int**));
+ ocp_entries=256;
+ } else if ((ocp_number==256)&&(ocp_entries==256)) {
+ ocp_tables = xrealloc(ocp_tables, 65536);
+ ocp_entries=65536;
+ }
+ ocp_tables[ocp_number] =
+ (int *) xmalloc((1+ocp_size)*sizeof(int));
+ ocp_tables[ocp_number][0] = ocp_size;
+ for (i=1; i<=ocp_size; i++) {
+ ocp_tables[ocp_number][i] = 0;
+ }
+}
+
+void
+dump_ocp_table P1C(int, ocp_number)
+{
+ dump_things(ocp_tables[ocp_number][0], ocp_tables[ocp_number][0]+1);
+}
+
+void
+undump_ocp_table P1C(int, ocp_number)
+{
+ int sizeword;
+ if (ocp_entries==0) {
+ ocp_tables = (int **) xmalloc(256*sizeof(int**));
+ ocp_entries=256;
+ } else if ((ocp_number==256)&&(ocp_entries==256)) {
+ ocp_tables = xrealloc(ocp_tables, 65536);
+ ocp_entries=65536;
+ }
+ undump_things(sizeword,1);
+ ocp_tables[ocp_number] =
+ (int *) xmalloc((1+sizeword)*sizeof(int));
+ ocp_tables[ocp_number][0] = sizeword;
+ undump_things(ocp_tables[ocp_number][1], sizeword);
+}
+
+
+void
+run_external_ocp P1C(string, external_ocp_name)
+{
+ char *in_file_name;
+ char *out_file_name;
+ FILE *in_file;
+ FILE *out_file;
+ char command_line[400];
+ int i;
+ unsigned c;
+ int c_in;
+#ifdef WIN32
+ char *tempenv;
+
+#define null_string(s) ((s == NULL) || (*s == '\0'))
+
+ tempenv = getenv("TMPDIR");
+ if (null_string(tempenv))
+ tempenv = getenv("TEMP");
+ if (null_string(tempenv))
+ tempenv = getenv("TMP");
+ if (null_string(tempenv))
+ tempenv = "c:/tmp"; /* "/tmp" is not good if we are on a CD-ROM */
+ in_file_name = concat(tempenv, "/__aleph__in__XXXXXX");
+ mktemp(in_file_name);
+#else
+ in_file_name = strdup("/tmp/__aleph__in__XXXXXX");
+ mkstemp(in_file_name);
+#endif /* WIN32 */
+
+ in_file = fopen(in_file_name, FOPEN_WBIN_MODE);
+
+ for (i=1; i<=otp_input_end; i++) {
+ c = otp_input_buf[i];
+ if (c>0xffff) {
+ fprintf(stderr, "Aleph does not currently support 31-bit chars\n");
+ exit(1);
+ }
+ if (c>0x4000000) {
+ fputc(0xfc | ((c>>30) & 0x1), in_file);
+ fputc(0x80 | ((c>>24) & 0x3f), in_file);
+ fputc(0x80 | ((c>>18) & 0x3f), in_file);
+ fputc(0x80 | ((c>>12) & 0x3f), in_file);
+ fputc(0x80 | ((c>>6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c>0x200000) {
+ fputc(0xf8 | ((c>>24) & 0x3), in_file);
+ fputc(0x80 | ((c>>18) & 0x3f), in_file);
+ fputc(0x80 | ((c>>12) & 0x3f), in_file);
+ fputc(0x80 | ((c>>6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c>0x10000) {
+ fputc(0xf0 | ((c>>18) & 0x7), in_file);
+ fputc(0x80 | ((c>>12) & 0x3f), in_file);
+ fputc(0x80 | ((c>>6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c>0x800) {
+ fputc(0xe0 | ((c>>12) & 0xf), in_file);
+ fputc(0x80 | ((c>>6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c>0x80) {
+ fputc(0xc0 | ((c>>6) & 0x1f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else {
+ fputc(c & 0x7f, in_file);
+ }
+ }
+ fclose(in_file);
+
+#define advance_cin if ((c_in = fgetc(out_file)) == -1) { \
+ fprintf(stderr, "File contains bad char\n"); \
+ goto end_of_while; \
+ }
+
+#ifdef WIN32
+ out_file_name = concat(tempenv, "/__aleph__out__XXXXXX");
+ mktemp(out_file_name);
+#else
+ out_file_name = strdup("/tmp/__aleph__out__XXXXXX");
+ mkstemp(out_file_name);
+#endif
+
+ sprintf(command_line, "%s <%s >%s\n",
+ external_ocp_name+1, in_file_name, out_file_name);
+ system(command_line);
+ out_file = fopen(out_file_name, FOPEN_RBIN_MODE);
+ otp_output_end = 0;
+ otp_output_buf[otp_output_end] = 0;
+ while ((c_in = fgetc(out_file)) != -1) {
+ if (c_in>=0xfc) {
+ c = (c_in & 0x1) << 30;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 24;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 18;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 12;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 6;
+ {advance_cin}
+ c |= c_in & 0x3f;
+ } else if (c_in>=0xf8) {
+ c = (c_in & 0x3) << 24;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 18;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 12;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 6;
+ {advance_cin}
+ c |= c_in & 0x3f;
+ } else if (c_in>=0xf0) {
+ c = (c_in & 0x7) << 18;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 12;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 6;
+ {advance_cin}
+ c |= c_in & 0x3f;
+ } else if (c_in>=0xe0) {
+ c = (c_in & 0xf) << 12;
+ {advance_cin}
+ c |= (c_in & 0x3f) << 6;
+ {advance_cin}
+ c |= c_in & 0x3f;
+ } else if (c_in>=0x80) {
+ c = (c_in & 0x1f) << 6;
+ {advance_cin}
+ c |= c_in & 0x3f;
+ } else {
+ c = c_in & 0x7f;
+ }
+ otp_output_buf[++otp_output_end] = c;
+ }
+
+end_of_while:
+ remove(in_file_name);
+ remove(out_file_name);
+}
+
+/* Read and write dump files through zlib */
+
+/* Earlier versions recast *f from FILE * to gzFile, but there is
+ * no guarantee that these have the same size, so a static variable
+ * is needed.
+ */
+
+static gzFile gz_fmtfile = NULL;
+
+void
+do_zdump (char *p, int item_size, int nitems, FILE *out_file)
+{
+ int err;
+ if (nitems==0)
+ return;
+ if (gzwrite (gz_fmtfile,(void *)p, item_size*nitems) != item_size*nitems)
+ {
+ fprintf (stderr, "! Could not write %d %d-byte item(s): %s.\n",
+ nitems, item_size, gzerror(gz_fmtfile,&err));
+ uexit (1);
+ }
+}
+
+void
+do_zundump (char *p, int item_size, int nitems, FILE *in_file)
+{
+ int err;
+ if (nitems==0)
+ return;
+ if (gzread (gz_fmtfile,(void *)p, item_size*nitems) <= 0)
+ {
+ fprintf (stderr, "Could not undump %d %d-byte item(s): %s.\n",
+ nitems, item_size, gzerror(gz_fmtfile,&err));
+ uexit (1);
+ }
+}
+
+#define COMPRESSION "R3"
+
+boolean
+zopen_w_input (FILE **f, int format, const_string fopen_mode) {
+ int callbackid;
+ int res;
+ char *fnam;
+ callbackid = callback_defined(find_format_file_callback);
+ if (callbackid>0) {
+ res = run_callback(callbackid,"S->S",(nameoffile+1),&fnam);
+ if (res && fnam && strlen(fnam)>0) {
+ xfree (nameoffile);
+ nameoffile = xmalloc (strlen(fnam)+2);
+ memcpy((nameoffile+1),fnam,strlen(fnam));
+ *(nameoffile+strlen(fnam)+1)=0;
+ *f = xfopen(fnam,fopen_mode);
+ if (*f == NULL) {
+ return 0;
+ }
+ } else {
+ return 0;
+ }
+ } else {
+ res = open_input(f,format,fopen_mode);
+ }
+ if (res) {
+ gz_fmtfile = gzdopen(fileno(*f),"rb" COMPRESSION);
+ }
+ return res;
+}
+
+boolean
+zopen_w_output (FILE **f, const_string fopen_mode) {
+ int res = 1;
+ if (luainit) {
+ *f = fopen((nameoffile+1),fopen_mode);
+ if (*f == NULL) {
+ return 0;
+ }
+ } else {
+ res = open_output(f,fopen_mode);
+ }
+ if (res) {
+ gz_fmtfile = gzdopen(fileno(*f),"wb" COMPRESSION);
+ }
+ return res;
+}
+
+void
+zwclose (FILE *f) {
+ gzclose(gz_fmtfile);
+}
+
+/* create the dvi or pdf file */
+
+int
+open_outfile(FILE **f, char *name, char *mode) {
+ FILE *res;
+ res = fopen(name,mode);
+ if (res != NULL) {
+ *f = res;
+ return 1;
+ }
+ return 0;
+}
+
+
+/* the caller sets tfm_buffer=NULL and tfm_size=0 */
+
+int
+readbinfile (FILE *f, unsigned char **tfm_buffer, integer *tfm_size) {
+ void *buf;
+ int size;
+ if (fseek(f, 0, SEEK_END)==0) {
+ size = ftell(f);
+ if (size>0) {
+ buf = xmalloc(size);
+ if(fseek(f, 0, SEEK_SET)==0) {
+ if(fread((void *)buf,size,1,f)==1) {
+ *tfm_buffer=(unsigned char *)buf;
+ *tfm_size=(integer)size;
+ return 1;
+ }
+ }
+ }
+ } /* seek failed, or zero-sized file */
+ return 0;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/luatoken.c b/Build/source/texk/web2c/luatexdir/lua/luatoken.c
new file mode 100644
index 00000000000..23d9ca82150
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/luatoken.c
@@ -0,0 +1,548 @@
+/* $Id: luatoken.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include "tokens.h"
+
+command_item command_names[] =
+ { { "relax", 0, NULL },
+ { "left_brace", 0 , NULL },
+ { "right_brace", 0 , NULL },
+ { "math_shift", 0 , NULL },
+ { "tab_mark", 0 , NULL },
+ { "car_ret", 0 , NULL },
+ { "mac_param", 0 , NULL },
+ { "sup_mark", 0 , NULL },
+ { "sub_mark", 0 , NULL },
+ { "endv", 0 , NULL },
+ { "spacer", 0 , NULL },
+ { "letter", 0 , NULL },
+ { "other_char", 0 , NULL },
+ { "par_end", 0 , NULL },
+ { "stop", 0 , NULL },
+ { "delim_num", 0 , NULL },
+ { "char_num", 0 , NULL },
+ { "math_char_num", 0 , NULL },
+ { "mark", 0 , NULL },
+ { "xray", 0 , NULL },
+ { "make_box", 0 , NULL },
+ { "hmove", 0 , NULL },
+ { "vmove", 0 , NULL },
+ { "un_hbox", 0 , NULL },
+ { "un_vbox", 0 , NULL },
+ { "remove_item", 0 , NULL },
+ { "hskip", 0 , NULL },
+ { "vskip", 0 , NULL },
+ { "mskip", 0 , NULL },
+ { "kern", 0 , NULL },
+ { "mkern", 0 , NULL },
+ { "leader_ship", 0 , NULL },
+ { "halign", 0 , NULL },
+ { "valign", 0 , NULL },
+ { "no_align", 0 , NULL },
+ { "vrule", 0 , NULL },
+ { "hrule", 0 , NULL },
+ { "insert", 0 , NULL },
+ { "vadjust", 0 , NULL },
+ { "ignore_spaces", 0 , NULL },
+ { "after_assignment", 0 , NULL },
+ { "after_group", 0 , NULL },
+ { "break_penalty", 0 , NULL },
+ { "start_par", 0 , NULL },
+ { "ital_corr", 0 , NULL },
+ { "accent", 0 , NULL },
+ { "math_accent", 0 , NULL },
+ { "discretionary", 0 , NULL },
+ { "eq_no", 0 , NULL },
+ { "left_right", 0 , NULL },
+ { "math_comp", 0 , NULL },
+ { "limit_switch", 0 , NULL },
+ { "above", 0 , NULL },
+ { "math_style", 0 , NULL },
+ { "math_choice", 0 , NULL },
+ { "non_script", 0 , NULL },
+ { "vcenter", 0 , NULL },
+ { "case_shift", 0 , NULL },
+ { "message", 0 , NULL },
+ { "extension", 0 , NULL },
+ { "in_stream", 0 , NULL },
+ { "begin_group", 0 , NULL },
+ { "end_group", 0 , NULL },
+ { "omit", 0 , NULL },
+ { "ex_space", 0 , NULL },
+ { "no_boundary", 0 , NULL },
+ { "radical", 0 , NULL },
+ { "end_cs_name", 0 , NULL },
+ { "char_ghost", 0 , NULL },
+ { "assign_local_box", 0 , NULL },
+ { "char_given", 0 , NULL },
+ { "math_given", 0 , NULL },
+ { "omath_given", 0 , NULL },
+ { "last_item", 0 , NULL },
+ { "toks_register", 0 , NULL },
+ { "assign_toks", 0, NULL },
+ { "assign_int", 0, NULL },
+ { "assign_dimen", 0 , NULL },
+ { "assign_glue", 0 ,NULL },
+ { "assign_mu_glue", 0 , NULL },
+ { "assign_font_dimen", 0 , NULL },
+ { "assign_font_int", 0 , NULL },
+ { "set_aux", 0 , NULL },
+ { "set_prev_graf", 0 , NULL },
+ { "set_page_dimen", 0 , NULL },
+ { "set_page_int", 0 , NULL },
+ { "set_box_dimen", 0 , NULL },
+ { "set_shape", 0, NULL },
+ { "def_code", 0 , NULL },
+ { "extdef_code", 0 , NULL },
+ { "def_family", 0 , NULL },
+ { "set_font", 0 , NULL },
+ { "def_font", 0 , NULL },
+ { "register", 0 , NULL },
+ { "assign_box_dir", 0 , NULL },
+ { "assign_dir", 0 , NULL },
+ { "advance", 0 , NULL },
+ { "multiply", 0 , NULL },
+ { "divide", 0 , NULL },
+ { "prefix", 0 , NULL },
+ { "let", 0 , NULL }, /* 100 */
+ { "shorthand_def", 0 , NULL },
+ { "read_to_cs", 0 , NULL },
+ { "def", 0 , NULL },
+ { "set_box", 0 , NULL },
+ { "hyph_data", 0 , NULL },
+ { "set_interaction", 0 , NULL },
+ { "letterspace_font", 0 , NULL },
+ { "set_ocp", 0 , NULL },
+ { "def_ocp", 0 , NULL },
+ { "set_ocp_list", 0 , NULL }, /* 110 */
+ { "def_ocp_list", 0 , NULL },
+ { "clear_ocp_lists", 0 , NULL },
+ { "push_ocp_list", 0 , NULL },
+ { "pop_ocp_list", 0 , NULL },
+ { "ocp_list_op", 0 , NULL },
+ { "ocp_trace_level", 0 , NULL},
+ { "undefined_cs", 0 , NULL },
+ { "expand_after", 0 , NULL },
+ { "no_expand", 0 , NULL },
+ { "input", 0 , NULL }, /* 120 */
+ { "if_test", 0 , NULL },
+ { "fi_or_else", 0 , NULL },
+ { "cs_name", 0 , NULL },
+ { "convert", 0 , NULL },
+ { "the", 0 , NULL },
+ { "top_bot_mark", 0 , NULL },
+ { "call", 0 , NULL },
+ { "long_call", 0 , NULL },
+ { "outer_call", 0 , NULL },
+ { "long_outer_call", 0 , NULL }, /* 130 */
+ { "end_template", 0 , NULL },
+ { "dont_expand", 0, NULL },
+ { "glue_ref", 0 , NULL },
+ { "shape_ref", 0 , NULL },
+ { "box_ref", 0 , NULL },
+ { "data", 0 , NULL },
+ { NULL, 0, NULL } };
+
+
+int get_command_id (char *s) {
+ int i;
+ int cmd = -1;
+ for (i=0;command_names[i].cmd_name != NULL;i++) {
+ if (strcmp(s,command_names[i].cmd_name) == 0)
+ break;
+ }
+ if (command_names[i].cmd_name!=NULL) {
+ cmd = i;
+ }
+ return cmd;
+}
+
+static int
+get_cur_cmd (lua_State *L) {
+ int r = 0;
+ cur_cs = 0;
+ int len = lua_objlen(L,-1);
+ if (len==3 || len==2) {
+ r = 1;
+ lua_rawgeti(L,-1,1);
+ cur_cmd = lua_tointeger(L,-1);
+ lua_rawgeti(L,-2,2);
+ cur_chr = lua_tointeger(L,-1);
+ if (len==3) {
+ lua_rawgeti(L,-3,3);
+ cur_cs = lua_tointeger(L,-1);
+ }
+ lua_pop(L,len);
+ if (cur_cs==0)
+ cur_tok=(cur_cmd*string_offset)+cur_chr;
+ else
+ cur_tok=cs_token_flag+cur_cs;
+ }
+ return r;
+}
+
+
+static int
+token_from_lua (lua_State *L) {
+ int cmd,chr;
+ int cs = 0;
+ int len = lua_objlen(L,-1);
+ if (len==3 || len==2) {
+ lua_rawgeti(L,-1,1);
+ cmd = lua_tointeger(L,-1);
+ lua_rawgeti(L,-2,2);
+ chr = lua_tointeger(L,-1);
+ if (len==3) {
+ lua_rawgeti(L,-3,3);
+ cs = lua_tointeger(L,-1);
+ }
+ lua_pop(L,len);
+ if (cs==0) {
+ return (cmd*string_offset)+chr;
+ } else {
+ return cs_token_flag+cs;
+ }
+ }
+ return -1;
+}
+
+static int
+get_cur_cs (lua_State *L) {
+ char *s;
+ unsigned j;
+ size_t l;
+ integer cs;
+ int save_nncs;
+ int ret;
+ ret = 0;
+ cur_cs = 0;
+ lua_getfield(L,-1,"name");
+ if (lua_isstring(L,-1)) {
+ s = (char *)lua_tolstring(L,-1,&l);
+ if (l>0) {
+ if (last+l>buf_size)
+ check_buffer_overflow(last+l);
+ for (j=0;j<l;j++) {
+ buffer[last+1+j]=*s++;
+ }
+ save_nncs = no_new_control_sequence;
+ no_new_control_sequence = false;
+ cs = id_lookup((last+1),l);
+ cur_tok = cs_token_flag+cs;
+ cur_cmd = zget_eq_type(cs);
+ cur_chr = zget_equiv(cs);
+ no_new_control_sequence = save_nncs;
+ ret = 1;
+ }
+ }
+ lua_pop(L,1);
+ return ret;
+}
+
+
+#define append_i_byte(a) { \
+ if ((i+2)>alloci) { \
+ ret = xrealloc(ret,alloci+64); \
+ alloci = alloci + 64; } \
+ ret[i++] = a; }
+
+#define Print_char(a) append_i_byte(a)
+
+#define Print_uchar(s) { \
+ if (s<=0x7F) { \
+ Print_char(s); \
+ } else if (s<=0x7FF) { \
+ Print_char(0xC0 + (s / 0x40)); \
+ Print_char(0x80 + (s % 0x40)); \
+ } else if (s<=0xFFFF) { \
+ Print_char(0xE0 + (s / 0x1000)); \
+ Print_char(0x80 + ((s % 0x1000) / 0x40)); \
+ Print_char(0x80 + ((s % 0x1000) % 0x40)); \
+ } else if (s>=0x10FF00) { \
+ Print_char(s-0x10FF00); \
+ } else { \
+ Print_char(0xF0 + (s / 0x40000)); \
+ Print_char(0x80 + ((s % 0x40000) / 0x1000)); \
+ Print_char(0x80 + (((s % 0x40000) % 0x1000) / 0x40)); \
+ Print_char(0x80 + (((s % 0x40000) % 0x1000) % 0x40)); \
+ } }
+
+
+#define Print_esc(b) { if (e>0 && e<string_offset) { Print_uchar (e); Print_uchar (e); } \
+ { char *v = b; while (*v) { Print_char(*v); v++; } } }
+
+#define single_letter(a) (length(a)==1)|| \
+ ((length(a)==4)&&(str_pool[str_start_macro(a)]>=0xF0))|| \
+ ((length(a)==3)&&(str_pool[str_start_macro(a)]>=0xE0))|| \
+ ((length(a)==2)&&(str_pool[str_start_macro(a)]>=0xC0))
+
+#define is_cat_letter(a) \
+ (get_char_cat_code(pool_to_unichar(str_start_macro(a))) == 11)
+
+static int active_base = 0;
+static int hash_base = 0;
+static int eqtb_size = 0;
+static int null_cs = 0;
+static int undefined_control_sequence;
+
+char *
+tokenlist_to_cstring ( int p , int inhibit_par, int *siz) {
+ integer m, c ;
+ integer q;
+ char *s;
+ int e;
+ char *ret=NULL;
+ int match_chr = '#';
+ int n = '0';
+ int alloci = 0;
+ int i = 0;
+ if (p==null || link(p)==null) {
+ if (siz!=NULL)
+ *siz = 0;
+ return NULL;
+ }
+ p = link(p); /* skip refcount */
+ if (active_base==0) {
+ active_base = get_active_base();
+ hash_base = get_hash_base();
+ null_cs = get_nullcs();
+ eqtb_size = get_eqtb_size();
+ undefined_control_sequence = get_undefined_control_sequence();
+ }
+ e = get_escape_char();
+ while ( p != null ) {
+ if (p < fix_mem_min || p > fix_mem_end ) {
+ Print_esc ("CLOBBERED.") ;
+ break;
+ }
+ if (info(p)>=cs_token_flag) {
+ if ( ! (inhibit_par && info(p)==par_token) ) {
+ q = info(p) - cs_token_flag;
+ if (q<hash_base) {
+ if (q==null_cs) {
+ /* Print_esc("csname"); Print_esc("endcsname"); */
+ } else {
+ if (q<active_base) {
+ Print_esc("IMPOSSIBLE.");
+ } else {
+ Print_uchar(q-active_base);
+ }
+ }
+ } else if ((q>=undefined_control_sequence)&&((q<=eqtb_size))||(q>eqtb_size+hash_extra)) {
+ Print_esc("IMPOSSIBLE.");
+ } else if ((zget_cs_text(q)<0)||(zget_cs_text(q)>=str_ptr)) {
+ Print_esc("NONEXISTENT.");
+ } else {
+ Print_uchar (e);
+ s = makecstring(zget_cs_text(q));
+ while (*s) { Print_char(*s); s++; }
+ if ((! single_letter(zget_cs_text(q))) || is_cat_letter(zget_cs_text(q))) {
+ Print_char(' ');
+ }
+ }
+ }
+ } else {
+ m=info(p) / string_offset;
+ c=info(p) % string_offset;
+ if ( info(p) < 0 ) {
+ Print_esc ( "BAD.") ;
+ } else {
+ switch ( m ) {
+ case 6 : /* falls through */
+ Print_uchar ( c ) ;
+ case 1 :
+ case 2 :
+ case 3 :
+ case 4 :
+ case 7 :
+ case 8 :
+ case 10 :
+ case 11 :
+ case 12 :
+ Print_uchar ( c ) ;
+ break ;
+ case 5 :
+ Print_uchar ( match_chr ) ;
+ if ( c <= 9 ) {
+ Print_char ( c + '0') ;
+ } else {
+ Print_char ( '!' ) ;
+ return NULL;
+ }
+ break ;
+ case 13 :
+ match_chr = c ;
+ Print_uchar ( c ) ;
+ incr ( n ) ;
+ Print_char ( n ) ;
+ if ( n > '9' )
+ return NULL;
+ break ;
+ case 14 :
+ if ( c == 0 ) {
+ Print_char ('-');
+ Print_char ('>') ;
+ }
+ break ;
+ default:
+ Print_esc ( "BAD.") ;
+ break ;
+ }
+ }
+ }
+ p = link(p);
+ }
+ ret[i]=0;
+ if (siz!=NULL)
+ *siz = i;
+ return ret;
+}
+
+
+void
+tokenlist_to_lua(lua_State *L, int p) {
+ int cmd,chr,cs;
+ int v;
+ int i = 1;
+ v = p;
+ while (v!=null && v < fix_mem_end) { i++; v = link(v); }
+ i = 1;
+ lua_createtable(L,i,0);
+ while (p!=null&& p < fix_mem_end) {
+ if (info(p)>=cs_token_flag) {
+ cs=info(p)-cs_token_flag;
+ cmd = zget_eq_type(cs);
+ chr = zget_equiv(cs);
+ make_token_table(L,cmd,chr,cs);
+ } else {
+ cmd=info(p) / string_offset;
+ chr=info(p) % string_offset;
+ make_token_table(L,cmd,chr,0);
+ }
+ lua_rawseti(L,-2,i++);
+ p = link(p);
+ }
+}
+
+
+void
+tokenlist_to_luastring(lua_State *L, int p) {
+ int l;
+ char *s;
+ s = tokenlist_to_cstring(p,1,&l);
+ lua_pushlstring(L,s,l);
+}
+
+
+int
+tokenlist_from_lua(lua_State *L) {
+ char *s;
+ int tok,i;
+ size_t j;
+ halfword p,q,r;
+ r = get_avail();
+ info(r)=0; /* ref count */
+ link(r)=null;
+ p = r;
+ if (lua_istable(L,-1)) {
+ j = lua_objlen(L,-1);
+ if (j>0) {
+ for (i=1;i<=j;i++) {
+ lua_rawgeti(L,-1,i);
+ tok = token_from_lua(L);
+ if (tok>=0) {
+ store_new_token(tok);
+ }
+ lua_pop(L,1);
+ };
+ }
+ return r;
+ } else if (lua_isstring(L,-1)) {
+ s = (char *)lua_tolstring(L,-1,&j);
+ for (i=0;i<j;i++) {
+ if (s[i] == 32) {
+ tok = (10*string_offset)+s[i];
+ } else {
+ tok = (12*string_offset)+s[i];
+ }
+ store_new_token(tok);
+ }
+ return r;
+ } else {
+ free_avail(r);
+ return null;
+ }
+}
+
+void
+do_get_token_lua (integer callback_id) {
+ lua_State *L = Luas[0];
+
+ lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
+ while (1) {
+ lua_rawgeti(L,-1, callback_id);
+ if (!lua_isfunction(L,-1)) {
+ lua_pop(L,2); /* the not-a-function callback and the container */
+ get_next();
+ return;
+ }
+ if (lua_pcall(L,0,1,0) != 0) { /* no arg, 1 result */
+ fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
+ lua_pop(L,2);
+ error();
+ return;
+ }
+ if (lua_istable(L,-1)) {
+ lua_rawgeti(L,-1,1);
+ if (lua_istable(L,-1)) {
+ integer p,q,r;
+ int i,j;
+ lua_pop(L,1);
+ /* build a token list */
+ r = get_avail();
+ p = r;
+ j = lua_objlen(L,-1);
+ if (j>0) {
+ for (i=1;i<=j;i++) {
+ lua_rawgeti(L,-1,i);
+ if (get_cur_cmd(L) || get_cur_cs(L)) {
+ store_new_token(cur_tok);
+ }
+ lua_pop(L,1);
+ }
+ }
+ if (p!=r) {
+ p = link(r);
+ free_avail(r);
+ begin_token_list(p, inserted);
+ cur_input.nofilter_field=true;
+ get_next();
+ lua_pop(L,1);
+ break;
+ } else {
+ fprintf(stdout,"error: illegal or empty token list returned\n");
+ lua_pop(L,2);
+ error();
+ return;
+ }
+ } else {
+ lua_pop(L,1);
+ if (get_cur_cmd(L) || get_cur_cs(L)) {
+ lua_pop(L,1);
+ break;
+ } else {
+ lua_pop(L,2);
+ continue;
+ }
+ }
+ } else {
+ lua_pop(L,1);
+ continue;
+ }
+ }
+ lua_pop(L,1); /* callback container */
+ return;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/mp.w b/Build/source/texk/web2c/luatexdir/lua/mp.w
new file mode 100644
index 00000000000..a459cc48fe1
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/mp.w
@@ -0,0 +1,26173 @@
+% $Id: mp.web,v 1.8 2005/08/24 10:54:02 taco Exp $
+% MetaPost, by John Hobby. Public domain.
+
+% Much of this program was copied with permission from MF.web Version 1.9
+% It interprets a language very similar to D.E. Knuth's METAFONT, but with
+% changes designed to make it more suitable for PostScript output.
+
+% TeX is a trademark of the American Mathematical Society.
+% METAFONT is a trademark of Addison-Wesley Publishing Company.
+% PostScript is a trademark of Adobe Systems Incorporated.
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\noindent\ignorespaces}
+\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
+\def\ps{PostScript}
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+\def\k{_{k+1}}
+\def\pct!{{\char`\%}} % percent sign in ordinary text
+\font\tenlogo=logo10 % font used for the METAFONT logo
+\font\logos=logosl10
+\def\MF{{\tenlogo META}\-{\tenlogo FONT}}
+\def\MP{{\tenlogo META}\-{\tenlogo POST}}
+\def\[#1]{\ignorespaces} % left over from pascal web
+\def\<#1>{$\langle#1\rangle$}
+\def\section{\mathhexbox278}
+\let\swap=\leftrightarrow
+\def\round{\mathop{\rm round}\nolimits}
+\mathchardef\vb="026A % synonym for `\|'
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+\def\title{MetaPost}
+\pdfoutput=1
+\pageno=3
+
+@* \[1] Introduction.
+
+This is \MP, a graphics-language processor based on D. E. Knuth's \MF.
+
+The main purpose of the following program is to explain the algorithms of \MP\
+as clearly as possible. However, the program has been written so that it
+can be tuned to run efficiently in a wide variety of operating environments
+by making comparatively few changes. Such flexibility is possible because
+the documentation that follows is written in the \.{WEB} language, which is
+at a higher level than C.
+
+A large piece of software like \MP\ has inherent complexity that cannot
+be reduced below a certain level of difficulty, although each individual
+part is fairly simple by itself. The \.{WEB} language is intended to make
+the algorithms as readable as possible, by reflecting the way the
+individual program pieces fit together and by providing the
+cross-references that connect different parts. Detailed comments about
+what is going on, and about why things were done in certain ways, have
+been liberally sprinkled throughout the program. These comments explain
+features of the implementation, but they rarely attempt to explain the
+\MP\ language itself, since the reader is supposed to be familiar with
+{\sl The {\logos METAFONT\/}book} as well as the manual
+@.WEB@>
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+{\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
+AT\AM T Bell Laboratories.
+
+@ The present implementation is a preliminary version, but the possibilities
+for new features are limited by the desire to remain as nearly compatible
+with \MF\ as possible.
+
+On the other hand, the \.{WEB} description can be extended without changing
+the core of the program, and it has been designed so that such
+extensions are not extremely difficult to make.
+The |banner| string defined here should be changed whenever \MP\
+undergoes any modifications, so that it will be clear which version of
+\MP\ might be the guilty party when a problem arises.
+@^extensions to \MP@>
+@^system dependencies@>
+
+@d banner "This is MetaPost, Version 1.003" /* printed when \MP\ starts */
+@d metapost_version "1.003"
+@d mplib_version "0.30"
+@d version_string " (Cweb version 0.30)"
+
+@d true 1
+@d false 0
+
+@ The external library header for \MP\ is |mplib.h|. It contains a
+few typedefs and the header defintions for the externally used
+fuctions.
+
+The most important of the typedefs is the definition of the structure
+|MP_options|, that acts as a small, configurable front-end to the fairly
+large |MP_instance| structure.
+
+@(mplib.h@>=
+typedef struct MP_instance * MP;
+@<Exported types@>
+typedef struct MP_options {
+ @<Option variables@>
+} MP_options;
+@<Exported function headers@>
+
+@ The internal header file is much longer: it not only lists the complete
+|MP_instance|, but also a lot of functions that have to be available to
+the \ps\ backend, that is defined in a separate \.{WEB} file.
+
+The variables from |MP_options| are included inside the |MP_instance|
+wholesale.
+
+@(mpmp.h@>=
+#include <setjmp.h>
+typedef struct psout_data_struct * psout_data;
+typedef int boolean;
+typedef signed int integer;
+@<Declare helpers@>
+@<Types in the outer block@>
+@<Constants in the outer block@>
+# ifndef LIBAVL_ALLOCATOR
+# define LIBAVL_ALLOCATOR
+ struct libavl_allocator {
+ void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
+ void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
+ };
+# endif
+typedef struct MP_instance {
+ @<Option variables@>
+ @<Global variables@>
+} MP_instance;
+@<Internal library declarations@>
+
+@ @c
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <unistd.h> /* for access() */
+#include <time.h> /* for struct tm \& co */
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+@h
+@<Declarations@>
+@<Basic printing procedures@>
+@<Error handling procedures@>
+
+@ Here are the functions that set up the \MP\ instance.
+
+@<Declarations@> =
+@<Declare |mp_reallocate| functions@>
+struct MP_options *mp_options (void);
+MP mp_new (struct MP_options *opt);
+
+@ @c
+struct MP_options *mp_options (void) {
+ struct MP_options *opt;
+ opt = malloc(sizeof(MP_options));
+ if (opt!=NULL) {
+ memset (opt,0,sizeof(MP_options));
+ }
+ return opt;
+}
+
+@ The |__attribute__| pragma is gcc-only.
+
+@<Internal library ... @>=
+#if !defined(__GNUC__) || (__GNUC__ < 2)
+# define __attribute__(x)
+#endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
+
+@ @c
+MP __attribute__ ((noinline))
+mp_new (struct MP_options *opt) {
+ MP mp;
+ mp = malloc(1*sizeof(MP_instance));
+ if (mp==NULL)
+ return mp;
+ @<Set |ini_version|@>;
+ @<Setup the non-local jump buffer in |mp_new|@>;
+ @<Allocate or initialize variables@>
+ if (opt->main_memory>mp->mem_max)
+ mp_reallocate_memory(mp,opt->main_memory);
+ mp_reallocate_paths(mp,1000);
+ mp_reallocate_fonts(mp,8);
+ return mp;
+}
+
+@ @c
+void mp_free (MP mp) {
+ int k; /* loop variable */
+ @<Dealloc variables@>
+ xfree(mp);
+}
+
+@ @c
+void __attribute__((noinline))
+mp_do_initialize ( MP mp) {
+ @<Local variables for initialization@>
+ @<Set initial values of key variables@>
+}
+int mp_initialize (MP mp) { /* this procedure gets things started properly */
+ mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
+ @<Install and test the non-local jump buffer@>;
+ t_open_out; /* open the terminal for output */
+ @<Check the ``constant'' values...@>;
+ if ( mp->bad>0 ) {
+ char ss[256];
+ snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
+ "---case %i",(int)mp->bad);
+ do_fprintf(mp->err_out,(char *)ss);
+@.Ouch...clobbered@>
+ return mp->history;
+ }
+ mp_do_initialize(mp); /* erase preloaded mem */
+ if (mp->ini_version) {
+ @<Run inimpost commands@>;
+ }
+ @<Initialize the output routines@>;
+ @<Get the first line of input and prepare to start@>;
+ mp_set_job_id(mp);
+ mp_init_map_file(mp, mp->troff_mode);
+ mp->history=mp_spotless; /* ready to go! */
+ if (mp->troff_mode) {
+ mp->internal[mp_gtroffmode]=unity;
+ mp->internal[mp_prologues]=unity;
+ }
+ if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
+ mp->cur_sym=mp->start_sym; mp_back_input(mp);
+ }
+ return mp->history;
+}
+
+@
+@<Exported function headers@>=
+extern struct MP_options *mp_options (void);
+extern MP mp_new (struct MP_options *opt) ;
+extern void mp_free (MP mp);
+extern int mp_initialize (MP mp);
+
+@ The overall \MP\ program begins with the heading just shown, after which
+comes a bunch of procedure declarations and function declarations.
+Finally we will get to the main program, which begins with the
+comment `|start_here|'. If you want to skip down to the
+main program now, you can look up `|start_here|' in the index.
+But the author suggests that the best way to understand this program
+is to follow pretty much the order of \MP's components as they appear in the
+\.{WEB} description you are now reading, since the present ordering is
+intended to combine the advantages of the ``bottom up'' and ``top down''
+approaches to the problem of understanding a somewhat complicated system.
+
+@ Some of the code below is intended to be used only when diagnosing the
+strange behavior that sometimes occurs when \MP\ is being installed or
+when system wizards are fooling around with \MP\ without quite knowing
+what they are doing. Such code will not normally be compiled; it is
+delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
+
+@ This program has two important variations: (1) There is a long and slow
+version called \.{INIMP}, which does the extra calculations needed to
+@.INIMP@>
+initialize \MP's internal tables; and (2)~there is a shorter and faster
+production version, which cuts the initialization to a bare minimum.
+
+Which is which is decided at runtime.
+
+@ The following parameters can be changed at compile time to extend or
+reduce \MP's capacity. They may have different values in \.{INIMP} and
+in production versions of \MP.
+@.INIMP@>
+@^system dependencies@>
+
+@<Constants...@>=
+#define file_name_size 255 /* file names shouldn't be longer than this */
+#define bistack_size 1500 /* size of stack for bisection algorithms;
+ should probably be left at this value */
+
+@ Like the preceding parameters, the following quantities can be changed
+at compile time to extend or reduce \MP's capacity. But if they are changed,
+it is necessary to rerun the initialization program \.{INIMP}
+@.INIMP@>
+to generate new tables for the production \MP\ program.
+One can't simply make helter-skelter changes to the following constants,
+since certain rather complex initialization
+numbers are computed from them.
+
+@ @<Glob...@>=
+int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
+int pool_size; /* maximum number of characters in strings, including all
+ error messages and help texts, and the names of all identifiers */
+int mem_max; /* greatest index in \MP's internal |mem| array;
+ must be strictly less than |max_halfword|;
+ must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
+int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
+ must not be greater than |mem_max| */
+
+@ @<Option variables@>=
+int error_line; /* width of context lines on terminal error messages */
+int half_error_line; /* width of first lines of contexts in terminal
+ error messages; should be between 30 and |error_line-15| */
+int max_print_line; /* width of longest text lines output; should be at least 60 */
+int hash_size; /* maximum number of symbolic tokens,
+ must be less than |max_halfword-3*param_size| */
+int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
+int param_size; /* maximum number of simultaneous macro parameters */
+int max_in_open; /* maximum number of input files and error insertions that
+ can be going on simultaneously */
+int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
+void *userdata; /* this allows the calling application to setup local */
+
+@
+@d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
+
+@<Allocate or ...@>=
+mp->max_strings=500;
+mp->pool_size=10000;
+set_value(mp->error_line,opt->error_line,79);
+set_value(mp->half_error_line,opt->half_error_line,50);
+set_value(mp->max_print_line,opt->max_print_line,100);
+mp->main_memory=5000;
+mp->mem_max=5000;
+mp->mem_top=5000;
+set_value(mp->hash_size,opt->hash_size,9500);
+set_value(mp->hash_prime,opt->hash_prime,7919);
+set_value(mp->param_size,opt->param_size,150);
+set_value(mp->max_in_open,opt->max_in_open,10);
+mp->userdata=opt->userdata;
+
+@ In case somebody has inadvertently made bad settings of the ``constants,''
+\MP\ checks them using a global variable called |bad|.
+
+This is the first of many sections of \MP\ where global variables are
+defined.
+
+@<Glob...@>=
+integer bad; /* is some ``constant'' wrong? */
+
+@ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
+or something similar. (We can't do that until |max_halfword| has been defined.)
+
+@<Check the ``constant'' values for consistency@>=
+mp->bad=0;
+if ( (mp->half_error_line<30)||(mp->half_error_line>mp->error_line-15) ) mp->bad=1;
+if ( mp->max_print_line<60 ) mp->bad=2;
+if ( mp->mem_top<=1100 ) mp->bad=4;
+if (mp->hash_prime>mp->hash_size ) mp->bad=5;
+
+@ Some |goto| labels are used by the following definitions. The label
+`|restart|' is occasionally used at the very beginning of a procedure; and
+the label `|reswitch|' is occasionally used just prior to a |case|
+statement in which some cases change the conditions and we wish to branch
+to the newly applicable case. Loops that are set up with the |loop|
+construction defined below are commonly exited by going to `|done|' or to
+`|found|' or to `|not_found|', and they are sometimes repeated by going to
+`|continue|'. If two or more parts of a subroutine start differently but
+end up the same, the shared code may be gathered together at
+`|common_ending|'.
+
+@ Here are some macros for common programming idioms.
+
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+@d negate(A) (A)=-(A) /* change the sign of a variable */
+@d double(A) (A)=(A)+(A)
+@d odd(A) ((A)%2==1)
+@d chr(A) (A)
+@d do_nothing /* empty statement */
+@d Return goto exit /* terminate a procedure call */
+@f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
+
+@* \[2] The character set.
+In order to make \MP\ readily portable to a wide variety of
+computers, all of its input text is converted to an internal eight-bit
+code that includes standard ASCII, the ``American Standard Code for
+Information Interchange.'' This conversion is done immediately when each
+character is read in. Conversely, characters are converted from ASCII to
+the user's external representation just before they are output to a
+text file.
+@^ASCII code@>
+
+Such an internal code is relevant to users of \MP\ only with respect to
+the \&{char} and \&{ASCII} operations, and the comparison of strings.
+
+@ Characters of text that have been converted to \MP's internal form
+are said to be of type |ASCII_code|, which is a subrange of the integers.
+
+@<Types...@>=
+typedef unsigned char ASCII_code; /* eight-bit numbers */
+
+@ The present specification of \MP\ has been written under the assumption
+that the character set contains at least the letters and symbols associated
+with ASCII codes 040 through 0176; all of these characters are now
+available on most computer terminals.
+
+We shall use the name |text_char| to stand for the data type of the characters
+that are converted to and from |ASCII_code| when they are input and output.
+We shall also assume that |text_char| consists of the elements
+|chr(first_text_char)| through |chr(last_text_char)|, inclusive.
+The following definitions should be adjusted if necessary.
+@^system dependencies@>
+
+@d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
+@d last_text_char 255 /* ordinal number of the largest element of |text_char| */
+
+@<Types...@>=
+typedef unsigned char text_char; /* the data type of characters in text files */
+
+@ @<Local variables for init...@>=
+integer i;
+
+@ The \MP\ processor converts between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to Pascal's |ord| and |chr| functions.
+
+@d xchr(A) mp->xchr[(A)]
+@d xord(A) mp->xord[(A)]
+
+@<Glob...@>=
+ASCII_code xord[256]; /* specifies conversion of input characters */
+text_char xchr[256]; /* specifies conversion of output characters */
+
+@ The core system assumes all 8-bit is acceptable. If it is not,
+a change file has to alter the below section.
+@^system dependencies@>
+
+Additionally, people with extended character sets can
+assign codes arbitrarily, giving an |xchr| equivalent to whatever
+characters the users of \MP\ are allowed to have in their input files.
+Appropriate changes to \MP's |char_class| table should then be made.
+(Unlike \TeX, each installation of \MP\ has a fixed assignment of category
+codes, called the |char_class|.) Such changes make portability of programs
+more difficult, so they should be introduced cautiously if at all.
+@^character set dependencies@>
+@^system dependencies@>
+
+@<Set initial ...@>=
+for (i=0;i<=0377;i++) { xchr(i)=i; }
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
+where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
+|j| or more; hence, standard ASCII code numbers will be used instead of
+codes below 040 in case there is a coincidence.
+
+@<Set initial ...@>=
+for (i=first_text_char;i<=last_text_char;i++) {
+ xord(chr(i))=0177;
+}
+for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
+for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
+
+@* \[3] Input and output.
+The bane of portability is the fact that different operating systems treat
+input and output quite differently, perhaps because computer scientists
+have not given sufficient attention to this problem. People have felt somehow
+that input and output are not part of ``real'' programming. Well, it is true
+that some kinds of programming are more fun than others. With existing
+input/output conventions being so diverse and so messy, the only sources of
+joy in such parts of the code are the rare occasions when one can find a
+way to make the program a little less bad than it might have been. We have
+two choices, either to attack I/O now and get it over with, or to postpone
+I/O until near the end. Neither prospect is very attractive, so let's
+get it over with.
+
+The basic operations we need to do are (1)~inputting and outputting of
+text, to or from a file or the user's terminal; (2)~inputting and
+outputting of eight-bit bytes, to or from a file; (3)~instructing the
+operating system to initiate (``open'') or to terminate (``close'') input or
+output from a specified file; (4)~testing whether the end of an input
+file has been reached; (5)~display of bits on the user's screen.
+The bit-display operation will be discussed in a later section; we shall
+deal here only with more traditional kinds of I/O.
+
+@ Finding files happens in a slightly roundabout fashion: the \MP\
+instance object contains a field that holds a function pointer that finds a
+file, and returns its name, or NULL. For this, it receives three
+parameters: the non-qualified name |fname|, the intended |fopen|
+operation type |fmode|, and the type of the file |ftype|.
+
+The file types that are passed on in |ftype| can be used to
+differentiate file searches if a library like kpathsea is used,
+the fopen mode is passed along for the same reason.
+
+@<Types...@>=
+typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
+
+@ @<Exported types@>=
+enum mp_filetype {
+ mp_filetype_terminal = 0, /* the terminal */
+ mp_filetype_error, /* the terminal */
+ mp_filetype_program , /* \MP\ language input */
+ mp_filetype_log, /* the log file */
+ mp_filetype_postscript, /* the postscript output */
+ mp_filetype_memfile, /* memory dumps */
+ mp_filetype_metrics, /* TeX font metric files */
+ mp_filetype_fontmap, /* PostScript font mapping files */
+ mp_filetype_font, /* PostScript type1 font programs */
+ mp_filetype_encoding, /* PostScript font encoding files */
+ mp_filetype_text /* first text file for readfrom and writeto primitives */
+};
+typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
+typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
+typedef char *(*mp_file_reader)(MP, void *, size_t *);
+typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
+typedef void (*mp_file_closer)(MP, void *);
+typedef int (*mp_file_eoftest)(MP, void *);
+typedef void (*mp_file_flush)(MP, void *);
+typedef void (*mp_file_writer)(MP, void *, const char *);
+typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
+#define NOTTESTING 1
+
+@ @<Option variables@>=
+mp_file_finder find_file;
+mp_file_opener open_file;
+mp_file_reader read_ascii_file;
+mp_binfile_reader read_binary_file;
+mp_file_closer close_file;
+mp_file_eoftest eof_file;
+mp_file_flush flush_file;
+mp_file_writer write_ascii_file;
+mp_binfile_writer write_binary_file;
+
+@ The default function for finding files is |mp_find_file|. It is
+pretty stupid: it will only find files in the current directory.
+
+This function may disappear altogether, it is currently only
+used for the default font map file.
+
+@c
+char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
+ (void) mp;
+ if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
+ return strdup(fname);
+ }
+ return NULL;
+}
+
+@ This has to be done very early on, so it is best to put it in with
+the |mp_new| allocations
+
+@d set_callback_option(A) do { mp->A = mp_##A;
+ if (opt->A!=NULL) mp->A = opt->A;
+} while (0)
+
+@<Allocate or initialize ...@>=
+set_callback_option(find_file);
+set_callback_option(open_file);
+set_callback_option(read_ascii_file);
+set_callback_option(read_binary_file);
+set_callback_option(close_file);
+set_callback_option(eof_file);
+set_callback_option(flush_file);
+set_callback_option(write_ascii_file);
+set_callback_option(write_binary_file);
+
+@ Because |mp_find_file| is used so early, it has to be in the helpers
+section.
+
+@<Internal ...@>=
+char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
+void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
+char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
+void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
+void mp_close_file (MP mp, void *f) ;
+int mp_eof_file (MP mp, void *f) ;
+void mp_flush_file (MP mp, void *f) ;
+void mp_write_ascii_file (MP mp, void *f, const char *s) ;
+void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
+
+@ The function to open files can now be very short.
+
+@c
+void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
+ char realmode[3];
+ (void) mp;
+ realmode[0] = *fmode;
+ realmode[1] = 'b';
+ realmode[2] = 0;
+#if NOTTESTING
+ if (ftype==mp_filetype_terminal) {
+ return (fmode[0] == 'r' ? stdin : stdout);
+ } else if (ftype==mp_filetype_error) {
+ return stderr;
+ } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
+ return (void *)fopen(fname, realmode);
+ }
+#endif
+ return NULL;
+}
+
+@ This is a legacy interface: (almost) all file names pass through |name_of_file|.
+
+@<Glob...@>=
+char name_of_file[file_name_size+1]; /* the name of a system file */
+int name_length;/* this many characters are actually
+ relevant in |name_of_file| (the rest are blank) */
+
+@ @<Option variables@>=
+int print_found_names; /* configuration parameter */
+
+@ If this parameter is true, the terminal and log will report the found
+file names for input files instead of the requested ones.
+It is off by default because it creates an extra filename lookup.
+
+@<Allocate or initialize ...@>=
+mp->print_found_names = (opt->print_found_names>0 ? true : false);
+
+@ \MP's file-opening procedures return |false| if no file identified by
+|name_of_file| could be opened.
+
+The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
+It is not used for opening a mem file for read, because that file name
+is never printed.
+
+@d OPEN_FILE(A) do {
+ if (mp->print_found_names) {
+ char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
+ if (s!=NULL) {
+ *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
+ strncpy(mp->name_of_file,s,file_name_size);
+ xfree(s);
+ } else {
+ *f = NULL;
+ }
+ } else {
+ *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
+ }
+} while (0);
+return (*f ? true : false)
+
+@c
+boolean mp_a_open_in (MP mp, void **f, int ftype) {
+ /* open a text file for input */
+ OPEN_FILE("r");
+}
+@#
+boolean mp_w_open_in (MP mp, void **f) {
+ /* open a word file for input */
+ *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
+ return (*f ? true : false);
+}
+@#
+boolean mp_a_open_out (MP mp, void **f, int ftype) {
+ /* open a text file for output */
+ OPEN_FILE("w");
+}
+@#
+boolean mp_b_open_out (MP mp, void **f, int ftype) {
+ /* open a binary file for output */
+ OPEN_FILE("w");
+}
+@#
+boolean mp_w_open_out (MP mp, void **f) {
+ /* open a word file for output */
+ int ftype = mp_filetype_memfile;
+ OPEN_FILE("w");
+}
+
+@ @c
+char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
+ int c;
+ size_t len = 0, lim = 128;
+ char *s = NULL;
+ FILE *f = (FILE *)ff;
+ *size = 0;
+ (void) mp; /* for -Wunused */
+#if NOTTESTING
+ c = fgetc(f);
+ if (c==EOF)
+ return NULL;
+ s = malloc(lim);
+ if (s==NULL) return NULL;
+ while (c!=EOF && c!='\n' && c!='\r') {
+ if (len==lim) {
+ s =realloc(s, (lim+(lim>>2)));
+ if (s==NULL) return NULL;
+ lim+=(lim>>2);
+ }
+ s[len++] = c;
+ c =fgetc(f);
+ }
+ if (c=='\r') {
+ c = fgetc(f);
+ if (c!=EOF && c!='\n')
+ ungetc(c,f);
+ }
+ s[len] = 0;
+ *size = len;
+#endif
+ return s;
+}
+
+@ @c
+void mp_write_ascii_file (MP mp, void *f, const char *s) {
+ (void) mp;
+#if NOTTESTING
+ if (f!=NULL) {
+ fputs(s,(FILE *)f);
+ }
+#endif
+}
+
+@ @c
+void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
+ size_t len = 0;
+ (void) mp;
+#if NOTTESTING
+ len = fread(*data,1,*size,(FILE *)f);
+#endif
+ *size = len;
+}
+
+@ @c
+void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
+ (void) mp;
+#if NOTTESTING
+ if (f!=NULL)
+ fwrite(s,size,1,(FILE *)f);
+#endif
+}
+
+
+@ @c
+void mp_close_file (MP mp, void *f) {
+ (void) mp;
+#if NOTTESTING
+ fclose((FILE *)f);
+#endif
+}
+
+@ @c
+int mp_eof_file (MP mp, void *f) {
+ (void) mp;
+#if NOTTESTING
+ return feof((FILE *)f);
+#else
+ return 0;
+#endif
+}
+
+@ @c
+void mp_flush_file (MP mp, void *f) {
+ (void) mp;
+#if NOTTESTING
+ fflush((FILE *)f);
+#endif
+}
+
+@ Input from text files is read one line at a time, using a routine called
+|input_ln|. This function is defined in terms of global variables called
+|buffer|, |first|, and |last| that will be described in detail later; for
+now, it suffices for us to know that |buffer| is an array of |ASCII_code|
+values, and that |first| and |last| are indices into this array
+representing the beginning and ending of a line of text.
+
+@<Glob...@>=
+size_t buf_size; /* maximum number of characters simultaneously present in
+ current lines of open files */
+ASCII_code *buffer; /* lines of characters being read */
+size_t first; /* the first unused position in |buffer| */
+size_t last; /* end of the line just input to |buffer| */
+size_t max_buf_stack; /* largest index used in |buffer| */
+
+@ @<Allocate or initialize ...@>=
+mp->buf_size = 200;
+mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
+
+@ @<Dealloc variables@>=
+xfree(mp->buffer);
+
+@ @c
+void mp_reallocate_buffer(MP mp, size_t l) {
+ ASCII_code *buffer;
+ if (l>max_halfword) {
+ mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
+ }
+ buffer = xmalloc((l+1),sizeof(ASCII_code));
+ memcpy(buffer,mp->buffer,(mp->buf_size+1));
+ xfree(mp->buffer);
+ mp->buffer = buffer ;
+ mp->buf_size = l;
+}
+
+@ The |input_ln| function brings the next line of input from the specified
+field into available positions of the buffer array and returns the value
+|true|, unless the file has already been entirely read, in which case it
+returns |false| and sets |last:=first|. In general, the |ASCII_code|
+numbers that represent the next line of the file are input into
+|buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
+global variable |last| is set equal to |first| plus the length of the
+line. Trailing blanks are removed from the line; thus, either |last=first|
+(in which case the line was entirely blank) or |buffer[last-1]<>" "|.
+@^inner loop@>
+
+The variable |max_buf_stack|, which is used to keep track of how large
+the |buf_size| parameter must be to accommodate the present job, is
+also kept up to date by |input_ln|.
+
+@c
+boolean mp_input_ln (MP mp, void *f ) {
+ /* inputs the next line or returns |false| */
+ char *s;
+ size_t size = 0;
+ mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
+ s = (mp->read_ascii_file)(mp,f, &size);
+ if (s==NULL)
+ return false;
+ if (size>0) {
+ mp->last = mp->first+size;
+ if ( mp->last>=mp->max_buf_stack ) {
+ mp->max_buf_stack=mp->last+1;
+ while ( mp->max_buf_stack>=mp->buf_size ) {
+ mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
+ }
+ }
+ memcpy((mp->buffer+mp->first),s,size);
+ /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
+ }
+ free(s);
+ return true;
+}
+
+@ The user's terminal acts essentially like other files of text, except
+that it is used both for input and for output. When the terminal is
+considered an input file, the file variable is called |term_in|, and when it
+is considered an output file the file variable is |term_out|.
+@^system dependencies@>
+
+@<Glob...@>=
+void * term_in; /* the terminal as an input file */
+void * term_out; /* the terminal as an output file */
+void * err_out; /* the terminal as an output file */
+
+@ Here is how to open the terminal files. In the default configuration,
+nothing happens except that the command line (if there is one) is copied
+to the input buffer. The variable |command_line| will be filled by the
+|main| procedure. The copying can not be done earlier in the program
+logic because in the |INI| version, the |buffer| is also used for primitive
+initialization.
+
+@^system dependencies@>
+
+@d t_open_out do {/* open the terminal for text output */
+ mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
+ mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
+} while (0)
+@d t_open_in do { /* open the terminal for text input */
+ mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
+ if (mp->command_line!=NULL) {
+ mp->last = strlen(mp->command_line);
+ strncpy((char *)mp->buffer,mp->command_line,mp->last);
+ xfree(mp->command_line);
+ } else {
+ mp->last = 0;
+ }
+} while (0)
+
+@d t_close_out do { /* close the terminal */
+ (mp->close_file)(mp,mp->term_out);
+ (mp->close_file)(mp,mp->err_out);
+} while (0)
+
+@d t_close_in do { /* close the terminal */
+ (mp->close_file)(mp,mp->term_in);
+} while (0)
+
+@<Option variables@>=
+char *command_line;
+
+@ @<Allocate or initialize ...@>=
+mp->command_line = xstrdup(opt->command_line);
+
+@ Sometimes it is necessary to synchronize the input/output mixture that
+happens on the user's terminal, and three system-dependent
+procedures are used for this
+purpose. The first of these, |update_terminal|, is called when we want
+to make sure that everything we have output to the terminal so far has
+actually left the computer's internal buffers and been sent.
+The second, |clear_terminal|, is called when we wish to cancel any
+input that the user may have typed ahead (since we are about to
+issue an unexpected error message). The third, |wake_up_terminal|,
+is supposed to revive the terminal if the user has disabled it by
+some instruction to the operating system. The following macros show how
+these operations can be specified:
+@^system dependencies@>
+
+@d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
+@d clear_terminal do_nothing /* clear the terminal input buffer */
+@d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
+ /* cancel the user's cancellation of output */
+
+@ We need a special routine to read the first line of \MP\ input from
+the user's terminal. This line is different because it is read before we
+have opened the transcript file; there is sort of a ``chicken and
+egg'' problem here. If the user types `\.{input cmr10}' on the first
+line, or if some macro invoked by that line does such an \.{input},
+the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
+commands are performed during the first line of terminal input, the transcript
+file will acquire its default name `\.{mpout.log}'. (The transcript file
+will not contain error messages generated by the first line before the
+first \.{input} command.)
+
+The first line is even more special. It's nice to let the user start
+running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
+such a case, \MP\ will operate as if the first line of input were
+`\.{cmr10}', i.e., the first line will consist of the remainder of the
+command line, after the part that invoked \MP.
+
+@ Different systems have different ways to get started. But regardless of
+what conventions are adopted, the routine that initializes the terminal
+should satisfy the following specifications:
+
+\yskip\textindent{1)}It should open file |term_in| for input from the
+ terminal. (The file |term_out| will already be open for output to the
+ terminal.)
+
+\textindent{2)}If the user has given a command line, this line should be
+ considered the first line of terminal input. Otherwise the
+ user should be prompted with `\.{**}', and the first line of input
+ should be whatever is typed in response.
+
+\textindent{3)}The first line of input, which might or might not be a
+ command line, should appear in locations |first| to |last-1| of the
+ |buffer| array.
+
+\textindent{4)}The global variable |loc| should be set so that the
+ character to be read next by \MP\ is in |buffer[loc]|. This
+ character should not be blank, and we should have |loc<last|.
+
+\yskip\noindent(It may be necessary to prompt the user several times
+before a non-blank line comes in. The prompt is `\.{**}' instead of the
+later `\.*' because the meaning is slightly different: `\.{input}' need
+not be typed immediately after~`\.{**}'.)
+
+@d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
+
+@ The following program does the required initialization
+without retrieving a possible command line.
+It should be clear how to modify this routine to deal with command lines,
+if the system permits them.
+@^system dependencies@>
+
+@c
+boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
+ t_open_in;
+ if (mp->last!=0) {
+ loc = mp->first = 0;
+ return true;
+ }
+ while (1) {
+ if (!mp->noninteractive) {
+ wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
+@.**@>
+ }
+ if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
+ do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
+@.End of file on the terminal@>
+ return false;
+ }
+ loc=mp->first;
+ while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
+ incr(loc);
+ if ( loc<(int)mp->last ) {
+ return true; /* return unless the line was all blank */
+ }
+ if (!mp->noninteractive) {
+ do_fprintf(mp->term_out,"Please type the name of your input file.\n");
+ }
+ }
+}
+
+@ @<Declarations@>=
+boolean mp_init_terminal (MP mp) ;
+
+
+@* \[4] String handling.
+Symbolic token names and diagnostic messages are variable-length strings
+of eight-bit characters. Many strings \MP\ uses are simply literals
+in the compiled source, like the error messages and the names of the
+internal parameters. Other strings are used or defined from the \MP\ input
+language, and these have to be interned.
+
+\MP\ uses strings more extensively than \MF\ does, but the necessary
+operations can still be handled with a fairly simple data structure.
+The array |str_pool| contains all of the (eight-bit) ASCII codes in all
+of the strings, and the array |str_start| contains indices of the starting
+points of each string. Strings are referred to by integer numbers, so that
+string number |s| comprises the characters |str_pool[j]| for
+|str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
+is allocated sequentially and |str_pool[pool_ptr]| is the next unused
+location. The first string number not currently in use is |str_ptr|
+and |next_str[str_ptr]| begins a list of free string numbers. String
+pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
+string currently being constructed.
+
+String numbers 0 to 255 are reserved for strings that correspond to single
+ASCII characters. This is in accordance with the conventions of \.{WEB},
+@.WEB@>
+which converts single-character strings into the ASCII code number of the
+single character involved, while it converts other strings into integers
+and builds a string pool file. Thus, when the string constant \.{"."} appears
+in the program below, \.{WEB} converts it into the integer 46, which is the
+ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
+into some integer greater than~255. String number 46 will presumably be the
+single character `\..'\thinspace; but some ASCII codes have no standard visible
+representation, and \MP\ may need to be able to print an arbitrary
+ASCII character, so the first 256 strings are used to specify exactly what
+should be printed for each of the 256 possibilities.
+
+@<Types...@>=
+typedef int pool_pointer; /* for variables that point into |str_pool| */
+typedef int str_number; /* for variables that point into |str_start| */
+
+@ @<Glob...@>=
+ASCII_code *str_pool; /* the characters */
+pool_pointer *str_start; /* the starting pointers */
+str_number *next_str; /* for linking strings in order */
+pool_pointer pool_ptr; /* first unused position in |str_pool| */
+str_number str_ptr; /* number of the current string being created */
+pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
+str_number init_str_use; /* the initial number of strings in use */
+pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
+str_number max_str_ptr; /* the maximum so far of |str_ptr| */
+
+@ @<Allocate or initialize ...@>=
+mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
+mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
+mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
+
+@ @<Dealloc variables@>=
+xfree(mp->str_pool);
+xfree(mp->str_start);
+xfree(mp->next_str);
+
+@ Most printing is done from |char *|s, but sometimes not. Here are
+functions that convert an internal string into a |char *| for use
+by the printing routines, and vice versa.
+
+@d str(A) mp_str(mp,A)
+@d rts(A) mp_rts(mp,A)
+
+@<Internal ...@>=
+int mp_xstrcmp (const char *a, const char *b);
+char * mp_str (MP mp, str_number s);
+
+@ @<Declarations@>=
+str_number mp_rts (MP mp, const char *s);
+str_number mp_make_string (MP mp);
+
+@ The attempt to catch interrupted strings that is in |mp_rts|, is not
+very good: it does not handle nesting over more than one level.
+
+@c
+int mp_xstrcmp (const char *a, const char *b) {
+ if (a==NULL && b==NULL)
+ return 0;
+ if (a==NULL)
+ return -1;
+ if (b==NULL)
+ return 1;
+ return strcmp(a,b);
+}
+
+@ @c
+char * mp_str (MP mp, str_number ss) {
+ char *s;
+ int len;
+ if (ss==mp->str_ptr) {
+ return NULL;
+ } else {
+ len = length(ss);
+ s = xmalloc(len+1,sizeof(char));
+ strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
+ s[len] = 0;
+ return (char *)s;
+ }
+}
+str_number mp_rts (MP mp, const char *s) {
+ int r; /* the new string */
+ int old; /* a possible string in progress */
+ int i=0;
+ if (strlen(s)==0) {
+ return 256;
+ } else if (strlen(s)==1) {
+ return s[0];
+ } else {
+ old=0;
+ str_room((integer)strlen(s));
+ if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
+ old = mp_make_string(mp);
+ while (*s) {
+ append_char(*s);
+ s++;
+ }
+ r = mp_make_string(mp);
+ if (old!=0) {
+ str_room(length(old));
+ while (i<length(old)) {
+ append_char((mp->str_start[old]+i));
+ }
+ mp_flush_string(mp,old);
+ }
+ return r;
+ }
+}
+
+@ Except for |strs_used_up|, the following string statistics are only
+maintained when code between |stat| $\ldots$ |tats| delimiters is not
+commented out:
+
+@<Glob...@>=
+integer strs_used_up; /* strings in use or unused but not reclaimed */
+integer pool_in_use; /* total number of cells of |str_pool| actually in use */
+integer strs_in_use; /* total number of strings actually in use */
+integer max_pl_used; /* maximum |pool_in_use| so far */
+integer max_strs_used; /* maximum |strs_in_use| so far */
+
+@ Several of the elementary string operations are performed using \.{WEB}
+macros instead of functions, because many of the
+operations are done quite frequently and we want to avoid the
+overhead of procedure calls. For example, here is
+a simple macro that computes the length of a string.
+@.WEB@>
+
+@d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
+ number \# */
+@d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
+
+@ The length of the current string is called |cur_length|. If we decide that
+the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
+|cur_length| becomes zero.
+
+@d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
+@d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
+
+@ Strings are created by appending character codes to |str_pool|.
+The |append_char| macro, defined here, does not check to see if the
+value of |pool_ptr| has gotten too high; this test is supposed to be
+made before |append_char| is used.
+
+To test if there is room to append |l| more characters to |str_pool|,
+we shall write |str_room(l)|, which tries to make sure there is enough room
+by compacting the string pool if necessary. If this does not work,
+|do_compaction| aborts \MP\ and gives an apologetic error message.
+
+@d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
+{ mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
+}
+@d str_room(A) /* make sure that the pool hasn't overflowed */
+ { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
+ if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
+ else mp->max_pool_ptr=mp->pool_ptr+(A); }
+ }
+
+@ The following routine is similar to |str_room(1)| but it uses the
+argument |mp->pool_size| to prevent |do_compaction| from aborting when
+string space is exhausted.
+
+@<Declare the procedure called |unit_str_room|@>=
+void mp_unit_str_room (MP mp);
+
+@ @c
+void mp_unit_str_room (MP mp) {
+ if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
+ if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
+}
+
+@ \MP's string expressions are implemented in a brute-force way: Every
+new string or substring that is needed is simply copied into the string pool.
+Space is eventually reclaimed by a procedure called |do_compaction| with
+the aid of a simple system system of reference counts.
+@^reference counts@>
+
+The number of references to string number |s| will be |str_ref[s]|. The
+special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
+positive number of references; such strings will never be recycled. If
+a string is ever referred to more than 126 times, simultaneously, we
+put it in this category. Hence a single byte suffices to store each |str_ref|.
+
+@d max_str_ref 127 /* ``infinite'' number of references */
+@d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
+ }
+
+@<Glob...@>=
+int *str_ref;
+
+@ @<Allocate or initialize ...@>=
+mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
+
+@ @<Dealloc variables@>=
+xfree(mp->str_ref);
+
+@ Here's what we do when a string reference disappears:
+
+@d delete_str_ref(A) {
+ if ( mp->str_ref[(A)]<max_str_ref ) {
+ if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
+ else mp_flush_string(mp, (A));
+ }
+ }
+
+@<Declare the procedure called |flush_string|@>=
+void mp_flush_string (MP mp,str_number s) ;
+
+
+@ We can't flush the first set of static strings at all, so there
+is no point in trying
+
+@c
+void mp_flush_string (MP mp,str_number s) {
+ if (length(s)>1) {
+ mp->pool_in_use=mp->pool_in_use-length(s);
+ decr(mp->strs_in_use);
+ if ( mp->next_str[s]!=mp->str_ptr ) {
+ mp->str_ref[s]=0;
+ } else {
+ mp->str_ptr=s;
+ decr(mp->strs_used_up);
+ }
+ mp->pool_ptr=mp->str_start[mp->str_ptr];
+ }
+}
+
+@ C literals cannot be simply added, they need to be set so they can't
+be flushed.
+
+@d intern(A) mp_intern(mp,(A))
+
+@c
+str_number mp_intern (MP mp, const char *s) {
+ str_number r ;
+ r = rts(s);
+ mp->str_ref[r] = max_str_ref;
+ return r;
+}
+
+@ @<Declarations@>=
+str_number mp_intern (MP mp, const char *s);
+
+
+@ Once a sequence of characters has been appended to |str_pool|, it
+officially becomes a string when the function |make_string| is called.
+This function returns the identification number of the new string as its
+value.
+
+When getting the next unused string number from the linked list, we pretend
+that
+$$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
+are linked sequentially even though the |next_str| entries have not been
+initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
+|do_compaction| is responsible for making sure of this.
+
+@<Declarations@>=
+@<Declare the procedure called |do_compaction|@>
+@<Declare the procedure called |unit_str_room|@>
+str_number mp_make_string (MP mp);
+
+@ @c
+str_number mp_make_string (MP mp) { /* current string enters the pool */
+ str_number s; /* the new string */
+RESTART:
+ s=mp->str_ptr;
+ mp->str_ptr=mp->next_str[s];
+ if ( mp->str_ptr>mp->max_str_ptr ) {
+ if ( mp->str_ptr==mp->max_strings ) {
+ mp->str_ptr=s;
+ mp_do_compaction(mp, 0);
+ goto RESTART;
+ } else {
+#ifdef DEBUG
+ if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
+@:this can't happen s}{\quad \.s@>
+#endif
+ mp->max_str_ptr=mp->str_ptr;
+ mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
+ }
+ }
+ mp->str_ref[s]=1;
+ mp->str_start[mp->str_ptr]=mp->pool_ptr;
+ incr(mp->strs_used_up);
+ incr(mp->strs_in_use);
+ mp->pool_in_use=mp->pool_in_use+length(s);
+ if ( mp->pool_in_use>mp->max_pl_used )
+ mp->max_pl_used=mp->pool_in_use;
+ if ( mp->strs_in_use>mp->max_strs_used )
+ mp->max_strs_used=mp->strs_in_use;
+ return s;
+}
+
+@ The most interesting string operation is string pool compaction. The idea
+is to recover unused space in the |str_pool| array by recopying the strings
+to close the gaps created when some strings become unused. All string
+numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
+numbers after |str_ptr|. If this fails to free enough pool space we issue an
+|overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
+with |needed=mp->pool_size| supresses all overflow tests.
+
+The compaction process starts with |last_fixed_str| because all lower numbered
+strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
+
+@<Glob...@>=
+str_number last_fixed_str; /* last permanently allocated string */
+str_number fixed_str_use; /* number of permanently allocated strings */
+
+@ @<Declare the procedure called |do_compaction|@>=
+void mp_do_compaction (MP mp, pool_pointer needed) ;
+
+@ @c
+void mp_do_compaction (MP mp, pool_pointer needed) {
+ str_number str_use; /* a count of strings in use */
+ str_number r,s,t; /* strings being manipulated */
+ pool_pointer p,q; /* destination and source for copying string characters */
+ @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
+ r=mp->last_fixed_str;
+ s=mp->next_str[r];
+ p=mp->str_start[s];
+ while ( s!=mp->str_ptr ) {
+ while ( mp->str_ref[s]==0 ) {
+ @<Advance |s| and add the old |s| to the list of free string numbers;
+ then |break| if |s=str_ptr|@>;
+ }
+ r=s; s=mp->next_str[s];
+ incr(str_use);
+ @<Move string |r| back so that |str_start[r]=p|; make |p| the location
+ after the end of the string@>;
+ }
+ @<Move the current string back so that it starts at |p|@>;
+ if ( needed<mp->pool_size ) {
+ @<Make sure that there is room for another string with |needed| characters@>;
+ }
+ @<Account for the compaction and make sure the statistics agree with the
+ global versions@>;
+ mp->strs_used_up=str_use;
+}
+
+@ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
+t=mp->next_str[mp->last_fixed_str];
+while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
+ incr(mp->fixed_str_use);
+ mp->last_fixed_str=t;
+ t=mp->next_str[t];
+}
+str_use=mp->fixed_str_use
+
+@ Because of the way |flush_string| has been written, it should never be
+necessary to |break| here. The extra line of code seems worthwhile to
+preserve the generality of |do_compaction|.
+
+@<Advance |s| and add the old |s| to the list of free string numbers;...@>=
+{
+t=s;
+s=mp->next_str[s];
+mp->next_str[r]=s;
+mp->next_str[t]=mp->next_str[mp->str_ptr];
+mp->next_str[mp->str_ptr]=t;
+if ( s==mp->str_ptr ) break;
+}
+
+@ The string currently starts at |str_start[r]| and ends just before
+|str_start[s]|. We don't change |str_start[s]| because it might be needed
+to locate the next string.
+
+@<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
+q=mp->str_start[r];
+mp->str_start[r]=p;
+while ( q<mp->str_start[s] ) {
+ mp->str_pool[p]=mp->str_pool[q];
+ incr(p); incr(q);
+}
+
+@ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
+we do this, anything between them should be moved.
+
+@ @<Move the current string back so that it starts at |p|@>=
+q=mp->str_start[mp->str_ptr];
+mp->str_start[mp->str_ptr]=p;
+while ( q<mp->pool_ptr ) {
+ mp->str_pool[p]=mp->str_pool[q];
+ incr(p); incr(q);
+}
+mp->pool_ptr=p
+
+@ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
+
+@<Make sure that there is room for another string with |needed| char...@>=
+if ( str_use>=mp->max_strings-1 )
+ mp_reallocate_strings (mp,str_use);
+if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
+ mp_reallocate_pool(mp, mp->pool_ptr+needed);
+ mp->max_pool_ptr=mp->pool_ptr+needed;
+}
+
+@ @<Declarations@>=
+void mp_reallocate_strings (MP mp, str_number str_use) ;
+void mp_reallocate_pool(MP mp, pool_pointer needed) ;
+
+@ @c
+void mp_reallocate_strings (MP mp, str_number str_use) {
+ while ( str_use>=mp->max_strings-1 ) {
+ int l = mp->max_strings + (mp->max_strings>>2);
+ XREALLOC (mp->str_ref, l, int);
+ XREALLOC (mp->str_start, l, pool_pointer);
+ XREALLOC (mp->next_str, l, str_number);
+ mp->max_strings = l;
+ }
+}
+void mp_reallocate_pool(MP mp, pool_pointer needed) {
+ while ( needed>mp->pool_size ) {
+ int l = mp->pool_size + (mp->pool_size>>2);
+ XREALLOC (mp->str_pool, l, ASCII_code);
+ mp->pool_size = l;
+ }
+}
+
+@ @<Account for the compaction and make sure the statistics agree with...@>=
+if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
+ mp_confusion(mp, "string");
+@:this can't happen string}{\quad string@>
+incr(mp->pact_count);
+mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
+mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
+#ifdef DEBUG
+s=mp->str_ptr; t=str_use;
+while ( s<=mp->max_str_ptr ){
+ if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
+ incr(t); s=mp->next_str[s];
+};
+if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
+#endif
+
+@ A few more global variables are needed to keep track of statistics when
+|stat| $\ldots$ |tats| blocks are not commented out.
+
+@<Glob...@>=
+integer pact_count; /* number of string pool compactions so far */
+integer pact_chars; /* total number of characters moved during compactions */
+integer pact_strs; /* total number of strings moved during compactions */
+
+@ @<Initialize compaction statistics@>=
+mp->pact_count=0;
+mp->pact_chars=0;
+mp->pact_strs=0;
+
+@ The following subroutine compares string |s| with another string of the
+same length that appears in |buffer| starting at position |k|;
+the result is |true| if and only if the strings are equal.
+
+@c
+boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
+ /* test equality of strings */
+ pool_pointer j; /* running index */
+ j=mp->str_start[s];
+ while ( j<str_stop(s) ) {
+ if ( mp->str_pool[j++]!=mp->buffer[k++] )
+ return false;
+ }
+ return true;
+}
+
+@ Here is a similar routine, but it compares two strings in the string pool,
+and it does not assume that they have the same length. If the first string
+is lexicographically greater than, less than, or equal to the second,
+the result is respectively positive, negative, or zero.
+
+@c
+integer mp_str_vs_str (MP mp, str_number s, str_number t) {
+ /* test equality of strings */
+ pool_pointer j,k; /* running indices */
+ integer ls,lt; /* lengths */
+ integer l; /* length remaining to test */
+ ls=length(s); lt=length(t);
+ if ( ls<=lt ) l=ls; else l=lt;
+ j=mp->str_start[s]; k=mp->str_start[t];
+ while ( l-->0 ) {
+ if ( mp->str_pool[j]!=mp->str_pool[k] ) {
+ return (mp->str_pool[j]-mp->str_pool[k]);
+ }
+ incr(j); incr(k);
+ }
+ return (ls-lt);
+}
+
+@ The initial values of |str_pool|, |str_start|, |pool_ptr|,
+and |str_ptr| are computed by the \.{INIMP} program, based in part
+on the information that \.{WEB} has output while processing \MP.
+@.INIMP@>
+@^string pool@>
+
+@c
+void mp_get_strings_started (MP mp) {
+ /* initializes the string pool,
+ but returns |false| if something goes wrong */
+ int k; /* small indices or counters */
+ str_number g; /* a new string */
+ mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
+ mp->str_start[0]=0;
+ mp->next_str[0]=1;
+ mp->pool_in_use=0; mp->strs_in_use=0;
+ mp->max_pl_used=0; mp->max_strs_used=0;
+ @<Initialize compaction statistics@>;
+ mp->strs_used_up=0;
+ @<Make the first 256 strings@>;
+ g=mp_make_string(mp); /* string 256 == "" */
+ mp->str_ref[g]=max_str_ref;
+ mp->last_fixed_str=mp->str_ptr-1;
+ mp->fixed_str_use=mp->str_ptr;
+ return;
+}
+
+@ @<Declarations@>=
+void mp_get_strings_started (MP mp);
+
+@ The first 256 strings will consist of a single character only.
+
+@<Make the first 256...@>=
+for (k=0;k<=255;k++) {
+ append_char(k);
+ g=mp_make_string(mp);
+ mp->str_ref[g]=max_str_ref;
+}
+
+@ The first 128 strings will contain 95 standard ASCII characters, and the
+other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
+unless a system-dependent change is made here. Installations that have
+an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
+would like string 032 to be printed as the single character 032 instead
+of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
+even people with an extended character set will want to represent string
+015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
+to produce visible strings instead of tabs or line-feeds or carriage-returns
+or bell-rings or characters that are treated anomalously in text files.
+
+Unprintable characters of codes 128--255 are, similarly, rendered
+\.{\^\^80}--\.{\^\^ff}.
+
+The boolean expression defined here should be |true| unless \MP\ internal
+code number~|k| corresponds to a non-troublesome visible symbol in the
+local character set.
+If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
+|k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
+must be printable.
+@^character set dependencies@>
+@^system dependencies@>
+
+@<Character |k| cannot be printed@>=
+ (k<' ')||(k>'~')
+
+@* \[5] On-line and off-line printing.
+Messages that are sent to a user's terminal and to the transcript-log file
+are produced by several `|print|' procedures. These procedures will
+direct their output to a variety of places, based on the setting of
+the global variable |selector|, which has the following possible
+values:
+
+\yskip
+\hang |term_and_log|, the normal setting, prints on the terminal and on the
+ transcript file.
+
+\hang |log_only|, prints only on the transcript file.
+
+\hang |term_only|, prints only on the terminal.
+
+\hang |no_print|, doesn't print at all. This is used only in rare cases
+ before the transcript file is open.
+
+\hang |pseudo|, puts output into a cyclic buffer that is used
+ by the |show_context| routine; when we get to that routine we shall discuss
+ the reasoning behind this curious mode.
+
+\hang |new_string|, appends the output to the current string in the
+ string pool.
+
+\hang |>=write_file| prints on one of the files used for the \&{write}
+@:write_}{\&{write} primitive@>
+ command.
+
+\yskip
+\noindent The symbolic names `|term_and_log|', etc., have been assigned
+numeric codes that satisfy the convenient relations |no_print+1=term_only|,
+|no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
+relations are not used when |selector| could be |pseudo|, or |new_string|.
+We need not check for unprintable characters when |selector<pseudo|.
+
+Three additional global variables, |tally|, |term_offset| and |file_offset|
+record the number of characters that have been printed
+since they were most recently cleared to zero. We use |tally| to record
+the length of (possibly very long) stretches of printing; |term_offset|,
+and |file_offset|, on the other hand, keep track of how many
+characters have appeared so far on the current line that has been output
+to the terminal, the transcript file, or the \ps\ output file, respectively.
+
+@d new_string 0 /* printing is deflected to the string pool */
+@d pseudo 2 /* special |selector| setting for |show_context| */
+@d no_print 3 /* |selector| setting that makes data disappear */
+@d term_only 4 /* printing is destined for the terminal only */
+@d log_only 5 /* printing is destined for the transcript file only */
+@d term_and_log 6 /* normal |selector| setting */
+@d write_file 7 /* first write file selector */
+
+@<Glob...@>=
+void * log_file; /* transcript of \MP\ session */
+void * ps_file; /* the generic font output goes here */
+unsigned int selector; /* where to print a message */
+unsigned char dig[23]; /* digits in a number being output */
+integer tally; /* the number of characters recently printed */
+unsigned int term_offset;
+ /* the number of characters on the current terminal line */
+unsigned int file_offset;
+ /* the number of characters on the current file line */
+ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
+integer trick_count; /* threshold for pseudoprinting, explained later */
+integer first_count; /* another variable for pseudoprinting */
+
+@ @<Allocate or initialize ...@>=
+memset(mp->dig,0,23);
+mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
+
+@ @<Dealloc variables@>=
+xfree(mp->trick_buf);
+
+@ @<Initialize the output routines@>=
+mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
+
+@ Macro abbreviations for output to the terminal and to the log file are
+defined here for convenience. Some systems need special conventions
+for terminal output, and it is possible to adhere to those conventions
+by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
+@^system dependencies@>
+
+@d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
+@d wterm(A) do_fprintf(mp->term_out,(A))
+@d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
+@d wterm_cr do_fprintf(mp->term_out,"\n")
+@d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
+@d wlog(A) do_fprintf(mp->log_file,(A))
+@d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
+@d wlog_cr do_fprintf(mp->log_file, "\n")
+@d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
+
+
+@ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
+use an array |wr_file| that will be declared later.
+
+@d mp_print_text(A) mp_print_str(mp,text((A)))
+
+@<Internal ...@>=
+void mp_print_ln (MP mp);
+void mp_print_visible_char (MP mp, ASCII_code s);
+void mp_print_char (MP mp, ASCII_code k);
+void mp_print (MP mp, const char *s);
+void mp_print_str (MP mp, str_number s);
+void mp_print_nl (MP mp, const char *s);
+void mp_print_two (MP mp,scaled x, scaled y) ;
+void mp_print_scaled (MP mp,scaled s);
+
+@ @<Basic print...@>=
+void mp_print_ln (MP mp) { /* prints an end-of-line */
+ switch (mp->selector) {
+ case term_and_log:
+ wterm_cr; wlog_cr;
+ mp->term_offset=0; mp->file_offset=0;
+ break;
+ case log_only:
+ wlog_cr; mp->file_offset=0;
+ break;
+ case term_only:
+ wterm_cr; mp->term_offset=0;
+ break;
+ case no_print:
+ case pseudo:
+ case new_string:
+ break;
+ default:
+ do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
+ }
+} /* note that |tally| is not affected */
+
+@ The |print_visible_char| procedure sends one character to the desired
+destination, using the |xchr| array to map it into an external character
+compatible with |input_ln|. (It assumes that it is always called with
+a visible ASCII character.) All printing comes through |print_ln| or
+|print_char|, which ultimately calls |print_visible_char|, hence these
+routines are the ones that limit lines to at most |max_print_line| characters.
+But we must make an exception for the \ps\ output file since it is not safe
+to cut up lines arbitrarily in \ps.
+
+Procedure |unit_str_room| needs to be declared |forward| here because it calls
+|do_compaction| and |do_compaction| can call the error routines. Actually,
+|unit_str_room| avoids |overflow| errors but it can call |confusion|.
+
+@<Basic printing...@>=
+void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
+ switch (mp->selector) {
+ case term_and_log:
+ wterm_chr(xchr(s)); wlog_chr(xchr(s));
+ incr(mp->term_offset); incr(mp->file_offset);
+ if ( mp->term_offset==(unsigned)mp->max_print_line ) {
+ wterm_cr; mp->term_offset=0;
+ };
+ if ( mp->file_offset==(unsigned)mp->max_print_line ) {
+ wlog_cr; mp->file_offset=0;
+ };
+ break;
+ case log_only:
+ wlog_chr(xchr(s)); incr(mp->file_offset);
+ if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
+ break;
+ case term_only:
+ wterm_chr(xchr(s)); incr(mp->term_offset);
+ if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
+ break;
+ case no_print:
+ break;
+ case pseudo:
+ if ( mp->tally<mp->trick_count )
+ mp->trick_buf[mp->tally % mp->error_line]=s;
+ break;
+ case new_string:
+ if ( mp->pool_ptr>=mp->max_pool_ptr ) {
+ mp_unit_str_room(mp);
+ if ( mp->pool_ptr>=mp->pool_size )
+ goto DONE; /* drop characters if string space is full */
+ };
+ append_char(s);
+ break;
+ default:
+ { char ss[2]; ss[0] = xchr(s); ss[1]=0;
+ do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
+ }
+ }
+DONE:
+ incr(mp->tally);
+}
+
+@ The |print_char| procedure sends one character to the desired destination.
+File names and string expressions might contain |ASCII_code| values that
+can't be printed using |print_visible_char|. These characters will be
+printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
+(This procedure assumes that it is safe to bypass all checks for unprintable
+characters when |selector| is in the range |0..max_write_files-1|.
+The user might want to write unprintable characters.
+
+@d print_lc_hex(A) do { l=(A);
+ mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
+ } while (0)
+
+@<Basic printing...@>=
+void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
+ int l; /* small index or counter */
+ if ( mp->selector<pseudo || mp->selector>=write_file) {
+ mp_print_visible_char(mp, k);
+ } else if ( @<Character |k| cannot be printed@> ) {
+ mp_print(mp, "^^");
+ if ( k<0100 ) {
+ mp_print_visible_char(mp, k+0100);
+ } else if ( k<0200 ) {
+ mp_print_visible_char(mp, k-0100);
+ } else {
+ print_lc_hex(k / 16);
+ print_lc_hex(k % 16);
+ }
+ } else {
+ mp_print_visible_char(mp, k);
+ }
+}
+
+@ An entire string is output by calling |print|. Note that if we are outputting
+the single standard ASCII character \.c, we could call |print("c")|, since
+|"c"=99| is the number of a single-character string, as explained above. But
+|print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
+routine when it knows that this is safe. (The present implementation
+assumes that it is always safe to print a visible ASCII character.)
+@^system dependencies@>
+
+@<Basic print...@>=
+void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
+ unsigned int j = 0;
+ while ( j<len ){
+ mp_print_char(mp, ss[j]); incr(j);
+ }
+}
+
+@
+@<Basic print...@>=
+void mp_print (MP mp, const char *ss) {
+ mp_do_print(mp, ss, strlen(ss));
+}
+void mp_print_str (MP mp, str_number s) {
+ pool_pointer j; /* current character code position */
+ if ( (s<0)||(s>mp->max_str_ptr) ) {
+ mp_do_print(mp,"???",3); /* this can't happen */
+@.???@>
+ }
+ j=mp->str_start[s];
+ mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
+}
+
+
+@ Here is the very first thing that \MP\ prints: a headline that identifies
+the version number and base name. The |term_offset| variable is temporarily
+incorrect, but the discrepancy is not serious since we assume that the banner
+and mem identifier together will occupy at most |max_print_line|
+character positions.
+
+@<Initialize the output...@>=
+wterm (banner);
+wterm (version_string);
+if (mp->mem_ident!=NULL)
+ mp_print(mp,mp->mem_ident);
+mp_print_ln(mp);
+update_terminal;
+
+@ The procedure |print_nl| is like |print|, but it makes sure that the
+string appears at the beginning of a new line.
+
+@<Basic print...@>=
+void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
+ switch(mp->selector) {
+ case term_and_log:
+ if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
+ break;
+ case log_only:
+ if ( mp->file_offset>0 ) mp_print_ln(mp);
+ break;
+ case term_only:
+ if ( mp->term_offset>0 ) mp_print_ln(mp);
+ break;
+ case no_print:
+ case pseudo:
+ case new_string:
+ break;
+ } /* there are no other cases */
+ mp_print(mp, s);
+}
+
+@ An array of digits in the range |0..9| is printed by |print_the_digs|.
+
+@<Basic print...@>=
+void mp_print_the_digs (MP mp, eight_bits k) {
+ /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
+ while ( k>0 ){
+ decr(k); mp_print_char(mp, '0'+mp->dig[k]);
+ }
+}
+
+@ The following procedure, which prints out the decimal representation of a
+given integer |n|, has been written carefully so that it works properly
+if |n=0| or if |(-n)| would cause overflow. It does not apply |%| or |/|
+to negative arguments, since such operations are not implemented consistently
+on all platforms.
+
+@<Basic print...@>=
+void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
+ integer m; /* used to negate |n| in possibly dangerous cases */
+ int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
+ if ( n<0 ) {
+ mp_print_char(mp, '-');
+ if ( n>-100000000 ) {
+ negate(n);
+ } else {
+ m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
+ if ( m<10 ) {
+ mp->dig[0]=m;
+ } else {
+ mp->dig[0]=0; incr(n);
+ }
+ }
+ }
+ do {
+ mp->dig[k]=n % 10; n=n / 10; incr(k);
+ } while (n!=0);
+ mp_print_the_digs(mp, k);
+}
+
+@ @<Internal ...@>=
+void mp_print_int (MP mp,integer n);
+
+@ \MP\ also makes use of a trivial procedure to print two digits. The
+following subroutine is usually called with a parameter in the range |0<=n<=99|.
+
+@c
+void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
+ n=abs(n) % 100;
+ mp_print_char(mp, '0'+(n / 10));
+ mp_print_char(mp, '0'+(n % 10));
+}
+
+
+@ @<Internal ...@>=
+void mp_print_dd (MP mp,integer n);
+
+@ Here is a procedure that asks the user to type a line of input,
+assuming that the |selector| setting is either |term_only| or |term_and_log|.
+The input is placed into locations |first| through |last-1| of the
+|buffer| array, and echoed on the transcript file if appropriate.
+
+This procedure is never called when |interaction<mp_scroll_mode|.
+
+@d prompt_input(A) do {
+ if (!mp->noninteractive) {
+ wake_up_terminal; mp_print(mp, (A));
+ }
+ mp_term_input(mp);
+ } while (0) /* prints a string and gets a line of input */
+
+@c
+void mp_term_input (MP mp) { /* gets a line from the terminal */
+ size_t k; /* index into |buffer| */
+ update_terminal; /* Now the user sees the prompt for sure */
+ if (!mp_input_ln(mp, mp->term_in )) {
+ if (!mp->noninteractive) {
+ mp_fatal_error(mp, "End of file on the terminal!");
+@.End of file on the terminal@>
+ } else { /* we are done with this input chunk */
+ longjmp(mp->jump_buf,1);
+ }
+ }
+ if (!mp->noninteractive) {
+ mp->term_offset=0; /* the user's line ended with \<\rm return> */
+ decr(mp->selector); /* prepare to echo the input */
+ if ( mp->last!=mp->first ) {
+ for (k=mp->first;k<=mp->last-1;k++) {
+ mp_print_char(mp, mp->buffer[k]);
+ }
+ }
+ mp_print_ln(mp);
+ mp->buffer[mp->last]='%';
+ incr(mp->selector); /* restore previous status */
+ }
+}
+
+@* \[6] Reporting errors.
+When something anomalous is detected, \MP\ typically does something like this:
+$$\vbox{\halign{#\hfil\cr
+|print_err("Something anomalous has been detected");|\cr
+|help3("This is the first line of my offer to help.")|\cr
+|("This is the second line. I'm trying to")|\cr
+|("explain the best way for you to proceed.");|\cr
+|error;|\cr}}$$
+A two-line help message would be given using |help2|, etc.; these informal
+helps should use simple vocabulary that complements the words used in the
+official error message that was printed. (Outside the U.S.A., the help
+messages should preferably be translated into the local vernacular. Each
+line of help is at most 60 characters long, in the present implementation,
+so that |max_print_line| will not be exceeded.)
+
+The |print_err| procedure supplies a `\.!' before the official message,
+and makes sure that the terminal is awake if a stop is going to occur.
+The |error| procedure supplies a `\..' after the official message, then it
+shows the location of the error; and if |interaction=error_stop_mode|,
+it also enters into a dialog with the user, during which time the help
+message may be printed.
+@^system dependencies@>
+
+@ The global variable |interaction| has four settings, representing increasing
+amounts of user interaction:
+
+@<Exported types@>=
+enum mp_interaction_mode {
+ mp_unspecified_mode=0, /* extra value for command-line switch */
+ mp_batch_mode, /* omits all stops and omits terminal output */
+ mp_nonstop_mode, /* omits all stops */
+ mp_scroll_mode, /* omits error stops */
+ mp_error_stop_mode /* stops at every opportunity to interact */
+};
+
+@ @<Option variables@>=
+int interaction; /* current level of interaction */
+int noninteractive; /* do we have a terminal? */
+
+@ Set it here so it can be overwritten by the commandline
+
+@<Allocate or initialize ...@>=
+mp->interaction=opt->interaction;
+if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
+ mp->interaction=mp_error_stop_mode;
+if (mp->interaction<mp_unspecified_mode)
+ mp->interaction=mp_batch_mode;
+mp->noninteractive=opt->noninteractive;
+
+@
+
+@d print_err(A) mp_print_err(mp,(A))
+
+@<Internal ...@>=
+void mp_print_err(MP mp, const char * A);
+
+@ @c
+void mp_print_err(MP mp, const char * A) {
+ if ( mp->interaction==mp_error_stop_mode )
+ wake_up_terminal;
+ mp_print_nl(mp, "! ");
+ mp_print(mp, A);
+@.!\relax@>
+}
+
+
+@ \MP\ is careful not to call |error| when the print |selector| setting
+might be unusual. The only possible values of |selector| at the time of
+error messages are
+
+\yskip\hang|no_print| (when |interaction=mp_batch_mode|
+ and |log_file| not yet open);
+
+\hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
+
+\hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
+
+\hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
+
+@<Initialize the print |selector| based on |interaction|@>=
+if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
+
+@ A global variable |deletions_allowed| is set |false| if the |get_next|
+routine is active when |error| is called; this ensures that |get_next|
+will never be called recursively.
+@^recursion@>
+
+The global variable |history| records the worst level of error that
+has been detected. It has four possible values: |spotless|, |warning_issued|,
+|error_message_issued|, and |fatal_error_stop|.
+
+Another global variable, |error_count|, is increased by one when an
+|error| occurs without an interactive dialog, and it is reset to zero at
+the end of every statement. If |error_count| reaches 100, \MP\ decides
+that there is no point in continuing further.
+
+@<Types...@>=
+enum mp_history_states {
+ mp_spotless=0, /* |history| value when nothing has been amiss yet */
+ mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
+ mp_error_message_issued, /* |history| value when |error| has been called */
+ mp_fatal_error_stop /* |history| value when termination was premature */
+};
+
+@ @<Glob...@>=
+boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
+int history; /* has the source input been clean so far? */
+int error_count; /* the number of scrolled errors since the last statement ended */
+
+@ The value of |history| is initially |fatal_error_stop|, but it will
+be changed to |spotless| if \MP\ survives the initialization process.
+
+@<Allocate or ...@>=
+mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
+
+@ Since errors can be detected almost anywhere in \MP, we want to declare the
+error procedures near the beginning of the program. But the error procedures
+in turn use some other procedures, which need to be declared |forward|
+before we get to |error| itself.
+
+It is possible for |error| to be called recursively if some error arises
+when |get_next| is being used to delete a token, and/or if some fatal error
+occurs while \MP\ is trying to fix a non-fatal one. But such recursion
+@^recursion@>
+is never more than two levels deep.
+
+@<Declarations@>=
+void mp_get_next (MP mp);
+void mp_term_input (MP mp);
+void mp_show_context (MP mp);
+void mp_begin_file_reading (MP mp);
+void mp_open_log_file (MP mp);
+void mp_clear_for_error_prompt (MP mp);
+void mp_debug_help (MP mp);
+@<Declare the procedure called |flush_string|@>
+
+@ @<Internal ...@>=
+void mp_normalize_selector (MP mp);
+
+@ Individual lines of help are recorded in the array |help_line|, which
+contains entries in positions |0..(help_ptr-1)|. They should be printed
+in reverse order, i.e., with |help_line[0]| appearing last.
+
+@d hlp1(A) mp->help_line[0]=(A); }
+@d hlp2(A) mp->help_line[1]=(A); hlp1
+@d hlp3(A) mp->help_line[2]=(A); hlp2
+@d hlp4(A) mp->help_line[3]=(A); hlp3
+@d hlp5(A) mp->help_line[4]=(A); hlp4
+@d hlp6(A) mp->help_line[5]=(A); hlp5
+@d help0 mp->help_ptr=0 /* sometimes there might be no help */
+@d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
+@d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
+@d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
+@d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
+@d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
+@d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
+
+@<Glob...@>=
+const char * help_line[6]; /* helps for the next |error| */
+unsigned int help_ptr; /* the number of help lines present */
+boolean use_err_help; /* should the |err_help| string be shown? */
+str_number err_help; /* a string set up by \&{errhelp} */
+str_number filename_template; /* a string set up by \&{filenametemplate} */
+
+@ @<Allocate or ...@>=
+mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
+
+@ The |jump_out| procedure just cuts across all active procedure levels and
+goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
+whole program. It is used when there is no recovery from a particular error.
+
+The program uses a |jump_buf| to handle this, this is initialized at three
+spots: the start of |mp_new|, the start of |mp_initialize|, and the start
+of |mp_run|. Those are the only library enty points.
+
+@^system dependencies@>
+
+@<Glob...@>=
+jmp_buf jump_buf;
+
+@ @<Install and test the non-local jump buffer@>=
+if (setjmp(mp->jump_buf) != 0) { return mp->history; }
+
+@ @<Setup the non-local jump buffer in |mp_new|@>=
+if (setjmp(mp->jump_buf) != 0) return NULL;
+
+
+@ If the array of internals is still |NULL| when |jump_out| is called, a
+crash occured during initialization, and it is not safe to run the normal
+cleanup routine.
+
+@<Error hand...@>=
+void mp_jump_out (MP mp) {
+ if(mp->internal!=NULL)
+ mp_close_files_and_terminate(mp);
+ longjmp(mp->jump_buf,1);
+}
+
+@ Here now is the general |error| routine.
+
+@<Error hand...@>=
+void mp_error (MP mp) { /* completes the job of error reporting */
+ ASCII_code c; /* what the user types */
+ integer s1,s2,s3; /* used to save global variables when deleting tokens */
+ pool_pointer j; /* character position being printed */
+ if ( mp->history<mp_error_message_issued )
+ mp->history=mp_error_message_issued;
+ mp_print_char(mp, '.'); mp_show_context(mp);
+ if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
+ @<Get user's advice and |return|@>;
+ }
+ incr(mp->error_count);
+ if ( mp->error_count==100 ) {
+ mp_print_nl(mp,"(That makes 100 errors; please try again.)");
+@.That makes 100 errors...@>
+ mp->history=mp_fatal_error_stop; mp_jump_out(mp);
+ }
+ @<Put help message on the transcript file@>;
+}
+void mp_warn (MP mp, const char *msg) {
+ int saved_selector = mp->selector;
+ mp_normalize_selector(mp);
+ mp_print_nl(mp,"Warning: ");
+ mp_print(mp,msg);
+ mp_print_ln(mp);
+ mp->selector = saved_selector;
+}
+
+@ @<Exported function ...@>=
+void mp_error (MP mp);
+void mp_warn (MP mp, const char *msg);
+
+
+@ @<Get user's advice...@>=
+while (1) {
+CONTINUE:
+ mp_clear_for_error_prompt(mp); prompt_input("? ");
+@.?\relax@>
+ if ( mp->last==mp->first ) return;
+ c=mp->buffer[mp->first];
+ if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
+ @<Interpret code |c| and |return| if done@>;
+}
+
+@ It is desirable to provide an `\.E' option here that gives the user
+an easy way to return from \MP\ to the system editor, with the offending
+line ready to be edited. But such an extension requires some system
+wizardry, so the present implementation simply types out the name of the
+file that should be
+edited and the relevant line number.
+@^system dependencies@>
+
+@<Exported types@>=
+typedef void (*mp_run_editor_command)(MP, char *, int);
+
+@ @<Option variables@>=
+mp_run_editor_command run_editor;
+
+@ @<Allocate or initialize ...@>=
+set_callback_option(run_editor);
+
+@ @<Declarations@>=
+void mp_run_editor (MP mp, char *fname, int fline);
+
+@ @c void mp_run_editor (MP mp, char *fname, int fline) {
+ mp_print_nl(mp, "You want to edit file ");
+@.You want to edit file x@>
+ mp_print(mp, fname);
+ mp_print(mp, " at line ");
+ mp_print_int(mp, fline);
+ mp->interaction=mp_scroll_mode;
+ mp_jump_out(mp);
+}
+
+@
+There is a secret `\.D' option available when the debugging routines haven't
+been commented~out.
+@^debugging@>
+
+@<Interpret code |c| and |return| if done@>=
+switch (c) {
+case '0': case '1': case '2': case '3': case '4':
+case '5': case '6': case '7': case '8': case '9':
+ if ( mp->deletions_allowed ) {
+ @<Delete |c-"0"| tokens and |continue|@>;
+ }
+ break;
+#ifdef DEBUG
+case 'D':
+ mp_debug_help(mp); continue;
+ break;
+#endif
+case 'E':
+ if ( mp->file_ptr>0 ){
+ (mp->run_editor)(mp,
+ str(mp->input_stack[mp->file_ptr].name_field),
+ mp_true_line(mp));
+ }
+ break;
+case 'H':
+ @<Print the help information and |continue|@>;
+ break;
+case 'I':
+ @<Introduce new material from the terminal and |return|@>;
+ break;
+case 'Q': case 'R': case 'S':
+ @<Change the interaction level and |return|@>;
+ break;
+case 'X':
+ mp->interaction=mp_scroll_mode; mp_jump_out(mp);
+ break;
+default:
+ break;
+}
+@<Print the menu of available options@>
+
+@ @<Print the menu...@>=
+{
+ mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
+@.Type <return> to proceed...@>
+ mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
+ mp_print_nl(mp, "I to insert something, ");
+ if ( mp->file_ptr>0 )
+ mp_print(mp, "E to edit your file,");
+ if ( mp->deletions_allowed )
+ mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
+ mp_print_nl(mp, "H for help, X to quit.");
+}
+
+@ Here the author of \MP\ apologizes for making use of the numerical
+relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
+|mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
+@^Knuth, Donald Ervin@>
+
+@<Change the interaction...@>=
+{
+ mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
+ mp_print(mp, "OK, entering ");
+ switch (c) {
+ case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
+ case 'R': mp_print(mp, "nonstopmode"); break;
+ case 'S': mp_print(mp, "scrollmode"); break;
+ } /* there are no other cases */
+ mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
+}
+
+@ When the following code is executed, |buffer[(first+1)..(last-1)]| may
+contain the material inserted by the user; otherwise another prompt will
+be given. In order to understand this part of the program fully, you need
+to be familiar with \MP's input stacks.
+
+@<Introduce new material...@>=
+{
+ mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
+ if ( mp->last>mp->first+1 ) {
+ loc=mp->first+1; mp->buffer[mp->first]=' ';
+ } else {
+ prompt_input("insert>"); loc=mp->first;
+@.insert>@>
+ };
+ mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
+}
+
+@ We allow deletion of up to 99 tokens at a time.
+
+@<Delete |c-"0"| tokens...@>=
+{
+ s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
+ if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
+ c=c*10+mp->buffer[mp->first+1]-'0'*11;
+ else
+ c=c-'0';
+ while ( c>0 ) {
+ mp_get_next(mp); /* one-level recursive call of |error| is possible */
+ @<Decrease the string reference count, if the current token is a string@>;
+ decr(c);
+ };
+ mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
+ help2("I have just deleted some text, as you asked.")
+ ("You can now delete more, or insert, or whatever.");
+ mp_show_context(mp);
+ goto CONTINUE;
+}
+
+@ @<Print the help info...@>=
+{
+ if ( mp->use_err_help ) {
+ @<Print the string |err_help|, possibly on several lines@>;
+ mp->use_err_help=false;
+ } else {
+ if ( mp->help_ptr==0 ) {
+ help2("Sorry, I don't know how to help in this situation.")
+ ("Maybe you should try asking a human?");
+ }
+ do {
+ decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
+ } while (mp->help_ptr!=0);
+ };
+ help4("Sorry, I already gave what help I could...")
+ ("Maybe you should try asking a human?")
+ ("An error might have occurred before I noticed any problems.")
+ ("``If all else fails, read the instructions.''");
+ goto CONTINUE;
+}
+
+@ @<Print the string |err_help|, possibly on several lines@>=
+j=mp->str_start[mp->err_help];
+while ( j<str_stop(mp->err_help) ) {
+ if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
+ else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
+ else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
+ else { incr(j); mp_print_char(mp, '%'); };
+ incr(j);
+}
+
+@ @<Put help message on the transcript file@>=
+if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
+if ( mp->use_err_help ) {
+ mp_print_nl(mp, "");
+ @<Print the string |err_help|, possibly on several lines@>;
+} else {
+ while ( mp->help_ptr>0 ){
+ decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
+ };
+}
+mp_print_ln(mp);
+if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
+mp_print_ln(mp)
+
+@ In anomalous cases, the print selector might be in an unknown state;
+the following subroutine is called to fix things just enough to keep
+running a bit longer.
+
+@c
+void mp_normalize_selector (MP mp) {
+ if ( mp->log_opened ) mp->selector=term_and_log;
+ else mp->selector=term_only;
+ if ( mp->job_name==NULL ) mp_open_log_file(mp);
+ if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
+}
+
+@ The following procedure prints \MP's last words before dying.
+
+@d succumb { if ( mp->interaction==mp_error_stop_mode )
+ mp->interaction=mp_scroll_mode; /* no more interaction */
+ if ( mp->log_opened ) mp_error(mp);
+ /*| if ( mp->interaction>mp_batch_mode ) mp_debug_help(mp); |*/
+ mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
+ }
+
+@<Error hand...@>=
+void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
+ mp_normalize_selector(mp);
+ print_err("Emergency stop"); help1(s); succumb;
+@.Emergency stop@>
+}
+
+@ @<Exported function ...@>=
+void mp_fatal_error (MP mp, const char *s);
+
+
+@ Here is the most dreaded error message.
+
+@<Error hand...@>=
+void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
+ mp_normalize_selector(mp);
+ print_err("MetaPost capacity exceeded, sorry [");
+@.MetaPost capacity exceeded ...@>
+ mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
+ help2("If you really absolutely need more capacity,")
+ ("you can ask a wizard to enlarge me.");
+ succumb;
+}
+
+@ @<Internal library declarations@>=
+void mp_overflow (MP mp, const char *s, integer n);
+
+@ The program might sometime run completely amok, at which point there is
+no choice but to stop. If no previous error has been detected, that's bad
+news; a message is printed that is really intended for the \MP\
+maintenance person instead of the user (unless the user has been
+particularly diabolical). The index entries for `this can't happen' may
+help to pinpoint the problem.
+@^dry rot@>
+
+@<Internal library ...@>=
+void mp_confusion (MP mp, const char *s);
+
+@ @<Error hand...@>=
+void mp_confusion (MP mp, const char *s) {
+ /* consistency check violated; |s| tells where */
+ mp_normalize_selector(mp);
+ if ( mp->history<mp_error_message_issued ) {
+ print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
+@.This can't happen@>
+ help1("I'm broken. Please show this to someone who can fix can fix");
+ } else {
+ print_err("I can\'t go on meeting you like this");
+@.I can't go on...@>
+ help2("One of your faux pas seems to have wounded me deeply...")
+ ("in fact, I'm barely conscious. Please fix it and try again.");
+ }
+ succumb;
+}
+
+@ Users occasionally want to interrupt \MP\ while it's running.
+If the runtime system allows this, one can implement
+a routine that sets the global variable |interrupt| to some nonzero value
+when such an interrupt is signaled. Otherwise there is probably at least
+a way to make |interrupt| nonzero using the C debugger.
+@^system dependencies@>
+@^debugging@>
+
+@d check_interrupt { if ( mp->interrupt!=0 )
+ mp_pause_for_instructions(mp); }
+
+@<Global...@>=
+integer interrupt; /* should \MP\ pause for instructions? */
+boolean OK_to_interrupt; /* should interrupts be observed? */
+integer run_state; /* are we processing input ?*/
+
+@ @<Allocate or ...@>=
+mp->interrupt=0; mp->OK_to_interrupt=true; mp->run_state=0;
+
+@ When an interrupt has been detected, the program goes into its
+highest interaction level and lets the user have the full flexibility of
+the |error| routine. \MP\ checks for interrupts only at times when it is
+safe to do this.
+
+@c
+void mp_pause_for_instructions (MP mp) {
+ if ( mp->OK_to_interrupt ) {
+ mp->interaction=mp_error_stop_mode;
+ if ( (mp->selector==log_only)||(mp->selector==no_print) )
+ incr(mp->selector);
+ print_err("Interruption");
+@.Interruption@>
+ help3("You rang?")
+ ("Try to insert some instructions for me (e.g.,`I show x'),")
+ ("unless you just want to quit by typing `X'.");
+ mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
+ mp->interrupt=0;
+ }
+}
+
+@ Many of \MP's error messages state that a missing token has been
+inserted behind the scenes. We can save string space and program space
+by putting this common code into a subroutine.
+
+@c
+void mp_missing_err (MP mp, const char *s) {
+ print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
+@.Missing...inserted@>
+}
+
+@* \[7] Arithmetic with scaled numbers.
+The principal computations performed by \MP\ are done entirely in terms of
+integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
+program can be carried out in exactly the same way on a wide variety of
+computers, including some small ones.
+@^small computers@>
+
+But C does not rigidly define the |/| operation in the case of negative
+dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
+computers and |-n| on others (is this true ?). There are two principal
+types of arithmetic: ``translation-preserving,'' in which the identity
+|(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
+|(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
+different results, although the differences should be negligible when the
+language is being used properly. The \TeX\ processor has been defined
+carefully so that both varieties of arithmetic will produce identical
+output, but it would be too inefficient to constrain \MP\ in a similar way.
+
+@d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
+
+@ One of \MP's most common operations is the calculation of
+$\lfloor{a+b\over2}\rfloor$,
+the midpoint of two given integers |a| and~|b|. The most decent way to do
+this is to write `|(a+b)/2|'; but on many machines it is more efficient
+to calculate `|(a+b)>>1|'.
+
+Therefore the midpoint operation will always be denoted by `|half(a+b)|'
+in this program. If \MP\ is being implemented with languages that permit
+binary shifting, the |half| macro should be changed to make this operation
+as efficient as possible. Since some systems have shift operators that can
+only be trusted to work on positive numbers, there is also a macro |halfp|
+that is used only when the quantity being halved is known to be positive
+or zero.
+
+@d half(A) ((A) / 2)
+@d halfp(A) ((A) >> 1)
+
+@ A single computation might use several subroutine calls, and it is
+desirable to avoid producing multiple error messages in case of arithmetic
+overflow. So the routines below set the global variable |arith_error| to |true|
+instead of reporting errors directly to the user.
+@^overflow in arithmetic@>
+
+@<Glob...@>=
+boolean arith_error; /* has arithmetic overflow occurred recently? */
+
+@ @<Allocate or ...@>=
+mp->arith_error=false;
+
+@ At crucial points the program will say |check_arith|, to test if
+an arithmetic error has been detected.
+
+@d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
+
+@c
+void mp_clear_arith (MP mp) {
+ print_err("Arithmetic overflow");
+@.Arithmetic overflow@>
+ help4("Uh, oh. A little while ago one of the quantities that I was")
+ ("computing got too large, so I'm afraid your answers will be")
+ ("somewhat askew. You'll probably have to adopt different")
+ ("tactics next time. But I shall try to carry on anyway.");
+ mp_error(mp);
+ mp->arith_error=false;
+}
+
+@ Addition is not always checked to make sure that it doesn't overflow,
+but in places where overflow isn't too unlikely the |slow_add| routine
+is used.
+
+@c integer mp_slow_add (MP mp,integer x, integer y) {
+ if ( x>=0 ) {
+ if ( y<=el_gordo-x ) {
+ return x+y;
+ } else {
+ mp->arith_error=true;
+ return el_gordo;
+ }
+ } else if ( -y<=el_gordo+x ) {
+ return x+y;
+ } else {
+ mp->arith_error=true;
+ return -el_gordo;
+ }
+}
+
+@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
+of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
+positions from the right end of a binary computer word.
+
+@d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
+@d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
+@d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
+@d unity 0200000 /* $2^{16}$, represents 1.00000 */
+@d two 0400000 /* $2^{17}$, represents 2.00000 */
+@d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
+
+@<Types...@>=
+typedef integer scaled; /* this type is used for scaled integers */
+typedef unsigned char small_number; /* this type is self-explanatory */
+
+@ The following function is used to create a scaled integer from a given decimal
+fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
+given in |dig[i]|, and the calculation produces a correctly rounded result.
+
+@c
+scaled mp_round_decimals (MP mp,small_number k) {
+ /* converts a decimal fraction */
+ integer a = 0; /* the accumulator */
+ while ( k-->0 ) {
+ a=(a+mp->dig[k]*two) / 10;
+ }
+ return halfp(a+1);
+}
+
+@ Conversely, here is a procedure analogous to |print_int|. If the output
+of this procedure is subsequently read by \MP\ and converted by the
+|round_decimals| routine above, it turns out that the original value will
+be reproduced exactly. A decimal point is printed only if the value is
+not an integer. If there is more than one way to print the result with
+the optimum number of digits following the decimal point, the closest
+possible value is given.
+
+The invariant relation in the \&{repeat} loop is that a sequence of
+decimal digits yet to be printed will yield the original number if and only if
+they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
+We can stop if and only if $f=0$ satisfies this condition; the loop will
+terminate before $s$ can possibly become zero.
+
+@<Basic printing...@>=
+void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
+ scaled delta; /* amount of allowable inaccuracy */
+ if ( s<0 ) {
+ mp_print_char(mp, '-');
+ negate(s); /* print the sign, if negative */
+ }
+ mp_print_int(mp, s / unity); /* print the integer part */
+ s=10*(s % unity)+5;
+ if ( s!=5 ) {
+ delta=10;
+ mp_print_char(mp, '.');
+ do {
+ if ( delta>unity )
+ s=s+0100000-(delta / 2); /* round the final digit */
+ mp_print_char(mp, '0'+(s / unity));
+ s=10*(s % unity);
+ delta=delta*10;
+ } while (s>delta);
+ }
+}
+
+@ We often want to print two scaled quantities in parentheses,
+separated by a comma.
+
+@<Basic printing...@>=
+void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
+ mp_print_char(mp, '(');
+ mp_print_scaled(mp, x);
+ mp_print_char(mp, ',');
+ mp_print_scaled(mp, y);
+ mp_print_char(mp, ')');
+}
+
+@ The |scaled| quantities in \MP\ programs are generally supposed to be
+less than $2^{12}$ in absolute value, so \MP\ does much of its internal
+arithmetic with 28~significant bits of precision. A |fraction| denotes
+a scaled integer whose binary point is assumed to be 28 bit positions
+from the right.
+
+@d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
+@d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
+@d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
+@d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
+@d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
+
+@<Types...@>=
+typedef integer fraction; /* this type is used for scaled fractions */
+
+@ In fact, the two sorts of scaling discussed above aren't quite
+sufficient; \MP\ has yet another, used internally to keep track of angles
+in units of $2^{-20}$ degrees.
+
+@d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
+@d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
+@d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
+@d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
+
+@<Types...@>=
+typedef integer angle; /* this type is used for scaled angles */
+
+@ The |make_fraction| routine produces the |fraction| equivalent of
+|p/q|, given integers |p| and~|q|; it computes the integer
+$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
+positive. If |p| and |q| are both of the same scaled type |t|,
+the ``type relation'' |make_fraction(t,t)=fraction| is valid;
+and it's also possible to use the subroutine ``backwards,'' using
+the relation |make_fraction(t,fraction)=t| between scaled types.
+
+If the result would have magnitude $2^{31}$ or more, |make_fraction|
+sets |arith_error:=true|. Most of \MP's internal computations have
+been designed to avoid this sort of error.
+
+If this subroutine were programmed in assembly language on a typical
+machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
+double-precision product can often be input to a fixed-point division
+instruction. But when we are restricted to int-eger arithmetic it
+is necessary either to resort to multiple-precision maneuvering
+or to use a simple but slow iteration. The multiple-precision technique
+would be about three times faster than the code adopted here, but it
+would be comparatively long and tricky, involving about sixteen
+additional multiplications and divisions.
+
+This operation is part of \MP's ``inner loop''; indeed, it will
+consume nearly 10\pct! of the running time (exclusive of input and output)
+if the code below is left unchanged. A machine-dependent recoding
+will therefore make \MP\ run faster. The present implementation
+is highly portable, but slow; it avoids multiplication and division
+except in the initial stage. System wizards should be careful to
+replace it with a routine that is guaranteed to produce identical
+results in all cases.
+@^system dependencies@>
+
+As noted below, a few more routines should also be replaced by machine-dependent
+code, for efficiency. But when a procedure is not part of the ``inner loop,''
+such changes aren't advisable; simplicity and robustness are
+preferable to trickery, unless the cost is too high.
+@^inner loop@>
+
+@<Internal ...@>=
+fraction mp_make_fraction (MP mp,integer p, integer q);
+integer mp_take_scaled (MP mp,integer q, scaled f) ;
+
+@ If FIXPT is not defined, we need these preprocessor values
+
+@d ELGORDO 0x7fffffff
+@d TWEXP31 2147483648.0
+@d TWEXP28 268435456.0
+@d TWEXP16 65536.0
+@d TWEXP_16 (1.0/65536.0)
+@d TWEXP_28 (1.0/268435456.0)
+
+
+@c
+fraction mp_make_fraction (MP mp,integer p, integer q) {
+#ifdef FIXPT
+ integer f; /* the fraction bits, with a leading 1 bit */
+ integer n; /* the integer part of $\vert p/q\vert$ */
+ integer be_careful; /* disables certain compiler optimizations */
+ boolean negative = false; /* should the result be negated? */
+ if ( p<0 ) {
+ negate(p); negative=true;
+ }
+ if ( q<=0 ) {
+#ifdef DEBUG
+ if ( q==0 ) mp_confusion(mp, '/');
+#endif
+@:this can't happen /}{\quad \./@>
+ negate(q); negative = ! negative;
+ };
+ n=p / q; p=p % q;
+ if ( n>=8 ){
+ mp->arith_error=true;
+ return ( negative ? -el_gordo : el_gordo);
+ } else {
+ n=(n-1)*fraction_one;
+ @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
+ return (negative ? (-(f+n)) : (f+n));
+ }
+#else /* FIXPT */
+ register double d;
+ register integer i;
+#ifdef DEBUG
+ if (q==0) mp_confusion(mp,'/');
+#endif /* DEBUG */
+ d = TWEXP28 * (double)p /(double)q;
+ if ((p^q) >= 0) {
+ d += 0.5;
+ if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
+ i = (integer) d;
+ if (d==i && ( ((q>0 ? -q : q)&077777)
+ * (((i&037777)<<1)-1) & 04000)!=0) --i;
+ } else {
+ d -= 0.5;
+ if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
+ i = (integer) d;
+ if (d==i && ( ((q>0 ? q : -q)&077777)
+ * (((i&037777)<<1)+1) & 04000)!=0) ++i;
+ }
+ return i;
+#endif /* FIXPT */
+}
+
+@ The |repeat| loop here preserves the following invariant relations
+between |f|, |p|, and~|q|:
+(i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
+$p_0$ is the original value of~$p$.
+
+Notice that the computation specifies
+|(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
+Let us hope that optimizing compilers do not miss this point; a
+special variable |be_careful| is used to emphasize the necessary
+order of computation. Optimizing compilers should keep |be_careful|
+in a register, not store it in memory.
+@^inner loop@>
+
+@<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
+{
+ f=1;
+ do {
+ be_careful=p-q; p=be_careful+p;
+ if ( p>=0 ) {
+ f=f+f+1;
+ } else {
+ f+=f; p=p+q;
+ }
+ } while (f<fraction_one);
+ be_careful=p-q;
+ if ( be_careful+p>=0 ) incr(f);
+}
+
+@ The dual of |make_fraction| is |take_fraction|, which multiplies a
+given integer~|q| by a fraction~|f|. When the operands are positive, it
+computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
+of |q| and~|f|.
+
+This routine is even more ``inner loopy'' than |make_fraction|;
+the present implementation consumes almost 20\pct! of \MP's computation
+time during typical jobs, so a machine-language substitute is advisable.
+@^inner loop@> @^system dependencies@>
+
+@<Declarations@>=
+integer mp_take_fraction (MP mp,integer q, fraction f) ;
+
+@ @c
+#ifdef FIXPT
+integer mp_take_fraction (MP mp,integer q, fraction f) {
+ integer p; /* the fraction so far */
+ boolean negative; /* should the result be negated? */
+ integer n; /* additional multiple of $q$ */
+ integer be_careful; /* disables certain compiler optimizations */
+ @<Reduce to the case that |f>=0| and |q>=0|@>;
+ if ( f<fraction_one ) {
+ n=0;
+ } else {
+ n=f / fraction_one; f=f % fraction_one;
+ if ( q<=el_gordo / n ) {
+ n=n*q ;
+ } else {
+ mp->arith_error=true; n=el_gordo;
+ }
+ }
+ f=f+fraction_one;
+ @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
+ be_careful=n-el_gordo;
+ if ( be_careful+p>0 ){
+ mp->arith_error=true; n=el_gordo-p;
+ }
+ if ( negative )
+ return (-(n+p));
+ else
+ return (n+p);
+#else /* FIXPT */
+integer mp_take_fraction (MP mp,integer p, fraction q) {
+ register double d;
+ register integer i;
+ d = (double)p * (double)q * TWEXP_28;
+ if ((p^q) >= 0) {
+ d += 0.5;
+ if (d>=TWEXP31) {
+ if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
+ mp->arith_error = true;
+ return ELGORDO;
+ }
+ i = (integer) d;
+ if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
+ } else {
+ d -= 0.5;
+ if (d<= -TWEXP31) {
+ if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
+ mp->arith_error = true;
+ return -ELGORDO;
+ }
+ i = (integer) d;
+ if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
+ }
+ return i;
+#endif /* FIXPT */
+}
+
+@ @<Reduce to the case that |f>=0| and |q>=0|@>=
+if ( f>=0 ) {
+ negative=false;
+} else {
+ negate( f); negative=true;
+}
+if ( q<0 ) {
+ negate(q); negative=! negative;
+}
+
+@ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
+=\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
+$f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
+@^inner loop@>
+
+@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
+p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
+if ( q<fraction_four ) {
+ do {
+ if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
+ f=halfp(f);
+ } while (f!=1);
+} else {
+ do {
+ if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
+ f=halfp(f);
+ } while (f!=1);
+}
+
+
+@ When we want to multiply something by a |scaled| quantity, we use a scheme
+analogous to |take_fraction| but with a different scaling.
+Given positive operands, |take_scaled|
+computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
+
+Once again it is a good idea to use a machine-language replacement if
+possible; otherwise |take_scaled| will use more than 2\pct! of the running time
+when the Computer Modern fonts are being generated.
+@^inner loop@>
+
+@c
+#ifdef FIXPT
+integer mp_take_scaled (MP mp,integer q, scaled f) {
+ integer p; /* the fraction so far */
+ boolean negative; /* should the result be negated? */
+ integer n; /* additional multiple of $q$ */
+ integer be_careful; /* disables certain compiler optimizations */
+ @<Reduce to the case that |f>=0| and |q>=0|@>;
+ if ( f<unity ) {
+ n=0;
+ } else {
+ n=f / unity; f=f % unity;
+ if ( q<=el_gordo / n ) {
+ n=n*q;
+ } else {
+ mp->arith_error=true; n=el_gordo;
+ }
+ }
+ f=f+unity;
+ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
+ be_careful=n-el_gordo;
+ if ( be_careful+p>0 ) {
+ mp->arith_error=true; n=el_gordo-p;
+ }
+ return ( negative ?(-(n+p)) :(n+p));
+#else /* FIXPT */
+integer mp_take_scaled (MP mp,integer p, scaled q) {
+ register double d;
+ register integer i;
+ d = (double)p * (double)q * TWEXP_16;
+ if ((p^q) >= 0) {
+ d += 0.5;
+ if (d>=TWEXP31) {
+ if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
+ mp->arith_error = true;
+ return ELGORDO;
+ }
+ i = (integer) d;
+ if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
+ } else {
+ d -= 0.5;
+ if (d<= -TWEXP31) {
+ if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
+ mp->arith_error = true;
+ return -ELGORDO;
+ }
+ i = (integer) d;
+ if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
+ }
+ return i;
+#endif /* FIXPT */
+}
+
+@ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
+p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
+@^inner loop@>
+if ( q<fraction_four ) {
+ do {
+ p = (odd(f) ? halfp(p+q) : halfp(p));
+ f=halfp(f);
+ } while (f!=1);
+} else {
+ do {
+ p = (odd(f) ? p+halfp(q-p) : halfp(p));
+ f=halfp(f);
+ } while (f!=1);
+}
+
+@ For completeness, there's also |make_scaled|, which computes a
+quotient as a |scaled| number instead of as a |fraction|.
+In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
+operands are positive. \ (This procedure is not used especially often,
+so it is not part of \MP's inner loop.)
+
+@<Internal library ...@>=
+scaled mp_make_scaled (MP mp,integer p, integer q) ;
+
+@ @c
+scaled mp_make_scaled (MP mp,integer p, integer q) {
+#ifdef FIXPT
+ integer f; /* the fraction bits, with a leading 1 bit */
+ integer n; /* the integer part of $\vert p/q\vert$ */
+ boolean negative; /* should the result be negated? */
+ integer be_careful; /* disables certain compiler optimizations */
+ if ( p>=0 ) negative=false;
+ else { negate(p); negative=true; };
+ if ( q<=0 ) {
+#ifdef DEBUG
+ if ( q==0 ) mp_confusion(mp, "/");
+@:this can't happen /}{\quad \./@>
+#endif
+ negate(q); negative=! negative;
+ }
+ n=p / q; p=p % q;
+ if ( n>=0100000 ) {
+ mp->arith_error=true;
+ return (negative ? (-el_gordo) : el_gordo);
+ } else {
+ n=(n-1)*unity;
+ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
+ return ( negative ? (-(f+n)) :(f+n));
+ }
+#else /* FIXPT */
+ register double d;
+ register integer i;
+#ifdef DEBUG
+ if (q==0) mp_confusion(mp,"/");
+#endif /* DEBUG */
+ d = TWEXP16 * (double)p /(double)q;
+ if ((p^q) >= 0) {
+ d += 0.5;
+ if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
+ i = (integer) d;
+ if (d==i && ( ((q>0 ? -q : q)&077777)
+ * (((i&037777)<<1)-1) & 04000)!=0) --i;
+ } else {
+ d -= 0.5;
+ if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
+ i = (integer) d;
+ if (d==i && ( ((q>0 ? q : -q)&077777)
+ * (((i&037777)<<1)+1) & 04000)!=0) ++i;
+ }
+ return i;
+#endif /* FIXPT */
+}
+
+@ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
+f=1;
+do {
+ be_careful=p-q; p=be_careful+p;
+ if ( p>=0 ) f=f+f+1;
+ else { f+=f; p=p+q; };
+} while (f<unity);
+be_careful=p-q;
+if ( be_careful+p>=0 ) incr(f)
+
+@ Here is a typical example of how the routines above can be used.
+It computes the function
+$${1\over3\tau}f(\theta,\phi)=
+{\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
+ (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
+3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
+where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
+fudge factor for placing the first control point of a curve that starts
+at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
+(Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
+
+The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
+(It's a sum of eight terms whose absolute values can be bounded using
+relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
+is positive; and since the tension $\tau$ is constrained to be at least
+$3\over4$, the numerator is less than $16\over3$. The denominator is
+nonnegative and at most~6. Hence the fixed-point calculations below
+are guaranteed to stay within the bounds of a 32-bit computer word.
+
+The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
+arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
+$\sin\phi$, and $\cos\phi$, respectively.
+
+@c
+fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
+ fraction cf, scaled t) {
+ integer acc,num,denom; /* registers for intermediate calculations */
+ acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
+ acc=mp_take_fraction(mp, acc,ct-cf);
+ num=fraction_two+mp_take_fraction(mp, acc,379625062);
+ /* $2^{28}\sqrt2\approx379625062.497$ */
+ denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
+ /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
+ $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
+ if ( t!=unity ) num=mp_make_scaled(mp, num,t);
+ /* |make_scaled(fraction,scaled)=fraction| */
+ if ( num / 4>=denom )
+ return fraction_four;
+ else
+ return mp_make_fraction(mp, num, denom);
+}
+
+@ The following somewhat different subroutine tests rigorously if $ab$ is
+greater than, equal to, or less than~$cd$,
+given integers $(a,b,c,d)$. In most cases a quick decision is reached.
+The result is $+1$, 0, or~$-1$ in the three respective cases.
+
+@d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
+
+@c
+integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
+ integer q,r; /* temporary registers */
+ @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
+ while (1) {
+ q = a / d; r = c / b;
+ if ( q!=r )
+ return ( q>r ? 1 : -1);
+ q = a % d; r = c % b;
+ if ( r==0 )
+ return (q ? 1 : 0);
+ if ( q==0 ) return -1;
+ a=b; b=q; c=d; d=r;
+ } /* now |a>d>0| and |c>b>0| */
+}
+
+@ @<Reduce to the case that |a...@>=
+if ( a<0 ) { negate(a); negate(b); };
+if ( c<0 ) { negate(c); negate(d); };
+if ( d<=0 ) {
+ if ( b>=0 ) {
+ if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
+ else return 1;
+ }
+ if ( d==0 )
+ return ( a==0 ? 0 : -1);
+ q=a; a=c; c=q; q=-b; b=-d; d=q;
+} else if ( b<=0 ) {
+ if ( b<0 ) if ( a>0 ) return -1;
+ return (c==0 ? 0 : -1);
+}
+
+@ We conclude this set of elementary routines with some simple rounding
+and truncation operations.
+
+@<Internal library declarations@>=
+#define mp_floor_scaled(M,i) ((i)&(-65536))
+#define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
+#define mp_round_fraction(M,i) (((i>>11)+1)>>1)
+
+
+@* \[8] Algebraic and transcendental functions.
+\MP\ computes all of the necessary special functions from scratch, without
+relying on |real| arithmetic or system subroutines for sines, cosines, etc.
+
+@ To get the square root of a |scaled| number |x|, we want to calculate
+$s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
+integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
+determines $s$ by an iterative method that maintains the invariant
+relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
+-s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
+might, however, be zero at the start of the first iteration.
+
+@<Declarations@>=
+scaled mp_square_rt (MP mp,scaled x) ;
+
+@ @c
+scaled mp_square_rt (MP mp,scaled x) {
+ small_number k; /* iteration control counter */
+ integer y,q; /* registers for intermediate calculations */
+ if ( x<=0 ) {
+ @<Handle square root of zero or negative argument@>;
+ } else {
+ k=23; q=2;
+ while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
+ decr(k); x=x+x+x+x;
+ }
+ if ( x<fraction_four ) y=0;
+ else { x=x-fraction_four; y=1; };
+ do {
+ @<Decrease |k| by 1, maintaining the invariant
+ relations between |x|, |y|, and~|q|@>;
+ } while (k!=0);
+ return (halfp(q));
+ }
+}
+
+@ @<Handle square root of zero...@>=
+{
+ if ( x<0 ) {
+ print_err("Square root of ");
+@.Square root...replaced by 0@>
+ mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
+ help2("Since I don't take square roots of negative numbers,")
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_error(mp);
+ };
+ return 0;
+}
+
+@ @<Decrease |k| by 1, maintaining...@>=
+x+=x; y+=y;
+if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
+ x=x-fraction_four; incr(y);
+};
+x+=x; y=y+y-q; q+=q;
+if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
+if ( y>q ){ y=y-q; q=q+2; }
+else if ( y<=0 ) { q=q-2; y=y+q; };
+decr(k)
+
+@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
+iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
+@^Moler, Cleve Barry@>
+@^Morrison, Donald Ross@>
+of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
+in such a way that their Pythagorean sum remains invariant, while the
+smaller argument decreases.
+
+@<Internal library ...@>=
+integer mp_pyth_add (MP mp,integer a, integer b);
+
+
+@ @c
+integer mp_pyth_add (MP mp,integer a, integer b) {
+ fraction r; /* register used to transform |a| and |b| */
+ boolean big; /* is the result dangerously near $2^{31}$? */
+ a=abs(a); b=abs(b);
+ if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
+ if ( b>0 ) {
+ if ( a<fraction_two ) {
+ big=false;
+ } else {
+ a=a / 4; b=b / 4; big=true;
+ }; /* we reduced the precision to avoid arithmetic overflow */
+ @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
+ if ( big ) {
+ if ( a<fraction_two ) {
+ a=a+a+a+a;
+ } else {
+ mp->arith_error=true; a=el_gordo;
+ };
+ }
+ }
+ return a;
+}
+
+@ The key idea here is to reflect the vector $(a,b)$ about the
+line through $(a,b/2)$.
+
+@<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
+while (1) {
+ r=mp_make_fraction(mp, b,a);
+ r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
+ if ( r==0 ) break;
+ r=mp_make_fraction(mp, r,fraction_four+r);
+ a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
+}
+
+
+@ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
+It converges slowly when $b$ is near $a$, but otherwise it works fine.
+
+@c
+integer mp_pyth_sub (MP mp,integer a, integer b) {
+ fraction r; /* register used to transform |a| and |b| */
+ boolean big; /* is the input dangerously near $2^{31}$? */
+ a=abs(a); b=abs(b);
+ if ( a<=b ) {
+ @<Handle erroneous |pyth_sub| and set |a:=0|@>;
+ } else {
+ if ( a<fraction_four ) {
+ big=false;
+ } else {
+ a=halfp(a); b=halfp(b); big=true;
+ }
+ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
+ if ( big ) double(a);
+ }
+ return a;
+}
+
+@ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
+while (1) {
+ r=mp_make_fraction(mp, b,a);
+ r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
+ if ( r==0 ) break;
+ r=mp_make_fraction(mp, r,fraction_four-r);
+ a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
+}
+
+@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
+{
+ if ( a<b ){
+ print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
+ mp_print(mp, "+-+"); mp_print_scaled(mp, b);
+ mp_print(mp, " has been replaced by 0");
+@.Pythagorean...@>
+ help2("Since I don't take square roots of negative numbers,")
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_error(mp);
+ }
+ a=0;
+}
+
+@ The subroutines for logarithm and exponential involve two tables.
+The first is simple: |two_to_the[k]| equals $2^k$. The second involves
+a bit more calculation, which the author claims to have done correctly:
+|spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
+2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
+nearest integer.
+
+@d two_to_the(A) (1<<(A))
+
+@<Constants ...@>=
+static const integer spec_log[29] = { 0, /* special logarithms */
+93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
+1052693, 525315, 262400, 131136, 65552, 32772, 16385,
+8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
+
+@ @<Local variables for initialization@>=
+integer k; /* all-purpose loop index */
+
+
+@ Here is the routine that calculates $2^8$ times the natural logarithm
+of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
+when |x| is a given positive integer.
+
+The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
+Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
+and the logarithm of $2^{30}x$ remains to be added to an accumulator
+register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
+during the calculation, and sixteen auxiliary bits to extend |y| are
+kept in~|z| during the initial argument reduction. (We add
+$100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
+not become negative; also, the actual amount subtracted from~|y| is~96,
+not~100, because we want to add~4 for rounding before the final division by~8.)
+
+@c
+scaled mp_m_log (MP mp,scaled x) {
+ integer y,z; /* auxiliary registers */
+ integer k; /* iteration counter */
+ if ( x<=0 ) {
+ @<Handle non-positive logarithm@>;
+ } else {
+ y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
+ z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
+ while ( x<fraction_four ) {
+ double(x); y-=93032639; z-=48782;
+ } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
+ y=y+(z / unity); k=2;
+ while ( x>fraction_four+4 ) {
+ @<Increase |k| until |x| can be multiplied by a
+ factor of $2^{-k}$, and adjust $y$ accordingly@>;
+ }
+ return (y / 8);
+ }
+}
+
+@ @<Increase |k| until |x| can...@>=
+{
+ z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
+ while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
+ y+=spec_log[k]; x-=z;
+}
+
+@ @<Handle non-positive logarithm@>=
+{
+ print_err("Logarithm of ");
+@.Logarithm...replaced by 0@>
+ mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
+ help2("Since I don't take logs of non-positive numbers,")
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_error(mp);
+ return 0;
+}
+
+@ Conversely, the exponential routine calculates $\exp(x/2^8)$,
+when |x| is |scaled|. The result is an integer approximation to
+$2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
+
+@c
+scaled mp_m_exp (MP mp,scaled x) {
+ small_number k; /* loop control index */
+ integer y,z; /* auxiliary registers */
+ if ( x>174436200 ) {
+ /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
+ mp->arith_error=true;
+ return el_gordo;
+ } else if ( x<-197694359 ) {
+ /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
+ return 0;
+ } else {
+ if ( x<=0 ) {
+ z=-8*x; y=04000000; /* $y=2^{20}$ */
+ } else {
+ if ( x<=127919879 ) {
+ z=1023359037-8*x;
+ /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
+ } else {
+ z=8*(174436200-x); /* |z| is always nonnegative */
+ }
+ y=el_gordo;
+ };
+ @<Multiply |y| by $\exp(-z/2^{27})$@>;
+ if ( x<=127919879 )
+ return ((y+8) / 16);
+ else
+ return y;
+ }
+}
+
+@ The idea here is that subtracting |spec_log[k]| from |z| corresponds
+to multiplying |y| by $1-2^{-k}$.
+
+A subtle point (which had to be checked) was that if $x=127919879$, the
+value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
+$z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
+and by~16 when |k=27|.
+
+@<Multiply |y| by...@>=
+k=1;
+while ( z>0 ) {
+ while ( z>=spec_log[k] ) {
+ z-=spec_log[k];
+ y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
+ }
+ incr(k);
+}
+
+@ The trigonometric subroutines use an auxiliary table such that
+|spec_atan[k]| contains an approximation to the |angle| whose tangent
+is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
+
+@<Constants ...@>=
+static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
+1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
+1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
+
+@ Given integers |x| and |y|, not both zero, the |n_arg| function
+returns the |angle| whose tangent points in the direction $(x,y)$.
+This subroutine first determines the correct octant, then solves the
+problem for |0<=y<=x|, then converts the result appropriately to
+return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
+(The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
+|-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
+
+The octants are represented in a ``Gray code,'' since that turns out
+to be computationally simplest.
+
+@d negate_x 1
+@d negate_y 2
+@d switch_x_and_y 4
+@d first_octant 1
+@d second_octant (first_octant+switch_x_and_y)
+@d third_octant (first_octant+switch_x_and_y+negate_x)
+@d fourth_octant (first_octant+negate_x)
+@d fifth_octant (first_octant+negate_x+negate_y)
+@d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
+@d seventh_octant (first_octant+switch_x_and_y+negate_y)
+@d eighth_octant (first_octant+negate_y)
+
+@c
+angle mp_n_arg (MP mp,integer x, integer y) {
+ angle z; /* auxiliary register */
+ integer t; /* temporary storage */
+ small_number k; /* loop counter */
+ int octant; /* octant code */
+ if ( x>=0 ) {
+ octant=first_octant;
+ } else {
+ negate(x); octant=first_octant+negate_x;
+ }
+ if ( y<0 ) {
+ negate(y); octant=octant+negate_y;
+ }
+ if ( x<y ) {
+ t=y; y=x; x=t; octant=octant+switch_x_and_y;
+ }
+ if ( x==0 ) {
+ @<Handle undefined arg@>;
+ } else {
+ @<Set variable |z| to the arg of $(x,y)$@>;
+ @<Return an appropriate answer based on |z| and |octant|@>;
+ }
+}
+
+@ @<Handle undefined arg@>=
+{
+ print_err("angle(0,0) is taken as zero");
+@.angle(0,0)...zero@>
+ help2("The `angle' between two identical points is undefined.")
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_error(mp);
+ return 0;
+}
+
+@ @<Return an appropriate answer...@>=
+switch (octant) {
+case first_octant: return z;
+case second_octant: return (ninety_deg-z);
+case third_octant: return (ninety_deg+z);
+case fourth_octant: return (one_eighty_deg-z);
+case fifth_octant: return (z-one_eighty_deg);
+case sixth_octant: return (-z-ninety_deg);
+case seventh_octant: return (z-ninety_deg);
+case eighth_octant: return (-z);
+}; /* there are no other cases */
+return 0
+
+@ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
+or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
+will be made.
+
+@<Set variable |z| to the arg...@>=
+while ( x>=fraction_two ) {
+ x=halfp(x); y=halfp(y);
+}
+z=0;
+if ( y>0 ) {
+ while ( x<fraction_one ) {
+ x+=x; y+=y;
+ };
+ @<Increase |z| to the arg of $(x,y)$@>;
+}
+
+@ During the calculations of this section, variables |x| and~|y|
+represent actual coordinates $(x,2^{-k}y)$. We will maintain the
+condition |x>=y|, so that the tangent will be at most $2^{-k}$.
+If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
+$(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
+coordinates whose angle has decreased by~$\phi$; in the special case
+$a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
+to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
+@^Meggitt, John E.@>
+{\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
+
+The initial value of |x| will be multiplied by at most
+$(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
+there is no chance of integer overflow.
+
+@<Increase |z|...@>=
+k=0;
+do {
+ y+=y; incr(k);
+ if ( y>x ){
+ z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
+ };
+} while (k!=15);
+do {
+ y+=y; incr(k);
+ if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
+} while (k!=26)
+
+@ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
+and cosine of that angle. The results of this routine are
+stored in global integer variables |n_sin| and |n_cos|.
+
+@<Glob...@>=
+fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
+
+@ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
+the purpose of |n_sin_cos(z)| is to set
+|x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
+for some rather large number~|r|. The maximum of |x| and |y|
+will be between $2^{28}$ and $2^{30}$, so that there will be hardly
+any loss of accuracy. Then |x| and~|y| are divided by~|r|.
+
+@c
+void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
+ and cosine */
+ small_number k; /* loop control variable */
+ int q; /* specifies the quadrant */
+ fraction r; /* magnitude of |(x,y)| */
+ integer x,y,t; /* temporary registers */
+ while ( z<0 ) z=z+three_sixty_deg;
+ z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
+ q=z / forty_five_deg; z=z % forty_five_deg;
+ x=fraction_one; y=x;
+ if ( ! odd(q) ) z=forty_five_deg-z;
+ @<Subtract angle |z| from |(x,y)|@>;
+ @<Convert |(x,y)| to the octant determined by~|q|@>;
+ r=mp_pyth_add(mp, x,y);
+ mp->n_cos=mp_make_fraction(mp, x,r);
+ mp->n_sin=mp_make_fraction(mp, y,r);
+}
+
+@ In this case the octants are numbered sequentially.
+
+@<Convert |(x,...@>=
+switch (q) {
+case 0: break;
+case 1: t=x; x=y; y=t; break;
+case 2: t=x; x=-y; y=t; break;
+case 3: negate(x); break;
+case 4: negate(x); negate(y); break;
+case 5: t=x; x=-y; y=-t; break;
+case 6: t=x; x=y; y=-t; break;
+case 7: negate(y); break;
+} /* there are no other cases */
+
+@ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
+applied in reverse. The values of |spec_atan[k]| decrease slowly enough
+that this loop is guaranteed to terminate before the (nonexistent) value
+|spec_atan[27]| would be required.
+
+@<Subtract angle |z|...@>=
+k=1;
+while ( z>0 ){
+ if ( z>=spec_atan[k] ) {
+ z=z-spec_atan[k]; t=x;
+ x=t+y / two_to_the(k);
+ y=y-t / two_to_the(k);
+ }
+ incr(k);
+}
+if ( y<0 ) y=0 /* this precaution may never be needed */
+
+@ And now let's complete our collection of numeric utility routines
+by considering random number generation.
+\MP\ generates pseudo-random numbers with the additive scheme recommended
+in Section 3.6 of {\sl The Art of Computer Programming}; however, the
+results are random fractions between 0 and |fraction_one-1|, inclusive.
+
+There's an auxiliary array |randoms| that contains 55 pseudo-random
+fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
+we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
+The global variable |j_random| tells which element has most recently
+been consumed.
+The global variable |random_seed| was introduced in version 0.9,
+for the sole reason of stressing the fact that the initial value of the
+random seed is system-dependant. The initialization code below will initialize
+this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
+is not good enough on modern fast machines that are capable of running
+multiple MetaPost processes within the same second.
+@^system dependencies@>
+
+@<Glob...@>=
+fraction randoms[55]; /* the last 55 random values generated */
+int j_random; /* the number of unused |randoms| */
+
+@ @<Option variables@>=
+int random_seed; /* the default random seed */
+
+@ @<Allocate or initialize ...@>=
+mp->random_seed = (scaled)opt->random_seed;
+
+@ To consume a random fraction, the program below will say `|next_random|'
+and then it will fetch |randoms[j_random]|.
+
+@d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
+ else decr(mp->j_random); }
+
+@c
+void mp_new_randoms (MP mp) {
+ int k; /* index into |randoms| */
+ fraction x; /* accumulator */
+ for (k=0;k<=23;k++) {
+ x=mp->randoms[k]-mp->randoms[k+31];
+ if ( x<0 ) x=x+fraction_one;
+ mp->randoms[k]=x;
+ }
+ for (k=24;k<= 54;k++){
+ x=mp->randoms[k]-mp->randoms[k-24];
+ if ( x<0 ) x=x+fraction_one;
+ mp->randoms[k]=x;
+ }
+ mp->j_random=54;
+}
+
+@ @<Declarations@>=
+void mp_init_randoms (MP mp,scaled seed);
+
+@ To initialize the |randoms| table, we call the following routine.
+
+@c
+void mp_init_randoms (MP mp,scaled seed) {
+ fraction j,jj,k; /* more or less random integers */
+ int i; /* index into |randoms| */
+ j=abs(seed);
+ while ( j>=fraction_one ) j=halfp(j);
+ k=1;
+ for (i=0;i<=54;i++ ){
+ jj=k; k=j-k; j=jj;
+ if ( k<0 ) k=k+fraction_one;
+ mp->randoms[(i*21)% 55]=j;
+ }
+ mp_new_randoms(mp);
+ mp_new_randoms(mp);
+ mp_new_randoms(mp); /* ``warm up'' the array */
+}
+
+@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
+or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
+
+Note that the call of |take_fraction| will produce the values 0 and~|x|
+with about half the probability that it will produce any other particular
+values between 0 and~|x|, because it rounds its answers.
+
+@c
+scaled mp_unif_rand (MP mp,scaled x) {
+ scaled y; /* trial value */
+ next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
+ if ( y==abs(x) ) return 0;
+ else if ( x>0 ) return y;
+ else return (-y);
+}
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}).
+
+@c
+scaled mp_norm_rand (MP mp) {
+ integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
+ do {
+ do {
+ next_random;
+ x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
+ /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
+ next_random; u=mp->randoms[mp->j_random];
+ } while (abs(x)>=u);
+ x=mp_make_fraction(mp, x,u);
+ l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
+ } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
+ return x;
+}
+
+@* \[9] Packed data.
+In order to make efficient use of storage space, \MP\ bases its major data
+structures on a |memory_word|, which contains either a (signed) integer,
+possibly scaled, or a small number of fields that are one half or one
+quarter of the size used for storing integers.
+
+If |x| is a variable of type |memory_word|, it contains up to four
+fields that can be referred to as follows:
+$$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
+|x|&.|int|&(an |integer|)\cr
+|x|&.|sc|\qquad&(a |scaled| integer)\cr
+|x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
+|x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
+ field)\cr
+|x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
+ &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
+This is somewhat cumbersome to write, and not very readable either, but
+macros will be used to make the notation shorter and more transparent.
+The code below gives a formal definition of |memory_word| and
+its subsidiary types, using packed variant records. \MP\ makes no
+assumptions about the relative positions of the fields within a word.
+
+@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
+@d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
+
+@ Here are the inequalities that the quarterword and halfword values
+must satisfy (or rather, the inequalities that they mustn't satisfy):
+
+@<Check the ``constant''...@>=
+if (mp->ini_version) {
+ if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
+} else {
+ if ( mp->mem_max<mp->mem_top ) mp->bad=8;
+}
+if ( max_quarterword<255 ) mp->bad=9;
+if ( max_halfword<65535 ) mp->bad=10;
+if ( max_quarterword>max_halfword ) mp->bad=11;
+if ( mp->mem_max>=max_halfword ) mp->bad=12;
+if ( mp->max_strings>max_halfword ) mp->bad=13;
+
+@ The macros |qi| and |qo| are used for input to and output
+from quarterwords. These are legacy macros.
+@^system dependencies@>
+
+@d qo(A) (A) /* to read eight bits from a quarterword */
+@d qi(A) (A) /* to store eight bits in a quarterword */
+
+@ The reader should study the following definitions closely:
+@^system dependencies@>
+
+@d sc cint /* |scaled| data is equivalent to |integer| */
+
+@<Types...@>=
+typedef short quarterword; /* 1/4 of a word */
+typedef int halfword; /* 1/2 of a word */
+typedef union {
+ struct {
+ halfword RH, LH;
+ } v;
+ struct { /* Make B0,B1 overlap the most significant bytes of LH. */
+ halfword junk;
+ quarterword B0, B1;
+ } u;
+} two_halves;
+typedef struct {
+ struct {
+ quarterword B2, B3, B0, B1;
+ } u;
+} four_quarters;
+typedef union {
+ two_halves hh;
+ integer cint;
+ four_quarters qqqq;
+} memory_word;
+#define b0 u.B0
+#define b1 u.B1
+#define b2 u.B2
+#define b3 u.B3
+#define rh v.RH
+#define lh v.LH
+
+@ When debugging, we may want to print a |memory_word| without knowing
+what type it is; so we print it in all modes.
+@^debugging@>
+
+@c
+void mp_print_word (MP mp,memory_word w) {
+ /* prints |w| in all ways */
+ mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
+ mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
+ mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
+ mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
+ mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
+ mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
+ mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
+ mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
+ mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
+ mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
+ mp_print_int(mp, w.qqqq.b3);
+}
+
+
+@* \[10] Dynamic memory allocation.
+
+The \MP\ system does nearly all of its own memory allocation, so that it
+can readily be transported into environments that do not have automatic
+facilities for strings, garbage collection, etc., and so that it can be in
+control of what error messages the user receives. The dynamic storage
+requirements of \MP\ are handled by providing a large array |mem| in
+which consecutive blocks of words are used as nodes by the \MP\ routines.
+
+Pointer variables are indices into this array, or into another array
+called |eqtb| that will be explained later. A pointer variable might
+also be a special flag that lies outside the bounds of |mem|, so we
+allow pointers to assume any |halfword| value. The minimum memory
+index represents a null pointer.
+
+@d null 0 /* the null pointer */
+@d mp_void (null+1) /* a null pointer different from |null| */
+
+
+@<Types...@>=
+typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
+
+@ The |mem| array is divided into two regions that are allocated separately,
+but the dividing line between these two regions is not fixed; they grow
+together until finding their ``natural'' size in a particular job.
+Locations less than or equal to |lo_mem_max| are used for storing
+variable-length records consisting of two or more words each. This region
+is maintained using an algorithm similar to the one described in exercise
+2.5--19 of {\sl The Art of Computer Programming}. However, no size field
+appears in the allocated nodes; the program is responsible for knowing the
+relevant size when a node is freed. Locations greater than or equal to
+|hi_mem_min| are used for storing one-word records; a conventional
+\.{AVAIL} stack is used for allocation in this region.
+
+Locations of |mem| between |0| and |mem_top| may be dumped as part
+of preloaded mem files, by the \.{INIMP} preprocessor.
+@.INIMP@>
+Production versions of \MP\ may extend the memory at the top end in order to
+provide more space; these locations, between |mem_top| and |mem_max|,
+are always used for single-word nodes.
+
+The key pointers that govern |mem| allocation have a prescribed order:
+$$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
+
+@<Glob...@>=
+memory_word *mem; /* the big dynamic storage area */
+pointer lo_mem_max; /* the largest location of variable-size memory in use */
+pointer hi_mem_min; /* the smallest location of one-word memory in use */
+
+
+@
+@d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
+@d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
+@d xmalloc(A,B) mp_xmalloc(mp,A,B)
+@d xstrdup(A) mp_xstrdup(mp,A)
+@d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
+
+@<Declare helpers@>=
+void mp_xfree (void *x);
+void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
+void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
+char *mp_xstrdup(MP mp, const char *s);
+
+@ The |max_size_test| guards against overflow, on the assumption that
+|size_t| is at least 31bits wide.
+
+@d max_size_test 0x7FFFFFFF
+
+@c
+void mp_xfree (void *x) {
+ if (x!=NULL) free(x);
+}
+void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
+ void *w ;
+ if ((max_size_test/size)<nmem) {
+ do_fprintf(mp->err_out,"Memory size overflow!\n");
+ mp->history =mp_fatal_error_stop; mp_jump_out(mp);
+ }
+ w = realloc (p,(nmem*size));
+ if (w==NULL) {
+ do_fprintf(mp->err_out,"Out of memory!\n");
+ mp->history =mp_fatal_error_stop; mp_jump_out(mp);
+ }
+ return w;
+}
+void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
+ void *w;
+ if ((max_size_test/size)<nmem) {
+ do_fprintf(mp->err_out,"Memory size overflow!\n");
+ mp->history =mp_fatal_error_stop; mp_jump_out(mp);
+ }
+ w = malloc (nmem*size);
+ if (w==NULL) {
+ do_fprintf(mp->err_out,"Out of memory!\n");
+ mp->history =mp_fatal_error_stop; mp_jump_out(mp);
+ }
+ return w;
+}
+char *mp_xstrdup(MP mp, const char *s) {
+ char *w;
+ if (s==NULL)
+ return NULL;
+ w = strdup(s);
+ if (w==NULL) {
+ do_fprintf(mp->err_out,"Out of memory!\n");
+ mp->history =mp_fatal_error_stop; mp_jump_out(mp);
+ }
+ return w;
+}
+
+
+@
+@<Allocate or initialize ...@>=
+mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
+memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
+
+@ @<Dealloc variables@>=
+xfree(mp->mem);
+
+@ Users who wish to study the memory requirements of particular applications can
+can use optional special features that keep track of current and
+maximum memory usage. When code between the delimiters |stat| $\ldots$
+|tats| is not ``commented out,'' \MP\ will run a bit slower but it will
+report these statistics when |mp_tracing_stats| is positive.
+
+@<Glob...@>=
+integer var_used; integer dyn_used; /* how much memory is in use */
+
+@ Let's consider the one-word memory region first, since it's the
+simplest. The pointer variable |mem_end| holds the highest-numbered location
+of |mem| that has ever been used. The free locations of |mem| that
+occur between |hi_mem_min| and |mem_end|, inclusive, are of type
+|two_halves|, and we write |info(p)| and |link(p)| for the |lh|
+and |rh| fields of |mem[p]| when it is of this type. The single-word
+free locations form a linked list
+$$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
+terminated by |null|.
+
+@d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
+@d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
+
+@<Glob...@>=
+pointer avail; /* head of the list of available one-word nodes */
+pointer mem_end; /* the last one-word node used in |mem| */
+
+@ If one-word memory is exhausted, it might mean that the user has forgotten
+a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
+later that try to help pinpoint the trouble.
+
+@c
+@<Declare the procedure called |show_token_list|@>
+@<Declare the procedure called |runaway|@>
+
+@ The function |get_avail| returns a pointer to a new one-word node whose
+|link| field is null. However, \MP\ will halt if there is no more room left.
+@^inner loop@>
+
+@c
+pointer mp_get_avail (MP mp) { /* single-word node allocation */
+ pointer p; /* the new node being got */
+ p=mp->avail; /* get top location in the |avail| stack */
+ if ( p!=null ) {
+ mp->avail=link(mp->avail); /* and pop it off */
+ } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
+ incr(mp->mem_end); p=mp->mem_end;
+ } else {
+ decr(mp->hi_mem_min); p=mp->hi_mem_min;
+ if ( mp->hi_mem_min<=mp->lo_mem_max ) {
+ mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
+ mp_overflow(mp, "main memory size",mp->mem_max);
+ /* quit; all one-word nodes are busy */
+@:MetaPost capacity exceeded main memory size}{\quad main memory size@>
+ }
+ }
+ link(p)=null; /* provide an oft-desired initialization of the new node */
+ incr(mp->dyn_used);/* maintain statistics */
+ return p;
+}
+
+@ Conversely, a one-word node is recycled by calling |free_avail|.
+
+@d free_avail(A) /* single-word node liberation */
+ { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
+
+@ There's also a |fast_get_avail| routine, which saves the procedure-call
+overhead at the expense of extra programming. This macro is used in
+the places that would otherwise account for the most calls of |get_avail|.
+@^inner loop@>
+
+@d fast_get_avail(A) {
+ (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
+ if ( (A)==null ) { (A)=mp_get_avail(mp); }
+ else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
+ }
+
+@ The available-space list that keeps track of the variable-size portion
+of |mem| is a nonempty, doubly-linked circular list of empty nodes,
+pointed to by the roving pointer |rover|.
+
+Each empty node has size 2 or more; the first word contains the special
+value |max_halfword| in its |link| field and the size in its |info| field;
+the second word contains the two pointers for double linking.
+
+Each nonempty node also has size 2 or more. Its first word is of type
+|two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
+Otherwise there is complete flexibility with respect to the contents
+of its other fields and its other words.
+
+(We require |mem_max<max_halfword| because terrible things can happen
+when |max_halfword| appears in the |link| field of a nonempty node.)
+
+@d empty_flag max_halfword /* the |link| of an empty variable-size node */
+@d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
+@d node_size info /* the size field in empty variable-size nodes */
+@d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
+@d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
+
+@<Glob...@>=
+pointer rover; /* points to some node in the list of empties */
+
+@ A call to |get_node| with argument |s| returns a pointer to a new node
+of size~|s|, which must be 2~or more. The |link| field of the first word
+of this new node is set to null. An overflow stop occurs if no suitable
+space exists.
+
+If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
+areas and returns the value |max_halfword|.
+
+@<Internal library declarations@>=
+pointer mp_get_node (MP mp,integer s) ;
+
+@ @c
+pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
+ pointer p; /* the node currently under inspection */
+ pointer q; /* the node physically after node |p| */
+ integer r; /* the newly allocated node, or a candidate for this honor */
+ integer t,tt; /* temporary registers */
+@^inner loop@>
+ RESTART:
+ p=mp->rover; /* start at some free node in the ring */
+ do {
+ @<Try to allocate within node |p| and its physical successors,
+ and |goto found| if allocation was possible@>;
+ if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
+ print_err("Free list garbled");
+ help3("I found an entry in the list of free nodes that links")
+ ("badly. I will try to ignore the broken link, but something")
+ ("is seriously amiss. It is wise to warn the maintainers.")
+ mp_error(mp);
+ rlink(p)=mp->rover;
+ }
+ p=rlink(p); /* move to the next node in the ring */
+ } while (p!=mp->rover); /* repeat until the whole list has been traversed */
+ if ( s==010000000000 ) {
+ return max_halfword;
+ };
+ if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
+ if ( mp->lo_mem_max+2<=max_halfword ) {
+ @<Grow more variable-size memory and |goto restart|@>;
+ }
+ }
+ mp_overflow(mp, "main memory size",mp->mem_max);
+ /* sorry, nothing satisfactory is left */
+@:MetaPost capacity exceeded main memory size}{\quad main memory size@>
+FOUND:
+ link(r)=null; /* this node is now nonempty */
+ mp->var_used+=s; /* maintain usage statistics */
+ return r;
+}
+
+@ The lower part of |mem| grows by 1000 words at a time, unless
+we are very close to going under. When it grows, we simply link
+a new node into the available-space list. This method of controlled
+growth helps to keep the |mem| usage consecutive when \MP\ is
+implemented on ``virtual memory'' systems.
+@^virtual memory@>
+
+@<Grow more variable-size memory and |goto restart|@>=
+{
+ if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
+ t=mp->lo_mem_max+1000;
+ } else {
+ t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
+ /* |lo_mem_max+2<=t<hi_mem_min| */
+ }
+ if ( t>max_halfword ) t=max_halfword;
+ p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
+ rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
+ node_size(q)=t-mp->lo_mem_max;
+ mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
+ mp->rover=q;
+ goto RESTART;
+}
+
+@ @<Try to allocate...@>=
+q=p+node_size(p); /* find the physical successor */
+while ( is_empty(q) ) { /* merge node |p| with node |q| */
+ t=rlink(q); tt=llink(q);
+@^inner loop@>
+ if ( q==mp->rover ) mp->rover=t;
+ llink(t)=tt; rlink(tt)=t;
+ q=q+node_size(q);
+}
+r=q-s;
+if ( r>p+1 ) {
+ @<Allocate from the top of node |p| and |goto found|@>;
+}
+if ( r==p ) {
+ if ( rlink(p)!=p ) {
+ @<Allocate entire node |p| and |goto found|@>;
+ }
+}
+node_size(p)=q-p /* reset the size in case it grew */
+
+@ @<Allocate from the top...@>=
+{
+ node_size(p)=r-p; /* store the remaining size */
+ mp->rover=p; /* start searching here next time */
+ goto FOUND;
+}
+
+@ Here we delete node |p| from the ring, and let |rover| rove around.
+
+@<Allocate entire...@>=
+{
+ mp->rover=rlink(p); t=llink(p);
+ llink(mp->rover)=t; rlink(t)=mp->rover;
+ goto FOUND;
+}
+
+@ Conversely, when some variable-size node |p| of size |s| is no longer needed,
+the operation |free_node(p,s)| will make its words available, by inserting
+|p| as a new empty node just before where |rover| now points.
+
+@<Internal library declarations@>=
+void mp_free_node (MP mp, pointer p, halfword s) ;
+
+@ @c
+void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
+ liberation */
+ pointer q; /* |llink(rover)| */
+ node_size(p)=s; link(p)=empty_flag;
+@^inner loop@>
+ q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
+ llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
+ mp->var_used-=s; /* maintain statistics */
+}
+
+@ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
+available space list. The list is probably very short at such times, so a
+simple insertion sort is used. The smallest available location will be
+pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
+
+@c
+void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
+ by location */
+ pointer p,q,r; /* indices into |mem| */
+ pointer old_rover; /* initial |rover| setting */
+ p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
+ p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
+ while ( p!=old_rover ) {
+ @<Sort |p| into the list starting at |rover|
+ and advance |p| to |rlink(p)|@>;
+ }
+ p=mp->rover;
+ while ( rlink(p)!=max_halfword ) {
+ llink(rlink(p))=p; p=rlink(p);
+ };
+ rlink(p)=mp->rover; llink(mp->rover)=p;
+}
+
+@ The following |while| loop is guaranteed to
+terminate, since the list that starts at
+|rover| ends with |max_halfword| during the sorting procedure.
+
+@<Sort |p|...@>=
+if ( p<mp->rover ) {
+ q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
+} else {
+ q=mp->rover;
+ while ( rlink(q)<p ) q=rlink(q);
+ r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
+}
+
+@* \[11] Memory layout.
+Some areas of |mem| are dedicated to fixed usage, since static allocation is
+more efficient than dynamic allocation when we can get away with it. For
+example, locations |0| to |1| are always used to store a
+two-word dummy token whose second word is zero.
+The following macro definitions accomplish the static allocation by giving
+symbolic names to the fixed positions. Static variable-size nodes appear
+in locations |0| through |lo_mem_stat_max|, and static single-word nodes
+appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
+
+@d null_dash (2) /* the first two words are reserved for a null value */
+@d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
+@d zero_val (dep_head+2) /* two words for a permanently zero value */
+@d temp_val (zero_val+2) /* two words for a temporary value node */
+@d end_attr temp_val /* we use |end_attr+2| only */
+@d inf_val (end_attr+2) /* and |inf_val+1| only */
+@d test_pen (inf_val+2)
+ /* nine words for a pen used when testing the turning number */
+@d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
+@d lo_mem_stat_max (bad_vardef+1) /* largest statically
+ allocated word in the variable-size |mem| */
+@#
+@d sentinel mp->mem_top /* end of sorted lists */
+@d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
+@d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
+@d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
+@d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
+ the one-word |mem| */
+
+@ The following code gets the dynamic part of |mem| off to a good start,
+when \MP\ is initializing itself the slow way.
+
+@<Initialize table entries (done by \.{INIMP} only)@>=
+mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
+link(mp->rover)=empty_flag;
+node_size(mp->rover)=1000; /* which is a 1000-word available node */
+llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
+mp->lo_mem_max=mp->rover+1000;
+link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
+for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
+ mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
+}
+mp->avail=null; mp->mem_end=mp->mem_top;
+mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
+mp->var_used=lo_mem_stat_max+1;
+mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
+@<Initialize a pen at |test_pen| so that it fits in nine words@>;
+
+@ The procedure |flush_list(p)| frees an entire linked list of one-word
+nodes that starts at a given position, until coming to |sentinel| or a
+pointer that is not in the one-word region. Another procedure,
+|flush_node_list|, frees an entire linked list of one-word and two-word
+nodes, until coming to a |null| pointer.
+@^inner loop@>
+
+@c
+void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
+ pointer q,r; /* list traversers */
+ if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
+ r=p;
+ do {
+ q=r; r=link(r);
+ decr(mp->dyn_used);
+ if ( r<mp->hi_mem_min ) break;
+ } while (r!=sentinel);
+ /* now |q| is the last node on the list */
+ link(q)=mp->avail; mp->avail=p;
+ }
+}
+@#
+void mp_flush_node_list (MP mp,pointer p) {
+ pointer q; /* the node being recycled */
+ while ( p!=null ){
+ q=p; p=link(p);
+ if ( q<mp->hi_mem_min )
+ mp_free_node(mp, q,2);
+ else
+ free_avail(q);
+ }
+}
+
+@ If \MP\ is extended improperly, the |mem| array might get screwed up.
+For example, some pointers might be wrong, or some ``dead'' nodes might not
+have been freed when the last reference to them disappeared. Procedures
+|check_mem| and |search_mem| are available to help diagnose such
+problems. These procedures make use of two arrays called |free| and
+|was_free| that are present only if \MP's debugging routines have
+been included. (You may want to decrease the size of |mem| while you
+@^debugging@>
+are debugging.)
+
+Because |boolean|s are typedef-d as ints, it is better to use
+unsigned chars here.
+
+@<Glob...@>=
+unsigned char *free; /* free cells */
+unsigned char *was_free; /* previously free cells */
+pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
+ /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
+boolean panicking; /* do we want to check memory constantly? */
+
+@ @<Allocate or initialize ...@>=
+mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
+mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
+
+@ @<Dealloc variables@>=
+xfree(mp->free);
+xfree(mp->was_free);
+
+@ @<Allocate or ...@>=
+mp->was_mem_end=0; /* indicate that everything was previously free */
+mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
+mp->panicking=false;
+
+@ @<Declare |mp_reallocate| functions@>=
+void mp_reallocate_memory(MP mp, int l) ;
+
+@ @c
+void mp_reallocate_memory(MP mp, int l) {
+ XREALLOC(mp->free, l, unsigned char);
+ XREALLOC(mp->was_free, l, unsigned char);
+ if (mp->mem) {
+ int newarea = l-mp->mem_max;
+ XREALLOC(mp->mem, l, memory_word);
+ memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
+ } else {
+ XREALLOC(mp->mem, l, memory_word);
+ memset(mp->mem,0,sizeof(memory_word)*(l+1));
+ }
+ mp->mem_max = l;
+ if (mp->ini_version)
+ mp->mem_top = l;
+}
+
+
+
+@ Procedure |check_mem| makes sure that the available space lists of
+|mem| are well formed, and it optionally prints out all locations
+that are reserved now but were free the last time this procedure was called.
+
+@c
+void mp_check_mem (MP mp,boolean print_locs ) {
+ pointer p,q,r; /* current locations of interest in |mem| */
+ boolean clobbered; /* is something amiss? */
+ for (p=0;p<=mp->lo_mem_max;p++) {
+ mp->free[p]=false; /* you can probably do this faster */
+ }
+ for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
+ mp->free[p]=false; /* ditto */
+ }
+ @<Check single-word |avail| list@>;
+ @<Check variable-size |avail| list@>;
+ @<Check flags of unavailable nodes@>;
+ @<Check the list of linear dependencies@>;
+ if ( print_locs ) {
+ @<Print newly busy locations@>;
+ }
+ memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
+ mp->was_mem_end=mp->mem_end;
+ mp->was_lo_max=mp->lo_mem_max;
+ mp->was_hi_min=mp->hi_mem_min;
+}
+
+@ @<Check single-word...@>=
+p=mp->avail; q=null; clobbered=false;
+while ( p!=null ) {
+ if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
+ else if ( mp->free[p] ) clobbered=true;
+ if ( clobbered ) {
+ mp_print_nl(mp, "AVAIL list clobbered at ");
+@.AVAIL list clobbered...@>
+ mp_print_int(mp, q); break;
+ }
+ mp->free[p]=true; q=p; p=link(q);
+}
+
+@ @<Check variable-size...@>=
+p=mp->rover; q=null; clobbered=false;
+do {
+ if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
+ else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
+ else if ( !(is_empty(p))||(node_size(p)<2)||
+ (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
+ if ( clobbered ) {
+ mp_print_nl(mp, "Double-AVAIL list clobbered at ");
+@.Double-AVAIL list clobbered...@>
+ mp_print_int(mp, q); break;
+ }
+ for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
+ if ( mp->free[q] ) {
+ mp_print_nl(mp, "Doubly free location at ");
+@.Doubly free location...@>
+ mp_print_int(mp, q); break;
+ }
+ mp->free[q]=true;
+ }
+ q=p; p=rlink(p);
+} while (p!=mp->rover)
+
+
+@ @<Check flags...@>=
+p=0;
+while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
+ if ( is_empty(p) ) {
+ mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
+@.Bad flag...@>
+ }
+ while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
+ while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
+}
+
+@ @<Print newly busy...@>=
+{
+ @<Do intialization required before printing new busy locations@>;
+ mp_print_nl(mp, "New busy locs:");
+@.New busy locs@>
+ for (p=0;p<= mp->lo_mem_max;p++ ) {
+ if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
+ @<Indicate that |p| is a new busy location@>;
+ }
+ }
+ for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
+ if ( ! mp->free[p] &&
+ ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
+ @<Indicate that |p| is a new busy location@>;
+ }
+ }
+ @<Finish printing new busy locations@>;
+}
+
+@ There might be many new busy locations so we are careful to print contiguous
+blocks compactly. During this operation |q| is the last new busy location and
+|r| is the start of the block containing |q|.
+
+@<Indicate that |p| is a new busy location@>=
+{
+ if ( p>q+1 ) {
+ if ( q>r ) {
+ mp_print(mp, ".."); mp_print_int(mp, q);
+ }
+ mp_print_char(mp, ' '); mp_print_int(mp, p);
+ r=p;
+ }
+ q=p;
+}
+
+@ @<Do intialization required before printing new busy locations@>=
+q=mp->mem_max; r=mp->mem_max
+
+@ @<Finish printing new busy locations@>=
+if ( q>r ) {
+ mp_print(mp, ".."); mp_print_int(mp, q);
+}
+
+@ The |search_mem| procedure attempts to answer the question ``Who points
+to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
+that might not be of type |two_halves|. Strictly speaking, this is
+undefined, and it can lead to ``false drops'' (words that seem to
+point to |p| purely by coincidence). But for debugging purposes, we want
+to rule out the places that do {\sl not\/} point to |p|, so a few false
+drops are tolerable.
+
+@c
+void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
+ integer q; /* current position being searched */
+ for (q=0;q<=mp->lo_mem_max;q++) {
+ if ( link(q)==p ){
+ mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
+ }
+ if ( info(q)==p ) {
+ mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
+ }
+ }
+ for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
+ if ( link(q)==p ) {
+ mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
+ }
+ if ( info(q)==p ) {
+ mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
+ }
+ }
+ @<Search |eqtb| for equivalents equal to |p|@>;
+}
+
+@* \[12] The command codes.
+Before we can go much further, we need to define symbolic names for the internal
+code numbers that represent the various commands obeyed by \MP. These codes
+are somewhat arbitrary, but not completely so. For example,
+some codes have been made adjacent so that |case| statements in the
+program need not consider cases that are widely spaced, or so that |case|
+statements can be replaced by |if| statements. A command can begin an
+expression if and only if its code lies between |min_primary_command| and
+|max_primary_command|, inclusive. The first token of a statement that doesn't
+begin with an expression has a command code between |min_command| and
+|max_statement_command|, inclusive. Anything less than |min_command| is
+eliminated during macro expansions, and anything no more than |max_pre_command|
+is eliminated when expanding \TeX\ material. Ranges such as
+|min_secondary_command..max_secondary_command| are used when parsing
+expressions, but the relative ordering within such a range is generally not
+critical.
+
+The ordering of the highest-numbered commands
+(|comma<semicolon<end_group<stop|) is crucial for the parsing and
+error-recovery methods of this program as is the ordering |if_test<fi_or_else|
+for the smallest two commands. The ordering is also important in the ranges
+|numeric_token..plus_or_minus| and |left_brace..ampersand|.
+
+At any rate, here is the list, for future reference.
+
+@d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
+@d etex_marker 2 /* end \TeX\ material (\&{etex}) */
+@d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
+@d max_pre_command mpx_break
+@d if_test 4 /* conditional text (\&{if}) */
+@d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
+@d input 6 /* input a source file (\&{input}, \&{endinput}) */
+@d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
+@d repeat_loop 8 /* special command substituted for \&{endfor} */
+@d exit_test 9 /* premature exit from a loop (\&{exitif}) */
+@d relax 10 /* do nothing (\.{\char`\\}) */
+@d scan_tokens 11 /* put a string into the input buffer */
+@d expand_after 12 /* look ahead one token */
+@d defined_macro 13 /* a macro defined by the user */
+@d min_command (defined_macro+1)
+@d save_command 14 /* save a list of tokens (\&{save}) */
+@d interim_command 15 /* save an internal quantity (\&{interim}) */
+@d let_command 16 /* redefine a symbolic token (\&{let}) */
+@d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
+@d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
+@d ship_out_command 19 /* output a character (\&{shipout}) */
+@d add_to_command 20 /* add to edges (\&{addto}) */
+@d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
+@d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
+@d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
+@d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
+@d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
+@d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
+@d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
+@d every_job_command 28 /* designate a starting token (\&{everyjob}) */
+@d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
+@d special_command 30 /* output special info (\&{special})
+ or font map info (\&{fontmapfile}, \&{fontmapline}) */
+@d write_command 31 /* write text to a file (\&{write}) */
+@d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
+@d max_statement_command type_name
+@d min_primary_command type_name
+@d left_delimiter 33 /* the left delimiter of a matching pair */
+@d begin_group 34 /* beginning of a group (\&{begingroup}) */
+@d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
+@d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
+@d str_op 37 /* convert a suffix to a string (\&{str}) */
+@d cycle 38 /* close a cyclic path (\&{cycle}) */
+@d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
+@d capsule_token 40 /* a value that has been put into a token list */
+@d string_token 41 /* a string constant (e.g., |"hello"|) */
+@d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
+@d min_suffix_token internal_quantity
+@d tag_token 43 /* a symbolic token without a primitive meaning */
+@d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
+@d max_suffix_token numeric_token
+@d plus_or_minus 45 /* either `\.+' or `\.-' */
+@d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
+@d min_tertiary_command plus_or_minus
+@d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
+@d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
+@d max_tertiary_command tertiary_binary
+@d left_brace 48 /* the operator `\.{\char`\{}' */
+@d min_expression_command left_brace
+@d path_join 49 /* the operator `\.{..}' */
+@d ampersand 50 /* the operator `\.\&' */
+@d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
+@d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
+@d equals 53 /* the operator `\.=' */
+@d max_expression_command equals
+@d and_command 54 /* the operator `\&{and}' */
+@d min_secondary_command and_command
+@d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
+@d slash 56 /* the operator `\./' */
+@d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
+@d max_secondary_command secondary_binary
+@d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
+@d controls 59 /* specify control points explicitly (\&{controls}) */
+@d tension 60 /* specify tension between knots (\&{tension}) */
+@d at_least 61 /* bounded tension value (\&{atleast}) */
+@d curl_command 62 /* specify curl at an end knot (\&{curl}) */
+@d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
+@d right_delimiter 64 /* the right delimiter of a matching pair */
+@d left_bracket 65 /* the operator `\.[' */
+@d right_bracket 66 /* the operator `\.]' */
+@d right_brace 67 /* the operator `\.{\char`\}}' */
+@d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
+@d thing_to_add 69
+ /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
+@d of_token 70 /* the operator `\&{of}' */
+@d to_token 71 /* the operator `\&{to}' */
+@d step_token 72 /* the operator `\&{step}' */
+@d until_token 73 /* the operator `\&{until}' */
+@d within_token 74 /* the operator `\&{within}' */
+@d lig_kern_token 75
+ /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
+@d assignment 76 /* the operator `\.{:=}' */
+@d skip_to 77 /* the operation `\&{skipto}' */
+@d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
+@d double_colon 79 /* the operator `\.{::}' */
+@d colon 80 /* the operator `\.:' */
+@#
+@d comma 81 /* the operator `\.,', must be |colon+1| */
+@d end_of_statement (mp->cur_cmd>comma)
+@d semicolon 82 /* the operator `\.;', must be |comma+1| */
+@d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
+@d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
+@d max_command_code stop
+@d outer_tag (max_command_code+1) /* protection code added to command code */
+
+@<Types...@>=
+typedef int command_code;
+
+@ Variables and capsules in \MP\ have a variety of ``types,''
+distinguished by the code numbers defined here. These numbers are also
+not completely arbitrary. Things that get expanded must have types
+|>mp_independent|; a type remaining after expansion is numeric if and only if
+its code number is at least |numeric_type|; objects containing numeric
+parts must have types between |transform_type| and |pair_type|;
+all other types must be smaller than |transform_type|; and among the types
+that are not unknown or vacuous, the smallest two must be |boolean_type|
+and |string_type| in that order.
+
+@d undefined 0 /* no type has been declared */
+@d unknown_tag 1 /* this constant is added to certain type codes below */
+@d unknown_types mp_unknown_boolean: case mp_unknown_string:
+ case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
+
+@<Types...@>=
+enum mp_variable_type {
+mp_vacuous=1, /* no expression was present */
+mp_boolean_type, /* \&{boolean} with a known value */
+mp_unknown_boolean,
+mp_string_type, /* \&{string} with a known value */
+mp_unknown_string,
+mp_pen_type, /* \&{pen} with a known value */
+mp_unknown_pen,
+mp_path_type, /* \&{path} with a known value */
+mp_unknown_path,
+mp_picture_type, /* \&{picture} with a known value */
+mp_unknown_picture,
+mp_transform_type, /* \&{transform} variable or capsule */
+mp_color_type, /* \&{color} variable or capsule */
+mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
+mp_pair_type, /* \&{pair} variable or capsule */
+mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
+mp_known, /* \&{numeric} with a known value */
+mp_dependent, /* a linear combination with |fraction| coefficients */
+mp_proto_dependent, /* a linear combination with |scaled| coefficients */
+mp_independent, /* \&{numeric} with unknown value */
+mp_token_list, /* variable name or suffix argument or text argument */
+mp_structured, /* variable with subscripts and attributes */
+mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
+mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
+} ;
+
+@ @<Declarations@>=
+void mp_print_type (MP mp,small_number t) ;
+
+@ @<Basic printing procedures@>=
+void mp_print_type (MP mp,small_number t) {
+ switch (t) {
+ case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
+ case mp_boolean_type:mp_print(mp, "boolean"); break;
+ case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
+ case mp_string_type:mp_print(mp, "string"); break;
+ case mp_unknown_string:mp_print(mp, "unknown string"); break;
+ case mp_pen_type:mp_print(mp, "pen"); break;
+ case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
+ case mp_path_type:mp_print(mp, "path"); break;
+ case mp_unknown_path:mp_print(mp, "unknown path"); break;
+ case mp_picture_type:mp_print(mp, "picture"); break;
+ case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
+ case mp_transform_type:mp_print(mp, "transform"); break;
+ case mp_color_type:mp_print(mp, "color"); break;
+ case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
+ case mp_pair_type:mp_print(mp, "pair"); break;
+ case mp_known:mp_print(mp, "known numeric"); break;
+ case mp_dependent:mp_print(mp, "dependent"); break;
+ case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
+ case mp_numeric_type:mp_print(mp, "numeric"); break;
+ case mp_independent:mp_print(mp, "independent"); break;
+ case mp_token_list:mp_print(mp, "token list"); break;
+ case mp_structured:mp_print(mp, "mp_structured"); break;
+ case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
+ case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
+ default: mp_print(mp, "undefined"); break;
+ }
+}
+
+@ Values inside \MP\ are stored in two-word nodes that have a |name_type|
+as well as a |type|. The possibilities for |name_type| are defined
+here; they will be explained in more detail later.
+
+@<Types...@>=
+enum mp_name_type {
+ mp_root=0, /* |name_type| at the top level of a variable */
+ mp_saved_root, /* same, when the variable has been saved */
+ mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
+ mp_subscr, /* |name_type| in a subscript node */
+ mp_attr, /* |name_type| in an attribute node */
+ mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
+ mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
+ mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
+ mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
+ mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
+ mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
+ mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
+ mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
+ mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
+ mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
+ mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
+ mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
+ mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
+ mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
+ mp_capsule, /* |name_type| in stashed-away subexpressions */
+ mp_token /* |name_type| in a numeric token or string token */
+};
+
+@ Primitive operations that produce values have a secondary identification
+code in addition to their command code; it's something like genera and species.
+For example, `\.*' has the command code |primary_binary|, and its
+secondary identification is |times|. The secondary codes start at 30 so that
+they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
+are used as operators as well as type identifications. The relative values
+are not critical, except for |true_code..false_code|, |or_op..and_op|,
+and |filled_op..bounded_op|. The restrictions are that
+|and_op-false_code=or_op-true_code|, that the ordering of
+|x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
+and the ordering of |filled_op..bounded_op| must match that of the code
+values they test for.
+
+@d true_code 30 /* operation code for \.{true} */
+@d false_code 31 /* operation code for \.{false} */
+@d null_picture_code 32 /* operation code for \.{nullpicture} */
+@d null_pen_code 33 /* operation code for \.{nullpen} */
+@d job_name_op 34 /* operation code for \.{jobname} */
+@d read_string_op 35 /* operation code for \.{readstring} */
+@d pen_circle 36 /* operation code for \.{pencircle} */
+@d normal_deviate 37 /* operation code for \.{normaldeviate} */
+@d read_from_op 38 /* operation code for \.{readfrom} */
+@d close_from_op 39 /* operation code for \.{closefrom} */
+@d odd_op 40 /* operation code for \.{odd} */
+@d known_op 41 /* operation code for \.{known} */
+@d unknown_op 42 /* operation code for \.{unknown} */
+@d not_op 43 /* operation code for \.{not} */
+@d decimal 44 /* operation code for \.{decimal} */
+@d reverse 45 /* operation code for \.{reverse} */
+@d make_path_op 46 /* operation code for \.{makepath} */
+@d make_pen_op 47 /* operation code for \.{makepen} */
+@d oct_op 48 /* operation code for \.{oct} */
+@d hex_op 49 /* operation code for \.{hex} */
+@d ASCII_op 50 /* operation code for \.{ASCII} */
+@d char_op 51 /* operation code for \.{char} */
+@d length_op 52 /* operation code for \.{length} */
+@d turning_op 53 /* operation code for \.{turningnumber} */
+@d color_model_part 54 /* operation code for \.{colormodel} */
+@d x_part 55 /* operation code for \.{xpart} */
+@d y_part 56 /* operation code for \.{ypart} */
+@d xx_part 57 /* operation code for \.{xxpart} */
+@d xy_part 58 /* operation code for \.{xypart} */
+@d yx_part 59 /* operation code for \.{yxpart} */
+@d yy_part 60 /* operation code for \.{yypart} */
+@d red_part 61 /* operation code for \.{redpart} */
+@d green_part 62 /* operation code for \.{greenpart} */
+@d blue_part 63 /* operation code for \.{bluepart} */
+@d cyan_part 64 /* operation code for \.{cyanpart} */
+@d magenta_part 65 /* operation code for \.{magentapart} */
+@d yellow_part 66 /* operation code for \.{yellowpart} */
+@d black_part 67 /* operation code for \.{blackpart} */
+@d grey_part 68 /* operation code for \.{greypart} */
+@d font_part 69 /* operation code for \.{fontpart} */
+@d text_part 70 /* operation code for \.{textpart} */
+@d path_part 71 /* operation code for \.{pathpart} */
+@d pen_part 72 /* operation code for \.{penpart} */
+@d dash_part 73 /* operation code for \.{dashpart} */
+@d sqrt_op 74 /* operation code for \.{sqrt} */
+@d m_exp_op 75 /* operation code for \.{mexp} */
+@d m_log_op 76 /* operation code for \.{mlog} */
+@d sin_d_op 77 /* operation code for \.{sind} */
+@d cos_d_op 78 /* operation code for \.{cosd} */
+@d floor_op 79 /* operation code for \.{floor} */
+@d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
+@d char_exists_op 81 /* operation code for \.{charexists} */
+@d font_size 82 /* operation code for \.{fontsize} */
+@d ll_corner_op 83 /* operation code for \.{llcorner} */
+@d lr_corner_op 84 /* operation code for \.{lrcorner} */
+@d ul_corner_op 85 /* operation code for \.{ulcorner} */
+@d ur_corner_op 86 /* operation code for \.{urcorner} */
+@d arc_length 87 /* operation code for \.{arclength} */
+@d angle_op 88 /* operation code for \.{angle} */
+@d cycle_op 89 /* operation code for \.{cycle} */
+@d filled_op 90 /* operation code for \.{filled} */
+@d stroked_op 91 /* operation code for \.{stroked} */
+@d textual_op 92 /* operation code for \.{textual} */
+@d clipped_op 93 /* operation code for \.{clipped} */
+@d bounded_op 94 /* operation code for \.{bounded} */
+@d plus 95 /* operation code for \.+ */
+@d minus 96 /* operation code for \.- */
+@d times 97 /* operation code for \.* */
+@d over 98 /* operation code for \./ */
+@d pythag_add 99 /* operation code for \.{++} */
+@d pythag_sub 100 /* operation code for \.{+-+} */
+@d or_op 101 /* operation code for \.{or} */
+@d and_op 102 /* operation code for \.{and} */
+@d less_than 103 /* operation code for \.< */
+@d less_or_equal 104 /* operation code for \.{<=} */
+@d greater_than 105 /* operation code for \.> */
+@d greater_or_equal 106 /* operation code for \.{>=} */
+@d equal_to 107 /* operation code for \.= */
+@d unequal_to 108 /* operation code for \.{<>} */
+@d concatenate 109 /* operation code for \.\& */
+@d rotated_by 110 /* operation code for \.{rotated} */
+@d slanted_by 111 /* operation code for \.{slanted} */
+@d scaled_by 112 /* operation code for \.{scaled} */
+@d shifted_by 113 /* operation code for \.{shifted} */
+@d transformed_by 114 /* operation code for \.{transformed} */
+@d x_scaled 115 /* operation code for \.{xscaled} */
+@d y_scaled 116 /* operation code for \.{yscaled} */
+@d z_scaled 117 /* operation code for \.{zscaled} */
+@d in_font 118 /* operation code for \.{infont} */
+@d intersect 119 /* operation code for \.{intersectiontimes} */
+@d double_dot 120 /* operation code for improper \.{..} */
+@d substring_of 121 /* operation code for \.{substring} */
+@d min_of substring_of
+@d subpath_of 122 /* operation code for \.{subpath} */
+@d direction_time_of 123 /* operation code for \.{directiontime} */
+@d point_of 124 /* operation code for \.{point} */
+@d precontrol_of 125 /* operation code for \.{precontrol} */
+@d postcontrol_of 126 /* operation code for \.{postcontrol} */
+@d pen_offset_of 127 /* operation code for \.{penoffset} */
+@d arc_time_of 128 /* operation code for \.{arctime} */
+@d mp_version 129 /* operation code for \.{mpversion} */
+@d envelope_of 130 /* operation code for \.{envelope} */
+
+@c void mp_print_op (MP mp,quarterword c) {
+ if (c<=mp_numeric_type ) {
+ mp_print_type(mp, c);
+ } else {
+ switch (c) {
+ case true_code:mp_print(mp, "true"); break;
+ case false_code:mp_print(mp, "false"); break;
+ case null_picture_code:mp_print(mp, "nullpicture"); break;
+ case null_pen_code:mp_print(mp, "nullpen"); break;
+ case job_name_op:mp_print(mp, "jobname"); break;
+ case read_string_op:mp_print(mp, "readstring"); break;
+ case pen_circle:mp_print(mp, "pencircle"); break;
+ case normal_deviate:mp_print(mp, "normaldeviate"); break;
+ case read_from_op:mp_print(mp, "readfrom"); break;
+ case close_from_op:mp_print(mp, "closefrom"); break;
+ case odd_op:mp_print(mp, "odd"); break;
+ case known_op:mp_print(mp, "known"); break;
+ case unknown_op:mp_print(mp, "unknown"); break;
+ case not_op:mp_print(mp, "not"); break;
+ case decimal:mp_print(mp, "decimal"); break;
+ case reverse:mp_print(mp, "reverse"); break;
+ case make_path_op:mp_print(mp, "makepath"); break;
+ case make_pen_op:mp_print(mp, "makepen"); break;
+ case oct_op:mp_print(mp, "oct"); break;
+ case hex_op:mp_print(mp, "hex"); break;
+ case ASCII_op:mp_print(mp, "ASCII"); break;
+ case char_op:mp_print(mp, "char"); break;
+ case length_op:mp_print(mp, "length"); break;
+ case turning_op:mp_print(mp, "turningnumber"); break;
+ case x_part:mp_print(mp, "xpart"); break;
+ case y_part:mp_print(mp, "ypart"); break;
+ case xx_part:mp_print(mp, "xxpart"); break;
+ case xy_part:mp_print(mp, "xypart"); break;
+ case yx_part:mp_print(mp, "yxpart"); break;
+ case yy_part:mp_print(mp, "yypart"); break;
+ case red_part:mp_print(mp, "redpart"); break;
+ case green_part:mp_print(mp, "greenpart"); break;
+ case blue_part:mp_print(mp, "bluepart"); break;
+ case cyan_part:mp_print(mp, "cyanpart"); break;
+ case magenta_part:mp_print(mp, "magentapart"); break;
+ case yellow_part:mp_print(mp, "yellowpart"); break;
+ case black_part:mp_print(mp, "blackpart"); break;
+ case grey_part:mp_print(mp, "greypart"); break;
+ case color_model_part:mp_print(mp, "colormodel"); break;
+ case font_part:mp_print(mp, "fontpart"); break;
+ case text_part:mp_print(mp, "textpart"); break;
+ case path_part:mp_print(mp, "pathpart"); break;
+ case pen_part:mp_print(mp, "penpart"); break;
+ case dash_part:mp_print(mp, "dashpart"); break;
+ case sqrt_op:mp_print(mp, "sqrt"); break;
+ case m_exp_op:mp_print(mp, "mexp"); break;
+ case m_log_op:mp_print(mp, "mlog"); break;
+ case sin_d_op:mp_print(mp, "sind"); break;
+ case cos_d_op:mp_print(mp, "cosd"); break;
+ case floor_op:mp_print(mp, "floor"); break;
+ case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
+ case char_exists_op:mp_print(mp, "charexists"); break;
+ case font_size:mp_print(mp, "fontsize"); break;
+ case ll_corner_op:mp_print(mp, "llcorner"); break;
+ case lr_corner_op:mp_print(mp, "lrcorner"); break;
+ case ul_corner_op:mp_print(mp, "ulcorner"); break;
+ case ur_corner_op:mp_print(mp, "urcorner"); break;
+ case arc_length:mp_print(mp, "arclength"); break;
+ case angle_op:mp_print(mp, "angle"); break;
+ case cycle_op:mp_print(mp, "cycle"); break;
+ case filled_op:mp_print(mp, "filled"); break;
+ case stroked_op:mp_print(mp, "stroked"); break;
+ case textual_op:mp_print(mp, "textual"); break;
+ case clipped_op:mp_print(mp, "clipped"); break;
+ case bounded_op:mp_print(mp, "bounded"); break;
+ case plus:mp_print_char(mp, '+'); break;
+ case minus:mp_print_char(mp, '-'); break;
+ case times:mp_print_char(mp, '*'); break;
+ case over:mp_print_char(mp, '/'); break;
+ case pythag_add:mp_print(mp, "++"); break;
+ case pythag_sub:mp_print(mp, "+-+"); break;
+ case or_op:mp_print(mp, "or"); break;
+ case and_op:mp_print(mp, "and"); break;
+ case less_than:mp_print_char(mp, '<'); break;
+ case less_or_equal:mp_print(mp, "<="); break;
+ case greater_than:mp_print_char(mp, '>'); break;
+ case greater_or_equal:mp_print(mp, ">="); break;
+ case equal_to:mp_print_char(mp, '='); break;
+ case unequal_to:mp_print(mp, "<>"); break;
+ case concatenate:mp_print(mp, "&"); break;
+ case rotated_by:mp_print(mp, "rotated"); break;
+ case slanted_by:mp_print(mp, "slanted"); break;
+ case scaled_by:mp_print(mp, "scaled"); break;
+ case shifted_by:mp_print(mp, "shifted"); break;
+ case transformed_by:mp_print(mp, "transformed"); break;
+ case x_scaled:mp_print(mp, "xscaled"); break;
+ case y_scaled:mp_print(mp, "yscaled"); break;
+ case z_scaled:mp_print(mp, "zscaled"); break;
+ case in_font:mp_print(mp, "infont"); break;
+ case intersect:mp_print(mp, "intersectiontimes"); break;
+ case substring_of:mp_print(mp, "substring"); break;
+ case subpath_of:mp_print(mp, "subpath"); break;
+ case direction_time_of:mp_print(mp, "directiontime"); break;
+ case point_of:mp_print(mp, "point"); break;
+ case precontrol_of:mp_print(mp, "precontrol"); break;
+ case postcontrol_of:mp_print(mp, "postcontrol"); break;
+ case pen_offset_of:mp_print(mp, "penoffset"); break;
+ case arc_time_of:mp_print(mp, "arctime"); break;
+ case mp_version:mp_print(mp, "mpversion"); break;
+ case envelope_of:mp_print(mp, "envelope"); break;
+ default: mp_print(mp, ".."); break;
+ }
+ }
+}
+
+@ \MP\ also has a bunch of internal parameters that a user might want to
+fuss with. Every such parameter has an identifying code number, defined here.
+
+@<Types...@>=
+enum mp_given_internal {
+ mp_tracing_titles=1, /* show titles online when they appear */
+ mp_tracing_equations, /* show each variable when it becomes known */
+ mp_tracing_capsules, /* show capsules too */
+ mp_tracing_choices, /* show the control points chosen for paths */
+ mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
+ mp_tracing_commands, /* show commands and operations before they are performed */
+ mp_tracing_restores, /* show when a variable or internal is restored */
+ mp_tracing_macros, /* show macros before they are expanded */
+ mp_tracing_output, /* show digitized edges as they are output */
+ mp_tracing_stats, /* show memory usage at end of job */
+ mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
+ mp_tracing_online, /* show long diagnostics on terminal and in the log file */
+ mp_year, /* the current year (e.g., 1984) */
+ mp_month, /* the current month (e.g., 3 $\equiv$ March) */
+ mp_day, /* the current day of the month */
+ mp_time, /* the number of minutes past midnight when this job started */
+ mp_char_code, /* the number of the next character to be output */
+ mp_char_ext, /* the extension code of the next character to be output */
+ mp_char_wd, /* the width of the next character to be output */
+ mp_char_ht, /* the height of the next character to be output */
+ mp_char_dp, /* the depth of the next character to be output */
+ mp_char_ic, /* the italic correction of the next character to be output */
+ mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
+ mp_pausing, /* positive to display lines on the terminal before they are read */
+ mp_showstopping, /* positive to stop after each \&{show} command */
+ mp_fontmaking, /* positive if font metric output is to be produced */
+ mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
+ mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
+ mp_miterlimit, /* controls miter length as in \ps */
+ mp_warning_check, /* controls error message when variable value is large */
+ mp_boundary_char, /* the right boundary character for ligatures */
+ mp_prologues, /* positive to output conforming PostScript using built-in fonts */
+ mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
+ mp_default_color_model, /* the default color model for unspecified items */
+ mp_restore_clip_color,
+ mp_procset, /* wether or not create PostScript command shortcuts */
+ mp_gtroffmode /* whether the user specified |-troff| on the command line */
+};
+
+@
+
+@d max_given_internal mp_gtroffmode
+
+@<Glob...@>=
+scaled *internal; /* the values of internal quantities */
+char **int_name; /* their names */
+int int_ptr; /* the maximum internal quantity defined so far */
+int max_internal; /* current maximum number of internal quantities */
+
+@ @<Option variables@>=
+int troff_mode;
+
+@ @<Allocate or initialize ...@>=
+mp->max_internal=2*max_given_internal;
+mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
+mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
+mp->troff_mode=(opt->troff_mode>0 ? true : false);
+
+@ @<Exported function ...@>=
+int mp_troff_mode(MP mp);
+
+@ @c
+int mp_troff_mode(MP mp) { return mp->troff_mode; }
+
+@ @<Set initial ...@>=
+for (k=0;k<= mp->max_internal; k++ ) {
+ mp->internal[k]=0;
+ mp->int_name[k]=NULL;
+}
+mp->int_ptr=max_given_internal;
+
+@ The symbolic names for internal quantities are put into \MP's hash table
+by using a routine called |primitive|, which will be defined later. Let us
+enter them now, so that we don't have to list all those names again
+anywhere else.
+
+@<Put each of \MP's primitives into the hash table@>=
+mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
+@:tracingtitles_}{\&{tracingtitles} primitive@>
+mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
+@:mp_tracing_equations_}{\&{tracingequations} primitive@>
+mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
+@:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
+mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
+@:mp_tracing_choices_}{\&{tracingchoices} primitive@>
+mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
+@:mp_tracing_specs_}{\&{tracingspecs} primitive@>
+mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
+@:mp_tracing_commands_}{\&{tracingcommands} primitive@>
+mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
+@:mp_tracing_restores_}{\&{tracingrestores} primitive@>
+mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
+@:mp_tracing_macros_}{\&{tracingmacros} primitive@>
+mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
+@:mp_tracing_output_}{\&{tracingoutput} primitive@>
+mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
+@:mp_tracing_stats_}{\&{tracingstats} primitive@>
+mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
+@:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
+mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
+@:mp_tracing_online_}{\&{tracingonline} primitive@>
+mp_primitive(mp, "year",internal_quantity,mp_year);
+@:mp_year_}{\&{year} primitive@>
+mp_primitive(mp, "month",internal_quantity,mp_month);
+@:mp_month_}{\&{month} primitive@>
+mp_primitive(mp, "day",internal_quantity,mp_day);
+@:mp_day_}{\&{day} primitive@>
+mp_primitive(mp, "time",internal_quantity,mp_time);
+@:time_}{\&{time} primitive@>
+mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
+@:mp_char_code_}{\&{charcode} primitive@>
+mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
+@:mp_char_ext_}{\&{charext} primitive@>
+mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
+@:mp_char_wd_}{\&{charwd} primitive@>
+mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
+@:mp_char_ht_}{\&{charht} primitive@>
+mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
+@:mp_char_dp_}{\&{chardp} primitive@>
+mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
+@:mp_char_ic_}{\&{charic} primitive@>
+mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
+@:mp_design_size_}{\&{designsize} primitive@>
+mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
+@:mp_pausing_}{\&{pausing} primitive@>
+mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
+@:mp_showstopping_}{\&{showstopping} primitive@>
+mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
+@:mp_fontmaking_}{\&{fontmaking} primitive@>
+mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
+@:mp_linejoin_}{\&{linejoin} primitive@>
+mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
+@:mp_linecap_}{\&{linecap} primitive@>
+mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
+@:mp_miterlimit_}{\&{miterlimit} primitive@>
+mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
+@:mp_warning_check_}{\&{warningcheck} primitive@>
+mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
+@:mp_boundary_char_}{\&{boundarychar} primitive@>
+mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
+@:mp_prologues_}{\&{prologues} primitive@>
+mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
+@:mp_true_corners_}{\&{truecorners} primitive@>
+mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
+@:mp_procset_}{\&{mpprocset} primitive@>
+mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
+@:troffmode_}{\&{troffmode} primitive@>
+mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
+@:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
+mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
+@:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
+
+@ Colors can be specified in four color models. In the special
+case of |no_model|, MetaPost does not output any color operator to
+the postscript output.
+
+Note: these values are passed directly on to |with_option|. This only
+works because the other possible values passed to |with_option| are
+8 and 10 respectively (from |with_pen| and |with_picture|).
+
+There is a first state, that is only used for |gs_colormodel|. It flags
+the fact that there has not been any kind of color specification by
+the user so far in the game.
+
+@<Types...@>=
+enum mp_color_model {
+ mp_no_model=1,
+ mp_grey_model=3,
+ mp_rgb_model=5,
+ mp_cmyk_model=7,
+ mp_uninitialized_model=9
+};
+
+
+@ @<Initialize table entries (done by \.{INIMP} only)@>=
+mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
+mp->internal[mp_restore_clip_color]=unity;
+
+@ Well, we do have to list the names one more time, for use in symbolic
+printouts.
+
+@<Initialize table...@>=
+mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
+mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
+mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
+mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
+mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
+mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
+mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
+mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
+mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
+mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
+mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
+mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
+mp->int_name[mp_year]=xstrdup("year");
+mp->int_name[mp_month]=xstrdup("month");
+mp->int_name[mp_day]=xstrdup("day");
+mp->int_name[mp_time]=xstrdup("time");
+mp->int_name[mp_char_code]=xstrdup("charcode");
+mp->int_name[mp_char_ext]=xstrdup("charext");
+mp->int_name[mp_char_wd]=xstrdup("charwd");
+mp->int_name[mp_char_ht]=xstrdup("charht");
+mp->int_name[mp_char_dp]=xstrdup("chardp");
+mp->int_name[mp_char_ic]=xstrdup("charic");
+mp->int_name[mp_design_size]=xstrdup("designsize");
+mp->int_name[mp_pausing]=xstrdup("pausing");
+mp->int_name[mp_showstopping]=xstrdup("showstopping");
+mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
+mp->int_name[mp_linejoin]=xstrdup("linejoin");
+mp->int_name[mp_linecap]=xstrdup("linecap");
+mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
+mp->int_name[mp_warning_check]=xstrdup("warningcheck");
+mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
+mp->int_name[mp_prologues]=xstrdup("prologues");
+mp->int_name[mp_true_corners]=xstrdup("truecorners");
+mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
+mp->int_name[mp_procset]=xstrdup("mpprocset");
+mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
+mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
+
+@ The following procedure, which is called just before \MP\ initializes its
+input and output, establishes the initial values of the date and time.
+@^system dependencies@>
+
+Note that the values are |scaled| integers. Hence \MP\ can no longer
+be used after the year 32767.
+
+@c
+void mp_fix_date_and_time (MP mp) {
+ time_t aclock = time ((time_t *) 0);
+ struct tm *tmptr = localtime (&aclock);
+ mp->internal[mp_time]=
+ (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
+ mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
+ mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
+ mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
+}
+
+@ @<Declarations@>=
+void mp_fix_date_and_time (MP mp) ;
+
+@ \MP\ is occasionally supposed to print diagnostic information that
+goes only into the transcript file, unless |mp_tracing_online| is positive.
+Now that we have defined |mp_tracing_online| we can define
+two routines that adjust the destination of print commands:
+
+@<Declarations@>=
+void mp_begin_diagnostic (MP mp) ;
+void mp_end_diagnostic (MP mp,boolean blank_line);
+void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
+
+@ @<Basic printing...@>=
+@<Declare a function called |true_line|@>
+void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
+ mp->old_setting=mp->selector;
+ if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
+ decr(mp->selector);
+ if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
+ }
+}
+@#
+void mp_end_diagnostic (MP mp,boolean blank_line) {
+ /* restore proper conditions after tracing */
+ mp_print_nl(mp, "");
+ if ( blank_line ) mp_print_ln(mp);
+ mp->selector=mp->old_setting;
+}
+
+@
+
+@<Glob...@>=
+unsigned int old_setting;
+
+@ We will occasionally use |begin_diagnostic| in connection with line-number
+printing, as follows. (The parameter |s| is typically |"Path"| or
+|"Cycle spec"|, etc.)
+
+@<Basic printing...@>=
+void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
+ mp_begin_diagnostic(mp);
+ if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
+ mp_print(mp, " at line ");
+ mp_print_int(mp, mp_true_line(mp));
+ mp_print(mp, t); mp_print_char(mp, ':');
+}
+
+@ The 256 |ASCII_code| characters are grouped into classes by means of
+the |char_class| table. Individual class numbers have no semantic
+or syntactic significance, except in a few instances defined here.
+There's also |max_class|, which can be used as a basis for additional
+class numbers in nonstandard extensions of \MP.
+
+@d digit_class 0 /* the class number of \.{0123456789} */
+@d period_class 1 /* the class number of `\..' */
+@d space_class 2 /* the class number of spaces and nonstandard characters */
+@d percent_class 3 /* the class number of `\.\%' */
+@d string_class 4 /* the class number of `\."' */
+@d right_paren_class 8 /* the class number of `\.)' */
+@d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
+@d letter_class 9 /* letters and the underline character */
+@d left_bracket_class 17 /* `\.[' */
+@d right_bracket_class 18 /* `\.]' */
+@d invalid_class 20 /* bad character in the input */
+@d max_class 20 /* the largest class number */
+
+@<Glob...@>=
+int char_class[256]; /* the class numbers */
+
+@ If changes are made to accommodate non-ASCII character sets, they should
+follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+@^system dependencies@>
+
+@<Set initial ...@>=
+for (k='0';k<='9';k++)
+ mp->char_class[k]=digit_class;
+mp->char_class['.']=period_class;
+mp->char_class[' ']=space_class;
+mp->char_class['%']=percent_class;
+mp->char_class['"']=string_class;
+mp->char_class[',']=5;
+mp->char_class[';']=6;
+mp->char_class['(']=7;
+mp->char_class[')']=right_paren_class;
+for (k='A';k<= 'Z';k++ )
+ mp->char_class[k]=letter_class;
+for (k='a';k<='z';k++)
+ mp->char_class[k]=letter_class;
+mp->char_class['_']=letter_class;
+mp->char_class['<']=10;
+mp->char_class['=']=10;
+mp->char_class['>']=10;
+mp->char_class[':']=10;
+mp->char_class['|']=10;
+mp->char_class['`']=11;
+mp->char_class['\'']=11;
+mp->char_class['+']=12;
+mp->char_class['-']=12;
+mp->char_class['/']=13;
+mp->char_class['*']=13;
+mp->char_class['\\']=13;
+mp->char_class['!']=14;
+mp->char_class['?']=14;
+mp->char_class['#']=15;
+mp->char_class['&']=15;
+mp->char_class['@@']=15;
+mp->char_class['$']=15;
+mp->char_class['^']=16;
+mp->char_class['~']=16;
+mp->char_class['[']=left_bracket_class;
+mp->char_class[']']=right_bracket_class;
+mp->char_class['{']=19;
+mp->char_class['}']=19;
+for (k=0;k<' ';k++)
+ mp->char_class[k]=invalid_class;
+mp->char_class['\t']=space_class;
+mp->char_class['\f']=space_class;
+for (k=127;k<=255;k++)
+ mp->char_class[k]=invalid_class;
+
+@* \[13] The hash table.
+Symbolic tokens are stored and retrieved by means of a fairly standard hash
+table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
+in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
+table, it is never removed.
+
+The actual sequence of characters forming a symbolic token is
+stored in the |str_pool| array together with all the other strings. An
+auxiliary array |hash| consists of items with two halfword fields per
+word. The first of these, called |next(p)|, points to the next identifier
+belonging to the same coalesced list as the identifier corresponding to~|p|;
+and the other, called |text(p)|, points to the |str_start| entry for
+|p|'s identifier. If position~|p| of the hash table is empty, we have
+|text(p)=0|; if position |p| is either empty or the end of a coalesced
+hash list, we have |next(p)=0|.
+
+An auxiliary pointer variable called |hash_used| is maintained in such a
+way that all locations |p>=hash_used| are nonempty. The global variable
+|st_count| tells how many symbolic tokens have been defined, if statistics
+are being kept.
+
+The first 256 locations of |hash| are reserved for symbols of length one.
+
+There's a parallel array called |eqtb| that contains the current equivalent
+values of each symbolic token. The entries of this array consist of
+two halfwords called |eq_type| (a command code) and |equiv| (a secondary
+piece of information that qualifies the |eq_type|).
+
+@d next(A) mp->hash[(A)].lh /* link for coalesced lists */
+@d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
+@d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
+@d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
+@d hash_base 257 /* hashing actually starts here */
+@d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
+
+@<Glob...@>=
+pointer hash_used; /* allocation pointer for |hash| */
+integer st_count; /* total number of known identifiers */
+
+@ Certain entries in the hash table are ``frozen'' and not redefinable,
+since they are used in error recovery.
+
+@d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
+@d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
+@d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
+@d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
+@d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
+@d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
+@d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
+@d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
+@d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
+@d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
+@d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
+@d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
+@d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
+@d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
+@d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
+@d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
+@d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
+
+@<Glob...@>=
+two_halves *hash; /* the hash table */
+two_halves *eqtb; /* the equivalents */
+
+@ @<Allocate or initialize ...@>=
+mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
+mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
+
+@ @<Dealloc variables@>=
+xfree(mp->hash);
+xfree(mp->eqtb);
+
+@ @<Set init...@>=
+next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
+for (k=2;k<=hash_end;k++) {
+ mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
+}
+
+@ @<Initialize table entries...@>=
+mp->hash_used=frozen_inaccessible; /* nothing is used */
+mp->st_count=0;
+text(frozen_bad_vardef)=intern("a bad variable");
+text(frozen_etex)=intern("etex");
+text(frozen_mpx_break)=intern("mpxbreak");
+text(frozen_fi)=intern("fi");
+text(frozen_end_group)=intern("endgroup");
+text(frozen_end_def)=intern("enddef");
+text(frozen_end_for)=intern("endfor");
+text(frozen_semicolon)=intern(";");
+text(frozen_colon)=intern(":");
+text(frozen_slash)=intern("/");
+text(frozen_left_bracket)=intern("[");
+text(frozen_right_delimiter)=intern(")");
+text(frozen_inaccessible)=intern(" INACCESSIBLE");
+eq_type(frozen_right_delimiter)=right_delimiter;
+
+@ @<Check the ``constant'' values...@>=
+if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
+
+@ Here is the subroutine that searches the hash table for an identifier
+that matches a given string of length~|l| appearing in |buffer[j..
+(j+l-1)]|. If the identifier is not found, it is inserted; hence it
+will always be found, and the corresponding hash table address
+will be returned.
+
+@c
+pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
+ integer h; /* hash code */
+ pointer p; /* index in |hash| array */
+ pointer k; /* index in |buffer| array */
+ if (l==1) {
+ @<Treat special case of length 1 and |break|@>;
+ }
+ @<Compute the hash code |h|@>;
+ p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
+ while (true) {
+ if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
+ break;
+ if ( next(p)==0 ) {
+ @<Insert a new symbolic token after |p|, then
+ make |p| point to it and |break|@>;
+ }
+ p=next(p);
+ }
+ return p;
+}
+
+@ @<Treat special case of length 1...@>=
+ p=mp->buffer[j]+1; text(p)=p-1; return p;
+
+
+@ @<Insert a new symbolic...@>=
+{
+if ( text(p)>0 ) {
+ do {
+ if ( hash_is_full )
+ mp_overflow(mp, "hash size",mp->hash_size);
+@:MetaPost capacity exceeded hash size}{\quad hash size@>
+ decr(mp->hash_used);
+ } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
+ next(p)=mp->hash_used;
+ p=mp->hash_used;
+}
+str_room(l);
+for (k=j;k<=j+l-1;k++) {
+ append_char(mp->buffer[k]);
+}
+text(p)=mp_make_string(mp);
+mp->str_ref[text(p)]=max_str_ref;
+incr(mp->st_count);
+break;
+}
+
+
+@ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
+should be a prime number. The theory of hashing tells us to expect fewer
+than two table probes, on the average, when the search is successful.
+[See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
+@^Vitter, Jeffrey Scott@>
+
+@<Compute the hash code |h|@>=
+h=mp->buffer[j];
+for (k=j+1;k<=j+l-1;k++){
+ h=h+h+mp->buffer[k];
+ while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
+}
+
+@ @<Search |eqtb| for equivalents equal to |p|@>=
+for (q=1;q<=hash_end;q++) {
+ if ( equiv(q)==p ) {
+ mp_print_nl(mp, "EQUIV(");
+ mp_print_int(mp, q);
+ mp_print_char(mp, ')');
+ }
+}
+
+@ We need to put \MP's ``primitive'' symbolic tokens into the hash
+table, together with their command code (which will be the |eq_type|)
+and an operand (which will be the |equiv|). The |primitive| procedure
+does this, in a way that no \MP\ user can. The global value |cur_sym|
+contains the new |eqtb| pointer after |primitive| has acted.
+
+@c
+void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
+ pool_pointer k; /* index into |str_pool| */
+ small_number j; /* index into |buffer| */
+ small_number l; /* length of the string */
+ str_number s;
+ s = intern(ss);
+ k=mp->str_start[s]; l=str_stop(s)-k;
+ /* we will move |s| into the (empty) |buffer| */
+ for (j=0;j<=l-1;j++) {
+ mp->buffer[j]=mp->str_pool[k+j];
+ }
+ mp->cur_sym=mp_id_lookup(mp, 0,l);
+ if ( s>=256 ) { /* we don't want to have the string twice */
+ mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
+ };
+ eq_type(mp->cur_sym)=c;
+ equiv(mp->cur_sym)=o;
+}
+
+
+@ Many of \MP's primitives need no |equiv|, since they are identifiable
+by their |eq_type| alone. These primitives are loaded into the hash table
+as follows:
+
+@<Put each of \MP's primitives into the hash table@>=
+mp_primitive(mp, "..",path_join,0);
+@:.._}{\.{..} primitive@>
+mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
+@:[ }{\.{[} primitive@>
+mp_primitive(mp, "]",right_bracket,0);
+@:] }{\.{]} primitive@>
+mp_primitive(mp, "}",right_brace,0);
+@:]]}{\.{\char`\}} primitive@>
+mp_primitive(mp, "{",left_brace,0);
+@:][}{\.{\char`\{} primitive@>
+mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
+@:: }{\.{:} primitive@>
+mp_primitive(mp, "::",double_colon,0);
+@::: }{\.{::} primitive@>
+mp_primitive(mp, "||:",bchar_label,0);
+@:::: }{\.{\char'174\char'174:} primitive@>
+mp_primitive(mp, ":=",assignment,0);
+@::=_}{\.{:=} primitive@>
+mp_primitive(mp, ",",comma,0);
+@:, }{\., primitive@>
+mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
+@:; }{\.; primitive@>
+mp_primitive(mp, "\\",relax,0);
+@:]]\\}{\.{\char`\\} primitive@>
+@#
+mp_primitive(mp, "addto",add_to_command,0);
+@:add_to_}{\&{addto} primitive@>
+mp_primitive(mp, "atleast",at_least,0);
+@:at_least_}{\&{atleast} primitive@>
+mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
+@:begin_group_}{\&{begingroup} primitive@>
+mp_primitive(mp, "controls",controls,0);
+@:controls_}{\&{controls} primitive@>
+mp_primitive(mp, "curl",curl_command,0);
+@:curl_}{\&{curl} primitive@>
+mp_primitive(mp, "delimiters",delimiters,0);
+@:delimiters_}{\&{delimiters} primitive@>
+mp_primitive(mp, "endgroup",end_group,0);
+ mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
+@:endgroup_}{\&{endgroup} primitive@>
+mp_primitive(mp, "everyjob",every_job_command,0);
+@:every_job_}{\&{everyjob} primitive@>
+mp_primitive(mp, "exitif",exit_test,0);
+@:exit_if_}{\&{exitif} primitive@>
+mp_primitive(mp, "expandafter",expand_after,0);
+@:expand_after_}{\&{expandafter} primitive@>
+mp_primitive(mp, "interim",interim_command,0);
+@:interim_}{\&{interim} primitive@>
+mp_primitive(mp, "let",let_command,0);
+@:let_}{\&{let} primitive@>
+mp_primitive(mp, "newinternal",new_internal,0);
+@:new_internal_}{\&{newinternal} primitive@>
+mp_primitive(mp, "of",of_token,0);
+@:of_}{\&{of} primitive@>
+mp_primitive(mp, "randomseed",mp_random_seed,0);
+@:mp_random_seed_}{\&{randomseed} primitive@>
+mp_primitive(mp, "save",save_command,0);
+@:save_}{\&{save} primitive@>
+mp_primitive(mp, "scantokens",scan_tokens,0);
+@:scan_tokens_}{\&{scantokens} primitive@>
+mp_primitive(mp, "shipout",ship_out_command,0);
+@:ship_out_}{\&{shipout} primitive@>
+mp_primitive(mp, "skipto",skip_to,0);
+@:skip_to_}{\&{skipto} primitive@>
+mp_primitive(mp, "special",special_command,0);
+@:special}{\&{special} primitive@>
+mp_primitive(mp, "fontmapfile",special_command,1);
+@:fontmapfile}{\&{fontmapfile} primitive@>
+mp_primitive(mp, "fontmapline",special_command,2);
+@:fontmapline}{\&{fontmapline} primitive@>
+mp_primitive(mp, "step",step_token,0);
+@:step_}{\&{step} primitive@>
+mp_primitive(mp, "str",str_op,0);
+@:str_}{\&{str} primitive@>
+mp_primitive(mp, "tension",tension,0);
+@:tension_}{\&{tension} primitive@>
+mp_primitive(mp, "to",to_token,0);
+@:to_}{\&{to} primitive@>
+mp_primitive(mp, "until",until_token,0);
+@:until_}{\&{until} primitive@>
+mp_primitive(mp, "within",within_token,0);
+@:within_}{\&{within} primitive@>
+mp_primitive(mp, "write",write_command,0);
+@:write_}{\&{write} primitive@>
+
+@ Each primitive has a corresponding inverse, so that it is possible to
+display the cryptic numeric contents of |eqtb| in symbolic form.
+Every call of |primitive| in this program is therefore accompanied by some
+straightforward code that forms part of the |print_cmd_mod| routine
+explained below.
+
+@<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
+case add_to_command:mp_print(mp, "addto"); break;
+case assignment:mp_print(mp, ":="); break;
+case at_least:mp_print(mp, "atleast"); break;
+case bchar_label:mp_print(mp, "||:"); break;
+case begin_group:mp_print(mp, "begingroup"); break;
+case colon:mp_print(mp, ":"); break;
+case comma:mp_print(mp, ","); break;
+case controls:mp_print(mp, "controls"); break;
+case curl_command:mp_print(mp, "curl"); break;
+case delimiters:mp_print(mp, "delimiters"); break;
+case double_colon:mp_print(mp, "::"); break;
+case end_group:mp_print(mp, "endgroup"); break;
+case every_job_command:mp_print(mp, "everyjob"); break;
+case exit_test:mp_print(mp, "exitif"); break;
+case expand_after:mp_print(mp, "expandafter"); break;
+case interim_command:mp_print(mp, "interim"); break;
+case left_brace:mp_print(mp, "{"); break;
+case left_bracket:mp_print(mp, "["); break;
+case let_command:mp_print(mp, "let"); break;
+case new_internal:mp_print(mp, "newinternal"); break;
+case of_token:mp_print(mp, "of"); break;
+case path_join:mp_print(mp, ".."); break;
+case mp_random_seed:mp_print(mp, "randomseed"); break;
+case relax:mp_print_char(mp, '\\'); break;
+case right_brace:mp_print(mp, "}"); break;
+case right_bracket:mp_print(mp, "]"); break;
+case save_command:mp_print(mp, "save"); break;
+case scan_tokens:mp_print(mp, "scantokens"); break;
+case semicolon:mp_print(mp, ";"); break;
+case ship_out_command:mp_print(mp, "shipout"); break;
+case skip_to:mp_print(mp, "skipto"); break;
+case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
+ if ( m==1 ) mp_print(mp, "fontmapfile"); else
+ mp_print(mp, "special"); break;
+case step_token:mp_print(mp, "step"); break;
+case str_op:mp_print(mp, "str"); break;
+case tension:mp_print(mp, "tension"); break;
+case to_token:mp_print(mp, "to"); break;
+case until_token:mp_print(mp, "until"); break;
+case within_token:mp_print(mp, "within"); break;
+case write_command:mp_print(mp, "write"); break;
+
+@ We will deal with the other primitives later, at some point in the program
+where their |eq_type| and |equiv| values are more meaningful. For example,
+the primitives for macro definitions will be loaded when we consider the
+routines that define macros.
+It is easy to find where each particular
+primitive was treated by looking in the index at the end; for example, the
+section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
+
+@* \[14] Token lists.
+A \MP\ token is either symbolic or numeric or a string, or it denotes
+a macro parameter or capsule; so there are five corresponding ways to encode it
+@^token@>
+internally: (1)~A symbolic token whose hash code is~|p|
+is represented by the number |p|, in the |info| field of a single-word
+node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
+represented in a two-word node of~|mem|; the |type| field is |known|,
+the |name_type| field is |token|, and the |value| field holds~|v|.
+The fact that this token appears in a two-word node rather than a
+one-word node is, of course, clear from the node address.
+(3)~A string token is also represented in a two-word node; the |type|
+field is |mp_string_type|, the |name_type| field is |token|, and the
+|value| field holds the corresponding |str_number|. (4)~Capsules have
+|name_type=capsule|, and their |type| and |value| fields represent
+arbitrary values (in ways to be explained later). (5)~Macro parameters
+are like symbolic tokens in that they appear in |info| fields of
+one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
+is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
+by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
+Actual values of these parameters are kept in a separate stack, as we will
+see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
+of course, chosen so that there will be no confusion between symbolic
+tokens and parameters of various types.
+
+Note that
+the `\\{type}' field of a node has nothing to do with ``type'' in a
+printer's sense. It's curious that the same word is used in such different ways.
+
+@d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
+@d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
+@d token_node_size 2 /* the number of words in a large token node */
+@d value_loc(A) ((A)+1) /* the word that contains the |value| field */
+@d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
+@d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
+@d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
+@d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
+
+@<Check the ``constant''...@>=
+if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
+
+@ We have set aside a two word node beginning at |null| so that we can have
+|value(null)=0|. We will make use of this coincidence later.
+
+@<Initialize table entries...@>=
+link(null)=null; value(null)=0;
+
+@ A numeric token is created by the following trivial routine.
+
+@c
+pointer mp_new_num_tok (MP mp,scaled v) {
+ pointer p; /* the new node */
+ p=mp_get_node(mp, token_node_size); value(p)=v;
+ type(p)=mp_known; name_type(p)=mp_token;
+ return p;
+}
+
+@ A token list is a singly linked list of nodes in |mem|, where
+each node contains a token and a link. Here's a subroutine that gets rid
+of a token list when it is no longer needed.
+
+@c void mp_flush_token_list (MP mp,pointer p) {
+ pointer q; /* the node being recycled */
+ while ( p!=null ) {
+ q=p; p=link(p);
+ if ( q>=mp->hi_mem_min ) {
+ free_avail(q);
+ } else {
+ switch (type(q)) {
+ case mp_vacuous: case mp_boolean_type: case mp_known:
+ break;
+ case mp_string_type:
+ delete_str_ref(value(q));
+ break;
+ case unknown_types: case mp_pen_type: case mp_path_type:
+ case mp_picture_type: case mp_pair_type: case mp_color_type:
+ case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
+ case mp_proto_dependent: case mp_independent:
+ mp_recycle_value(mp,q);
+ break;
+ default: mp_confusion(mp, "token");
+@:this can't happen token}{\quad token@>
+ }
+ mp_free_node(mp, q,token_node_size);
+ }
+ }
+}
+
+@ The procedure |show_token_list|, which prints a symbolic form of
+the token list that starts at a given node |p|, illustrates these
+conventions. The token list being displayed should not begin with a reference
+count. However, the procedure is intended to be fairly robust, so that if the
+memory links are awry or if |p| is not really a pointer to a token list,
+almost nothing catastrophic can happen.
+
+An additional parameter |q| is also given; this parameter is either null
+or it points to a node in the token list where a certain magic computation
+takes place that will be explained later. (Basically, |q| is non-null when
+we are printing the two-line context information at the time of an error
+message; |q| marks the place corresponding to where the second line
+should begin.)
+
+The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
+of printing exceeds a given limit~|l|; the length of printing upon entry is
+assumed to be a given amount called |null_tally|. (Note that
+|show_token_list| sometimes uses itself recursively to print
+variable names within a capsule.)
+@^recursion@>
+
+Unusual entries are printed in the form of all-caps tokens
+preceded by a space, e.g., `\.{\char`\ BAD}'.
+
+@<Declare the procedure called |show_token_list|@>=
+void mp_show_token_list (MP mp, integer p, integer q, integer l,
+ integer null_tally) ;
+
+@ @c
+void mp_show_token_list (MP mp, integer p, integer q, integer l,
+ integer null_tally) {
+ small_number class,c; /* the |char_class| of previous and new tokens */
+ integer r,v; /* temporary registers */
+ class=percent_class;
+ mp->tally=null_tally;
+ while ( (p!=null) && (mp->tally<l) ) {
+ if ( p==q )
+ @<Do magic computation@>;
+ @<Display token |p| and set |c| to its class;
+ but |return| if there are problems@>;
+ class=c; p=link(p);
+ }
+ if ( p!=null )
+ mp_print(mp, " ETC.");
+@.ETC@>
+ return;
+}
+
+@ @<Display token |p| and set |c| to its class...@>=
+c=letter_class; /* the default */
+if ( (p<0)||(p>mp->mem_end) ) {
+ mp_print(mp, " CLOBBERED"); return;
+@.CLOBBERED@>
+}
+if ( p<mp->hi_mem_min ) {
+ @<Display two-word token@>;
+} else {
+ r=info(p);
+ if ( r>=expr_base ) {
+ @<Display a parameter token@>;
+ } else {
+ if ( r<1 ) {
+ if ( r==0 ) {
+ @<Display a collective subscript@>
+ } else {
+ mp_print(mp, " IMPOSSIBLE");
+@.IMPOSSIBLE@>
+ }
+ } else {
+ r=text(r);
+ if ( (r<0)||(r>mp->max_str_ptr) ) {
+ mp_print(mp, " NONEXISTENT");
+@.NONEXISTENT@>
+ } else {
+ @<Print string |r| as a symbolic token
+ and set |c| to its class@>;
+ }
+ }
+ }
+}
+
+@ @<Display two-word token@>=
+if ( name_type(p)==mp_token ) {
+ if ( type(p)==mp_known ) {
+ @<Display a numeric token@>;
+ } else if ( type(p)!=mp_string_type ) {
+ mp_print(mp, " BAD");
+@.BAD@>
+ } else {
+ mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
+ c=string_class;
+ }
+} else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
+ mp_print(mp, " BAD");
+} else {
+ mp_print_capsule(mp,p); c=right_paren_class;
+}
+
+@ @<Display a numeric token@>=
+if ( class==digit_class )
+ mp_print_char(mp, ' ');
+v=value(p);
+if ( v<0 ){
+ if ( class==left_bracket_class )
+ mp_print_char(mp, ' ');
+ mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
+ c=right_bracket_class;
+} else {
+ mp_print_scaled(mp, v); c=digit_class;
+}
+
+
+@ Strictly speaking, a genuine token will never have |info(p)=0|.
+But we will see later (in the |print_variable_name| routine) that
+it is convenient to let |info(p)=0| stand for `\.{[]}'.
+
+@<Display a collective subscript@>=
+{
+if ( class==left_bracket_class )
+ mp_print_char(mp, ' ');
+mp_print(mp, "[]"); c=right_bracket_class;
+}
+
+@ @<Display a parameter token@>=
+{
+if ( r<suffix_base ) {
+ mp_print(mp, "(EXPR"); r=r-(expr_base);
+@.EXPR@>
+} else if ( r<text_base ) {
+ mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
+@.SUFFIX@>
+} else {
+ mp_print(mp, "(TEXT"); r=r-(text_base);
+@.TEXT@>
+}
+mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
+}
+
+
+@ @<Print string |r| as a symbolic token...@>=
+{
+c=mp->char_class[mp->str_pool[mp->str_start[r]]];
+if ( c==class ) {
+ switch (c) {
+ case letter_class:mp_print_char(mp, '.'); break;
+ case isolated_classes: break;
+ default: mp_print_char(mp, ' '); break;
+ }
+}
+mp_print_str(mp, r);
+}
+
+@ @<Declarations@>=
+void mp_print_capsule (MP mp, pointer p);
+
+@ @<Declare miscellaneous procedures that were declared |forward|@>=
+void mp_print_capsule (MP mp, pointer p) {
+ mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
+}
+
+@ Macro definitions are kept in \MP's memory in the form of token lists
+that have a few extra one-word nodes at the beginning.
+
+The first node contains a reference count that is used to tell when the
+list is no longer needed. To emphasize the fact that a reference count is
+present, we shall refer to the |info| field of this special node as the
+|ref_count| field.
+@^reference counts@>
+
+The next node or nodes after the reference count serve to describe the
+formal parameters. They consist of zero or more parameter tokens followed
+by a code for the type of macro.
+
+@d ref_count info
+ /* reference count preceding a macro definition or picture header */
+@d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
+@d general_macro 0 /* preface to a macro defined with a parameter list */
+@d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
+@d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
+@d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
+@d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
+@d of_macro 5 /* preface to a macro with
+ undelimited `\&{expr} |x| \&{of}~|y|' parameters */
+@d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
+@d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
+
+@c
+void mp_delete_mac_ref (MP mp,pointer p) {
+ /* |p| points to the reference count of a macro list that is
+ losing one reference */
+ if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
+ else decr(ref_count(p));
+}
+
+@ The following subroutine displays a macro, given a pointer to its
+reference count.
+
+@c
+@<Declare the procedure called |print_cmd_mod|@>
+void mp_show_macro (MP mp, pointer p, integer q, integer l) {
+ pointer r; /* temporary storage */
+ p=link(p); /* bypass the reference count */
+ while ( info(p)>text_macro ){
+ r=link(p); link(p)=null;
+ mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
+ if ( l>0 ) l=l-mp->tally; else return;
+ } /* control printing of `\.{ETC.}' */
+@.ETC@>
+ mp->tally=0;
+ switch(info(p)) {
+ case general_macro:mp_print(mp, "->"); break;
+@.->@>
+ case primary_macro: case secondary_macro: case tertiary_macro:
+ mp_print_char(mp, '<');
+ mp_print_cmd_mod(mp, param_type,info(p));
+ mp_print(mp, ">->");
+ break;
+ case expr_macro:mp_print(mp, "<expr>->"); break;
+ case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
+ case suffix_macro:mp_print(mp, "<suffix>->"); break;
+ case text_macro:mp_print(mp, "<text>->"); break;
+ } /* there are no other cases */
+ mp_show_token_list(mp, link(p),q,l-mp->tally,0);
+}
+
+@* \[15] Data structures for variables.
+The variables of \MP\ programs can be simple, like `\.x', or they can
+combine the structural properties of arrays and records, like `\.{x20a.b}'.
+A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
+example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
+things are represented inside of the computer.
+
+Each variable value occupies two consecutive words, either in a two-word
+node called a value node, or as a two-word subfield of a larger node. One
+of those two words is called the |value| field; it is an integer,
+containing either a |scaled| numeric value or the representation of some
+other type of quantity. (It might also be subdivided into halfwords, in
+which case it is referred to by other names instead of |value|.) The other
+word is broken into subfields called |type|, |name_type|, and |link|. The
+|type| field is a quarterword that specifies the variable's type, and
+|name_type| is a quarterword from which \MP\ can reconstruct the
+variable's name (sometimes by using the |link| field as well). Thus, only
+1.25 words are actually devoted to the value itself; the other
+three-quarters of a word are overhead, but they aren't wasted because they
+allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
+
+In this section we shall be concerned only with the structural aspects of
+variables, not their values. Later parts of the program will change the
+|type| and |value| fields, but we shall treat those fields as black boxes
+whose contents should not be touched.
+
+However, if the |type| field is |mp_structured|, there is no |value| field,
+and the second word is broken into two pointer fields called |attr_head|
+and |subscr_head|. Those fields point to additional nodes that
+contain structural information, as we shall see.
+
+@d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
+@d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
+@d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
+@d value_node_size 2 /* the number of words in a value node */
+
+@ An attribute node is three words long. Two of these words contain |type|
+and |value| fields as described above, and the third word contains
+additional information: There is an |attr_loc| field, which contains the
+hash address of the token that names this attribute; and there's also a
+|parent| field, which points to the value node of |mp_structured| type at the
+next higher level (i.e., at the level to which this attribute is
+subsidiary). The |name_type| in an attribute node is `|attr|'. The
+|link| field points to the next attribute with the same parent; these are
+arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
+final attribute node links to the constant |end_attr|, whose |attr_loc|
+field is greater than any legal hash address. The |attr_head| in the
+parent points to a node whose |name_type| is |mp_structured_root|; this
+node represents the null attribute, i.e., the variable that is relevant
+when no attributes are attached to the parent. The |attr_head| node
+has the fields of either
+a value node, a subscript node, or an attribute node, depending on what
+the parent would be if it were not structured; but the subscript and
+attribute fields are ignored, so it effectively contains only the data of
+a value node. The |link| field in this special node points to an attribute
+node whose |attr_loc| field is zero; the latter node represents a collective
+subscript `\.{[]}' attached to the parent, and its |link| field points to
+the first non-special attribute node (or to |end_attr| if there are none).
+
+A subscript node likewise occupies three words, with |type| and |value| fields
+plus extra information; its |name_type| is |subscr|. In this case the
+third word is called the |subscript| field, which is a |scaled| integer.
+The |link| field points to the subscript node with the next larger
+subscript, if any; otherwise the |link| points to the attribute node
+for collective subscripts at this level. We have seen that the latter node
+contains an upward pointer, so that the parent can be deduced.
+
+The |name_type| in a parent-less value node is |root|, and the |link|
+is the hash address of the token that names this value.
+
+In other words, variables have a hierarchical structure that includes
+enough threads running around so that the program is able to move easily
+between siblings, parents, and children. An example should be helpful:
+(The reader is advised to draw a picture while reading the following
+description, since that will help to firm up the ideas.)
+Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
+and `\.{x20b}' have been mentioned in a user's program, where
+\.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
+and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
+|eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
+node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
+|attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
+node and |r| to a subscript node. (Are you still following this? Use
+a pencil to draw a diagram.) The lone variable `\.x' is represented by
+|type(q)| and |value(q)|; furthermore
+|name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
+to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
+|attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
+|type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
+|qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
+(assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
+with no further attributes), |name_type(qq)=structured_root|,
+|attr_loc(qq)=0|, |parent(qq)=p|, and
+|link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
+an attribute node representing `\.{x[][]}', which has never yet
+occurred; its |type| field is |undefined|, and its |value| field is
+undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
+|parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
+`\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
+|parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
+(Maybe colored lines will help untangle your picture.)
+ Node |r| is a subscript node with |type| and |value|
+representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
+and |link(r)=r1| is another subscript node. To complete the picture,
+see if you can guess what |link(r1)| is; give up? It's~|q1|.
+Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
+|type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
+and we finish things off with three more nodes
+|qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
+with a larger sheet of paper.) The value of variable \.{x20b}
+appears in node~|qqq2|, as you can well imagine.
+
+If the example in the previous paragraph doesn't make things crystal
+clear, a glance at some of the simpler subroutines below will reveal how
+things work out in practice.
+
+The only really unusual thing about these conventions is the use of
+collective subscript attributes. The idea is to avoid repeating a lot of
+type information when many elements of an array are identical macros
+(for which distinct values need not be stored) or when they don't have
+all of the possible attributes. Branches of the structure below collective
+subscript attributes do not carry actual values except for macro identifiers;
+branches of the structure below subscript nodes do not carry significant
+information in their collective subscript attributes.
+
+@d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
+@d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
+@d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
+@d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
+@d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
+@d attr_node_size 3 /* the number of words in an attribute node */
+@d subscr_node_size 3 /* the number of words in a subscript node */
+@d collective_subscript 0 /* code for the attribute `\.{[]}' */
+
+@<Initialize table...@>=
+attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
+
+@ Variables of type \&{pair} will have values that point to four-word
+nodes containing two numeric values. The first of these values has
+|name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
+the |link| in the first points back to the node whose |value| points
+to this four-word node.
+
+Variables of type \&{transform} are similar, but in this case their
+|value| points to a 12-word node containing six values, identified by
+|x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
+|mp_yx_part_sector|, and |mp_yy_part_sector|.
+Finally, variables of type \&{color} have 3~values in 6~words
+identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
+
+When an entire structured variable is saved, the |root| indication
+is temporarily replaced by |saved_root|.
+
+Some variables have no name; they just are used for temporary storage
+while expressions are being evaluated. We call them {\sl capsules}.
+
+@d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
+@d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
+@d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
+@d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
+@d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
+@d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
+@d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
+@d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
+@d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
+@d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
+@d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
+@d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
+@d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
+@d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
+@#
+@d pair_node_size 4 /* the number of words in a pair node */
+@d transform_node_size 12 /* the number of words in a transform node */
+@d color_node_size 6 /* the number of words in a color node */
+@d cmykcolor_node_size 8 /* the number of words in a color node */
+
+@<Glob...@>=
+small_number big_node_size[mp_pair_type+1];
+small_number sector0[mp_pair_type+1];
+small_number sector_offset[mp_black_part_sector+1];
+
+@ The |sector0| array gives for each big node type, |name_type| values
+for its first subfield; the |sector_offset| array gives for each
+|name_type| value, the offset from the first subfield in words;
+and the |big_node_size| array gives the size in words for each type of
+big node.
+
+@<Set init...@>=
+mp->big_node_size[mp_transform_type]=transform_node_size;
+mp->big_node_size[mp_pair_type]=pair_node_size;
+mp->big_node_size[mp_color_type]=color_node_size;
+mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
+mp->sector0[mp_transform_type]=mp_x_part_sector;
+mp->sector0[mp_pair_type]=mp_x_part_sector;
+mp->sector0[mp_color_type]=mp_red_part_sector;
+mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
+for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
+ mp->sector_offset[k]=2*(k-mp_x_part_sector);
+}
+for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
+ mp->sector_offset[k]=2*(k-mp_red_part_sector);
+}
+for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
+ mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
+}
+
+@ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
+procedure call |init_big_node(p)| will allocate a pair or transform node
+for~|p|. The individual parts of such nodes are initially of type
+|mp_independent|.
+
+@c
+void mp_init_big_node (MP mp,pointer p) {
+ pointer q; /* the new node */
+ small_number s; /* its size */
+ s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
+ do {
+ s=s-2;
+ @<Make variable |q+s| newly independent@>;
+ name_type(q+s)=halfp(s)+mp->sector0[type(p)];
+ link(q+s)=null;
+ } while (s!=0);
+ link(q)=p; value(p)=q;
+}
+
+@ The |id_transform| function creates a capsule for the
+identity transformation.
+
+@c
+pointer mp_id_transform (MP mp) {
+ pointer p,q,r; /* list manipulation registers */
+ p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
+ name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
+ r=q+transform_node_size;
+ do {
+ r=r-2;
+ type(r)=mp_known; value(r)=0;
+ } while (r!=q);
+ value(xx_part_loc(q))=unity;
+ value(yy_part_loc(q))=unity;
+ return p;
+}
+
+@ Tokens are of type |tag_token| when they first appear, but they point
+to |null| until they are first used as the root of a variable.
+The following subroutine establishes the root node on such grand occasions.
+
+@c
+void mp_new_root (MP mp,pointer x) {
+ pointer p; /* the new node */
+ p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
+ link(p)=x; equiv(x)=p;
+}
+
+@ These conventions for variable representation are illustrated by the
+|print_variable_name| routine, which displays the full name of a
+variable given only a pointer to its two-word value packet.
+
+@<Declarations@>=
+void mp_print_variable_name (MP mp, pointer p);
+
+@ @c
+void mp_print_variable_name (MP mp, pointer p) {
+ pointer q; /* a token list that will name the variable's suffix */
+ pointer r; /* temporary for token list creation */
+ while ( name_type(p)>=mp_x_part_sector ) {
+ @<Preface the output with a part specifier; |return| in the
+ case of a capsule@>;
+ }
+ q=null;
+ while ( name_type(p)>mp_saved_root ) {
+ @<Ascend one level, pushing a token onto list |q|
+ and replacing |p| by its parent@>;
+ }
+ r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
+ if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
+@.SAVED@>
+ mp_show_token_list(mp, r,null,el_gordo,mp->tally);
+ mp_flush_token_list(mp, r);
+}
+
+@ @<Ascend one level, pushing a token onto list |q|...@>=
+{
+ if ( name_type(p)==mp_subscr ) {
+ r=mp_new_num_tok(mp, subscript(p));
+ do {
+ p=link(p);
+ } while (name_type(p)!=mp_attr);
+ } else if ( name_type(p)==mp_structured_root ) {
+ p=link(p); goto FOUND;
+ } else {
+ if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
+@:this can't happen var}{\quad var@>
+ r=mp_get_avail(mp); info(r)=attr_loc(p);
+ }
+ link(r)=q; q=r;
+FOUND:
+ p=parent(p);
+}
+
+@ @<Preface the output with a part specifier...@>=
+{ switch (name_type(p)) {
+ case mp_x_part_sector: mp_print_char(mp, 'x'); break;
+ case mp_y_part_sector: mp_print_char(mp, 'y'); break;
+ case mp_xx_part_sector: mp_print(mp, "xx"); break;
+ case mp_xy_part_sector: mp_print(mp, "xy"); break;
+ case mp_yx_part_sector: mp_print(mp, "yx"); break;
+ case mp_yy_part_sector: mp_print(mp, "yy"); break;
+ case mp_red_part_sector: mp_print(mp, "red"); break;
+ case mp_green_part_sector: mp_print(mp, "green"); break;
+ case mp_blue_part_sector: mp_print(mp, "blue"); break;
+ case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
+ case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
+ case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
+ case mp_black_part_sector: mp_print(mp, "black"); break;
+ case mp_grey_part_sector: mp_print(mp, "grey"); break;
+ case mp_capsule:
+ mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
+ break;
+@.CAPSULE@>
+ } /* there are no other cases */
+ mp_print(mp, "part ");
+ p=link(p-mp->sector_offset[name_type(p)]);
+}
+
+@ The |interesting| function returns |true| if a given variable is not
+in a capsule, or if the user wants to trace capsules.
+
+@c
+boolean mp_interesting (MP mp,pointer p) {
+ small_number t; /* a |name_type| */
+ if ( mp->internal[mp_tracing_capsules]>0 ) {
+ return true;
+ } else {
+ t=name_type(p);
+ if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
+ t=name_type(link(p-mp->sector_offset[t]));
+ return (t!=mp_capsule);
+ }
+}
+
+@ Now here is a subroutine that converts an unstructured type into an
+equivalent structured type, by inserting a |mp_structured| node that is
+capable of growing. This operation is done only when |name_type(p)=root|,
+|subscr|, or |attr|.
+
+The procedure returns a pointer to the new node that has taken node~|p|'s
+place in the structure. Node~|p| itself does not move, nor are its
+|value| or |type| fields changed in any way.
+
+@c
+pointer mp_new_structure (MP mp,pointer p) {
+ pointer q,r=0; /* list manipulation registers */
+ switch (name_type(p)) {
+ case mp_root:
+ q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
+ break;
+ case mp_subscr:
+ @<Link a new subscript node |r| in place of node |p|@>;
+ break;
+ case mp_attr:
+ @<Link a new attribute node |r| in place of node |p|@>;
+ break;
+ default:
+ mp_confusion(mp, "struct");
+@:this can't happen struct}{\quad struct@>
+ break;
+ }
+ link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
+ attr_head(r)=p; name_type(p)=mp_structured_root;
+ q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
+ parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
+ attr_loc(q)=collective_subscript;
+ return r;
+}
+
+@ @<Link a new subscript node |r| in place of node |p|@>=
+{
+ q=p;
+ do {
+ q=link(q);
+ } while (name_type(q)!=mp_attr);
+ q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
+ do {
+ q=r; r=link(r);
+ } while (r!=p);
+ r=mp_get_node(mp, subscr_node_size);
+ link(q)=r; subscript(r)=subscript(p);
+}
+
+@ If the attribute is |collective_subscript|, there are two pointers to
+node~|p|, so we must change both of them.
+
+@<Link a new attribute node |r| in place of node |p|@>=
+{
+ q=parent(p); r=attr_head(q);
+ do {
+ q=r; r=link(r);
+ } while (r!=p);
+ r=mp_get_node(mp, attr_node_size); link(q)=r;
+ mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
+ if ( attr_loc(p)==collective_subscript ) {
+ q=subscr_head_loc(parent(p));
+ while ( link(q)!=p ) q=link(q);
+ link(q)=r;
+ }
+}
+
+@ The |find_variable| routine is given a pointer~|t| to a nonempty token
+list of suffixes; it returns a pointer to the corresponding two-word
+value. For example, if |t| points to token \.x followed by a numeric
+token containing the value~7, |find_variable| finds where the value of
+\.{x7} is stored in memory. This may seem a simple task, and it
+usually is, except when \.{x7} has never been referenced before.
+Indeed, \.x may never have even been subscripted before; complexities
+arise with respect to updating the collective subscript information.
+
+If a macro type is detected anywhere along path~|t|, or if the first
+item on |t| isn't a |tag_token|, the value |null| is returned.
+Otherwise |p| will be a non-null pointer to a node such that
+|undefined<type(p)<mp_structured|.
+
+@d abort_find { return null; }
+
+@c
+pointer mp_find_variable (MP mp,pointer t) {
+ pointer p,q,r,s; /* nodes in the ``value'' line */
+ pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
+ integer n; /* subscript or attribute */
+ memory_word save_word; /* temporary storage for a word of |mem| */
+@^inner loop@>
+ p=info(t); t=link(t);
+ if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
+ if ( equiv(p)==null ) mp_new_root(mp, p);
+ p=equiv(p); pp=p;
+ while ( t!=null ) {
+ @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
+ if ( t<mp->hi_mem_min ) {
+ @<Descend one level for the subscript |value(t)|@>
+ } else {
+ @<Descend one level for the attribute |info(t)|@>;
+ }
+ t=link(t);
+ }
+ if ( type(pp)>=mp_structured ) {
+ if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
+ }
+ if ( type(p)==mp_structured ) p=attr_head(p);
+ if ( type(p)==undefined ) {
+ if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
+ type(p)=type(pp); value(p)=null;
+ };
+ return p;
+}
+
+@ Although |pp| and |p| begin together, they diverge when a subscript occurs;
+|pp|~stays in the collective line while |p|~goes through actual subscript
+values.
+
+@<Make sure that both nodes |p| and |pp|...@>=
+if ( type(pp)!=mp_structured ) {
+ if ( type(pp)>mp_structured ) abort_find;
+ ss=mp_new_structure(mp, pp);
+ if ( p==pp ) p=ss;
+ pp=ss;
+}; /* now |type(pp)=mp_structured| */
+if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
+ p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
+
+@ We want this part of the program to be reasonably fast, in case there are
+@^inner loop@>
+lots of subscripts at the same level of the data structure. Therefore
+we store an ``infinite'' value in the word that appears at the end of the
+subscript list, even though that word isn't part of a subscript node.
+
+@<Descend one level for the subscript |value(t)|@>=
+{
+ n=value(t);
+ pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
+ q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
+ subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
+ do {
+ r=s; s=link(s);
+ } while (n>subscript(s));
+ if ( n==subscript(s) ) {
+ p=s;
+ } else {
+ p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
+ subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
+ }
+ mp->mem[subscript_loc(q)]=save_word;
+}
+
+@ @<Descend one level for the attribute |info(t)|@>=
+{
+ n=info(t);
+ ss=attr_head(pp);
+ do {
+ rr=ss; ss=link(ss);
+ } while (n>attr_loc(ss));
+ if ( n<attr_loc(ss) ) {
+ qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
+ attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
+ parent(qq)=pp; ss=qq;
+ }
+ if ( p==pp ) {
+ p=ss; pp=ss;
+ } else {
+ pp=ss; s=attr_head(p);
+ do {
+ r=s; s=link(s);
+ } while (n>attr_loc(s));
+ if ( n==attr_loc(s) ) {
+ p=s;
+ } else {
+ q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
+ attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
+ parent(q)=p; p=q;
+ }
+ }
+}
+
+@ Variables lose their former values when they appear in a type declaration,
+or when they are defined to be macros or \&{let} equal to something else.
+A subroutine will be defined later that recycles the storage associated
+with any particular |type| or |value|; our goal now is to study a higher
+level process called |flush_variable|, which selectively frees parts of a
+variable structure.
+
+This routine has some complexity because of examples such as
+`\hbox{\tt numeric x[]a[]b}'
+which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
+`\hbox{\tt vardef x[]a[]=...}'
+discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
+suffix, except for the collective node \.{x[]a[]} itself. The obvious way
+to handle such examples is to use recursion; so that's what we~do.
+@^recursion@>
+
+Parameter |p| points to the root information of the variable;
+parameter |t| points to a list of one-word nodes that represent
+suffixes, with |info=collective_subscript| for subscripts.
+
+@<Declarations@>=
+@<Declare subroutines for printing expressions@>
+@<Declare basic dependency-list subroutines@>
+@<Declare the recycling subroutines@>
+void mp_flush_cur_exp (MP mp,scaled v) ;
+@<Declare the procedure called |flush_below_variable|@>
+
+@ @c
+void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
+ pointer q,r; /* list manipulation */
+ halfword n; /* attribute to match */
+ while ( t!=null ) {
+ if ( type(p)!=mp_structured ) return;
+ n=info(t); t=link(t);
+ if ( n==collective_subscript ) {
+ r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
+ while ( name_type(q)==mp_subscr ){
+ mp_flush_variable(mp, q,t,discard_suffixes);
+ if ( t==null ) {
+ if ( type(q)==mp_structured ) r=q;
+ else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
+ } else {
+ r=q;
+ }
+ q=link(r);
+ }
+ }
+ p=attr_head(p);
+ do {
+ r=p; p=link(p);
+ } while (attr_loc(p)<n);
+ if ( attr_loc(p)!=n ) return;
+ }
+ if ( discard_suffixes ) {
+ mp_flush_below_variable(mp, p);
+ } else {
+ if ( type(p)==mp_structured ) p=attr_head(p);
+ mp_recycle_value(mp, p);
+ }
+}
+
+@ The next procedure is simpler; it wipes out everything but |p| itself,
+which becomes undefined.
+
+@<Declare the procedure called |flush_below_variable|@>=
+void mp_flush_below_variable (MP mp, pointer p);
+
+@ @c
+void mp_flush_below_variable (MP mp,pointer p) {
+ pointer q,r; /* list manipulation registers */
+ if ( type(p)!=mp_structured ) {
+ mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
+ } else {
+ q=subscr_head(p);
+ while ( name_type(q)==mp_subscr ) {
+ mp_flush_below_variable(mp, q); r=q; q=link(q);
+ mp_free_node(mp, r,subscr_node_size);
+ }
+ r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
+ if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
+ else mp_free_node(mp, r,subscr_node_size);
+ /* we assume that |subscr_node_size=attr_node_size| */
+ do {
+ mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
+ } while (q!=end_attr);
+ type(p)=undefined;
+ }
+}
+
+@ Just before assigning a new value to a variable, we will recycle the
+old value and make the old value undefined. The |und_type| routine
+determines what type of undefined value should be given, based on
+the current type before recycling.
+
+@c
+small_number mp_und_type (MP mp,pointer p) {
+ switch (type(p)) {
+ case undefined: case mp_vacuous:
+ return undefined;
+ case mp_boolean_type: case mp_unknown_boolean:
+ return mp_unknown_boolean;
+ case mp_string_type: case mp_unknown_string:
+ return mp_unknown_string;
+ case mp_pen_type: case mp_unknown_pen:
+ return mp_unknown_pen;
+ case mp_path_type: case mp_unknown_path:
+ return mp_unknown_path;
+ case mp_picture_type: case mp_unknown_picture:
+ return mp_unknown_picture;
+ case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
+ case mp_pair_type: case mp_numeric_type:
+ return type(p);
+ case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
+ return mp_numeric_type;
+ } /* there are no other cases */
+ return 0;
+}
+
+@ The |clear_symbol| routine is used when we want to redefine the equivalent
+of a symbolic token. It must remove any variable structure or macro
+definition that is currently attached to that symbol. If the |saving|
+parameter is true, a subsidiary structure is saved instead of destroyed.
+
+@c
+void mp_clear_symbol (MP mp,pointer p, boolean saving) {
+ pointer q; /* |equiv(p)| */
+ q=equiv(p);
+ switch (eq_type(p) % outer_tag) {
+ case defined_macro:
+ case secondary_primary_macro:
+ case tertiary_secondary_macro:
+ case expression_tertiary_macro:
+ if ( ! saving ) mp_delete_mac_ref(mp, q);
+ break;
+ case tag_token:
+ if ( q!=null ) {
+ if ( saving ) {
+ name_type(q)=mp_saved_root;
+ } else {
+ mp_flush_below_variable(mp, q);
+ mp_free_node(mp,q,value_node_size);
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ mp->eqtb[p]=mp->eqtb[frozen_undefined];
+}
+
+@* \[16] Saving and restoring equivalents.
+The nested structure given by \&{begingroup} and \&{endgroup}
+allows |eqtb| entries to be saved and restored, so that temporary changes
+can be made without difficulty. When the user requests a current value to
+be saved, \MP\ puts that value into its ``save stack.'' An appearance of
+\&{endgroup} ultimately causes the old values to be removed from the save
+stack and put back in their former places.
+
+The save stack is a linked list containing three kinds of entries,
+distinguished by their |info| fields. If |p| points to a saved item,
+then
+
+\smallskip\hang
+|info(p)=0| stands for a group boundary; each \&{begingroup} contributes
+such an item to the save stack and each \&{endgroup} cuts back the stack
+until the most recent such entry has been removed.
+
+\smallskip\hang
+|info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
+contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
+commands.
+
+\smallskip\hang
+|info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
+integer to be restored to internal parameter number~|q|. Such entries
+are generated by \&{interim} commands.
+
+\smallskip\noindent
+The global variable |save_ptr| points to the top item on the save stack.
+
+@d save_node_size 2 /* number of words per non-boundary save-stack node */
+@d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
+@d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
+ link((A))=mp->save_ptr; mp->save_ptr=(A);
+ }
+
+@<Glob...@>=
+pointer save_ptr; /* the most recently saved item */
+
+@ @<Set init...@>=mp->save_ptr=null;
+
+@ The |save_variable| routine is given a hash address |q|; it salts this
+address in the save stack, together with its current equivalent,
+then makes token~|q| behave as though it were brand new.
+
+Nothing is stacked when |save_ptr=null|, however; there's no way to remove
+things from the stack when the program is not inside a group, so there's
+no point in wasting the space.
+
+@c void mp_save_variable (MP mp,pointer q) {
+ pointer p; /* temporary register */
+ if ( mp->save_ptr!=null ){
+ p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
+ saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
+ }
+ mp_clear_symbol(mp, q,(mp->save_ptr!=null));
+}
+
+@ Similarly, |save_internal| is given the location |q| of an internal
+quantity like |mp_tracing_pens|. It creates a save stack entry of the
+third kind.
+
+@c void mp_save_internal (MP mp,halfword q) {
+ pointer p; /* new item for the save stack */
+ if ( mp->save_ptr!=null ){
+ p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
+ link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
+ }
+}
+
+@ At the end of a group, the |unsave| routine restores all of the saved
+equivalents in reverse order. This routine will be called only when there
+is at least one boundary item on the save stack.
+
+@c
+void mp_unsave (MP mp) {
+ pointer q; /* index to saved item */
+ pointer p; /* temporary register */
+ while ( info(mp->save_ptr)!=0 ) {
+ q=info(mp->save_ptr);
+ if ( q>hash_end ) {
+ if ( mp->internal[mp_tracing_restores]>0 ) {
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
+ mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
+ mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
+ mp_end_diagnostic(mp, false);
+ }
+ mp->internal[q-(hash_end)]=value(mp->save_ptr);
+ } else {
+ if ( mp->internal[mp_tracing_restores]>0 ) {
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
+ mp_print_text(q); mp_print_char(mp, '}');
+ mp_end_diagnostic(mp, false);
+ }
+ mp_clear_symbol(mp, q,false);
+ mp->eqtb[q]=saved_equiv(mp->save_ptr);
+ if ( eq_type(q) % outer_tag==tag_token ) {
+ p=equiv(q);
+ if ( p!=null ) name_type(p)=mp_root;
+ }
+ }
+ p=link(mp->save_ptr);
+ mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
+ }
+ p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
+}
+
+@* \[17] Data structures for paths.
+When a \MP\ user specifies a path, \MP\ will create a list of knots
+and control points for the associated cubic spline curves. If the
+knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
+$z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
+$z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
+@:Bezier}{B\'ezier, Pierre Etienne@>
+$$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
+&=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
+for |0<=t<=1|.
+
+There is a 8-word node for each knot $z_k$, containing one word of
+control information and six words for the |x| and |y| coordinates of
+$z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
+|left_type| and |right_type| fields, which each occupy a quarter of
+the first word in the node; they specify properties of the curve as it
+enters and leaves the knot. There's also a halfword |link| field,
+which points to the following knot, and a final supplementary word (of
+which only a quarter is used).
+
+If the path is a closed contour, knots 0 and |n| are identical;
+i.e., the |link| in knot |n-1| points to knot~0. But if the path
+is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
+are equal to |endpoint|. In the latter case the |link| in knot~|n| points
+to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
+
+@d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
+@d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
+@d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
+@d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
+@d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
+@d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
+@d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
+@d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
+@d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
+@d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
+@d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
+@d left_coord(A) mp->mem[(A)+2].sc
+ /* coordinate of previous control point given |x_loc| or |y_loc| */
+@d right_coord(A) mp->mem[(A)+4].sc
+ /* coordinate of next control point given |x_loc| or |y_loc| */
+@d knot_node_size 8 /* number of words in a knot node */
+
+@<Types...@>=
+enum mp_knot_type {
+ mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
+ mp_explicit, /* |left_type| or |right_type| when control points are known */
+ mp_given, /* |left_type| or |right_type| when a direction is given */
+ mp_curl, /* |left_type| or |right_type| when a curl is desired */
+ mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
+ mp_end_cycle
+};
+
+@ Before the B\'ezier control points have been calculated, the memory
+space they will ultimately occupy is taken up by information that can be
+used to compute them. There are four cases:
+
+\yskip
+\textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
+the knot in the same direction it entered; \MP\ will figure out a
+suitable direction.
+
+\yskip
+\textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
+knot in a direction depending on the angle at which it enters the next
+knot and on the curl parameter stored in |right_curl|.
+
+\yskip
+\textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
+knot in a nonzero direction stored as an |angle| in |right_given|.
+
+\yskip
+\textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
+point for leaving this knot has already been computed; it is in the
+|right_x| and |right_y| fields.
+
+\yskip\noindent
+The rules for |left_type| are similar, but they refer to the curve entering
+the knot, and to \\{left} fields instead of \\{right} fields.
+
+Non-|explicit| control points will be chosen based on ``tension'' parameters
+in the |left_tension| and |right_tension| fields. The
+`\&{atleast}' option is represented by negative tension values.
+@:at_least_}{\&{atleast} primitive@>
+
+For example, the \MP\ path specification
+$$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
+ 3 and 4..p},$$
+where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
+by the six knots
+\def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
+$$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
+|left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
+\noalign{\yskip}
+|endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
+|open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
+|curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
+|given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
+|open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
+|explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
+Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
+Of course, this example is more complicated than anything a normal user
+would ever write.
+
+These types must satisfy certain restrictions because of the form of \MP's
+path syntax:
+(i)~|open| type never appears in the same node together with |endpoint|,
+|given|, or |curl|.
+(ii)~The |right_type| of a node is |explicit| if and only if the
+|left_type| of the following node is |explicit|.
+(iii)~|endpoint| types occur only at the ends, as mentioned above.
+
+@d left_curl left_x /* curl information when entering this knot */
+@d left_given left_x /* given direction when entering this knot */
+@d left_tension left_y /* tension information when entering this knot */
+@d right_curl right_x /* curl information when leaving this knot */
+@d right_given right_x /* given direction when leaving this knot */
+@d right_tension right_y /* tension information when leaving this knot */
+
+@ Knots can be user-supplied, or they can be created by program code,
+like the |split_cubic| function, or |copy_path|. The distinction is
+needed for the cleanup routine that runs after |split_cubic|, because
+it should only delete knots it has previously inserted, and never
+anything that was user-supplied. In order to be able to differentiate
+one knot from another, we will set |originator(p):=mp_metapost_user| when
+it appeared in the actual metapost program, and
+|originator(p):=mp_program_code| in all other cases.
+
+@d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
+
+@<Types...@>=
+enum {
+ mp_program_code=0, /* not created by a user */
+ mp_metapost_user /* created by a user */
+};
+
+@ Here is a routine that prints a given knot list
+in symbolic form. It illustrates the conventions discussed above,
+and checks for anomalies that might arise while \MP\ is being debugged.
+
+@<Declare subroutines for printing expressions@>=
+void mp_pr_path (MP mp,pointer h);
+
+@ @c
+void mp_pr_path (MP mp,pointer h) {
+ pointer p,q; /* for list traversal */
+ p=h;
+ do {
+ q=link(p);
+ if ( (p==null)||(q==null) ) {
+ mp_print_nl(mp, "???"); return; /* this won't happen */
+@.???@>
+ }
+ @<Print information for adjacent knots |p| and |q|@>;
+ DONE1:
+ p=q;
+ if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
+ @<Print two dots, followed by |given| or |curl| if present@>;
+ }
+ } while (p!=h);
+ if ( left_type(h)!=mp_endpoint )
+ mp_print(mp, "cycle");
+}
+
+@ @<Print information for adjacent knots...@>=
+mp_print_two(mp, x_coord(p),y_coord(p));
+switch (right_type(p)) {
+case mp_endpoint:
+ if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
+@.open?@>
+ if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
+ goto DONE1;
+ break;
+case mp_explicit:
+ @<Print control points between |p| and |q|, then |goto done1|@>;
+ break;
+case mp_open:
+ @<Print information for a curve that begins |open|@>;
+ break;
+case mp_curl:
+case mp_given:
+ @<Print information for a curve that begins |curl| or |given|@>;
+ break;
+default:
+ mp_print(mp, "???"); /* can't happen */
+@.???@>
+ break;
+}
+if ( left_type(q)<=mp_explicit ) {
+ mp_print(mp, "..control?"); /* can't happen */
+@.control?@>
+} else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
+ @<Print tension between |p| and |q|@>;
+}
+
+@ Since |n_sin_cos| produces |fraction| results, which we will print as if they
+were |scaled|, the magnitude of a |given| direction vector will be~4096.
+
+@<Print two dots...@>=
+{
+ mp_print_nl(mp, " ..");
+ if ( left_type(p)==mp_given ) {
+ mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
+ mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
+ mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
+ } else if ( left_type(p)==mp_curl ){
+ mp_print(mp, "{curl ");
+ mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
+ }
+}
+
+@ @<Print tension between |p| and |q|@>=
+{
+ mp_print(mp, "..tension ");
+ if ( right_tension(p)<0 ) mp_print(mp, "atleast");
+ mp_print_scaled(mp, abs(right_tension(p)));
+ if ( right_tension(p)!=left_tension(q) ){
+ mp_print(mp, " and ");
+ if ( left_tension(q)<0 ) mp_print(mp, "atleast");
+ mp_print_scaled(mp, abs(left_tension(q)));
+ }
+}
+
+@ @<Print control points between |p| and |q|, then |goto done1|@>=
+{
+ mp_print(mp, "..controls ");
+ mp_print_two(mp, right_x(p),right_y(p));
+ mp_print(mp, " and ");
+ if ( left_type(q)!=mp_explicit ) {
+ mp_print(mp, "??"); /* can't happen */
+@.??@>
+ } else {
+ mp_print_two(mp, left_x(q),left_y(q));
+ }
+ goto DONE1;
+}
+
+@ @<Print information for a curve that begins |open|@>=
+if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
+ mp_print(mp, "{open?}"); /* can't happen */
+@.open?@>
+}
+
+@ A curl of 1 is shown explicitly, so that the user sees clearly that
+\MP's default curl is present.
+
+@<Print information for a curve that begins |curl|...@>=
+{
+ if ( left_type(p)==mp_open )
+ mp_print(mp, "??"); /* can't happen */
+@.??@>
+ if ( right_type(p)==mp_curl ) {
+ mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
+ } else {
+ mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
+ mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
+ mp_print_scaled(mp, mp->n_sin);
+ }
+ mp_print_char(mp, '}');
+}
+
+@ It is convenient to have another version of |pr_path| that prints the path
+as a diagnostic message.
+
+@<Declare subroutines for printing expressions@>=
+void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
+ mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
+@.Path at line...@>
+ mp_pr_path(mp, h);
+ mp_end_diagnostic(mp, true);
+}
+
+@ If we want to duplicate a knot node, we can say |copy_knot|:
+
+@c
+pointer mp_copy_knot (MP mp,pointer p) {
+ pointer q; /* the copy */
+ int k; /* runs through the words of a knot node */
+ q=mp_get_node(mp, knot_node_size);
+ for (k=0;k<knot_node_size;k++) {
+ mp->mem[q+k]=mp->mem[p+k];
+ }
+ originator(q)=originator(p);
+ return q;
+}
+
+@ The |copy_path| routine makes a clone of a given path.
+
+@c
+pointer mp_copy_path (MP mp, pointer p) {
+ pointer q,pp,qq; /* for list manipulation */
+ q=mp_copy_knot(mp, p);
+ qq=q; pp=link(p);
+ while ( pp!=p ) {
+ link(qq)=mp_copy_knot(mp, pp);
+ qq=link(qq);
+ pp=link(pp);
+ }
+ link(qq)=q;
+ return q;
+}
+
+
+@ Just before |ship_out|, knot lists are exported for printing.
+
+The |gr_XXXX| macros are defined in |mppsout.h|.
+
+@c
+mp_knot *mp_export_knot (MP mp,pointer p) {
+ mp_knot *q; /* the copy */
+ if (p==null)
+ return NULL;
+ q = mp_xmalloc(mp, 1, sizeof (mp_knot));
+ memset(q,0,sizeof (mp_knot));
+ gr_left_type(q) = left_type(p);
+ gr_right_type(q) = right_type(p);
+ gr_x_coord(q) = x_coord(p);
+ gr_y_coord(q) = y_coord(p);
+ gr_left_x(q) = left_x(p);
+ gr_left_y(q) = left_y(p);
+ gr_right_x(q) = right_x(p);
+ gr_right_y(q) = right_y(p);
+ gr_originator(q) = originator(p);
+ return q;
+}
+
+@ The |export_knot_list| routine therefore also makes a clone
+of a given path.
+
+@c
+mp_knot *mp_export_knot_list (MP mp, pointer p) {
+ mp_knot *q, *qq; /* for list manipulation */
+ pointer pp; /* for list manipulation */
+ if (p==null)
+ return NULL;
+ q=mp_export_knot(mp, p);
+ qq=q; pp=link(p);
+ while ( pp!=p ) {
+ gr_next_knot(qq)=mp_export_knot(mp, pp);
+ qq=gr_next_knot(qq);
+ pp=link(pp);
+ }
+ gr_next_knot(qq)=q;
+ return q;
+}
+
+
+@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
+returns a pointer to the first node of the copy, if the path is a cycle,
+but to the final node of a non-cyclic copy. The global
+variable |path_tail| will point to the final node of the original path;
+this trick makes it easier to implement `\&{doublepath}'.
+
+All node types are assumed to be |endpoint| or |explicit| only.
+
+@c
+pointer mp_htap_ypoc (MP mp,pointer p) {
+ pointer q,pp,qq,rr; /* for list manipulation */
+ q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
+ qq=q; pp=p;
+ while (1) {
+ right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
+ x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
+ right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
+ left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
+ originator(qq)=originator(pp);
+ if ( link(pp)==p ) {
+ link(q)=qq; mp->path_tail=pp; return q;
+ }
+ rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
+ }
+}
+
+@ @<Glob...@>=
+pointer path_tail; /* the node that links to the beginning of a path */
+
+@ When a cyclic list of knot nodes is no longer needed, it can be recycled by
+calling the following subroutine.
+
+@<Declare the recycling subroutines@>=
+void mp_toss_knot_list (MP mp,pointer p) ;
+
+@ @c
+void mp_toss_knot_list (MP mp,pointer p) {
+ pointer q; /* the node being freed */
+ pointer r; /* the next node */
+ q=p;
+ do {
+ r=link(q);
+ mp_free_node(mp, q,knot_node_size); q=r;
+ } while (q!=p);
+}
+
+@* \[18] Choosing control points.
+Now we must actually delve into one of \MP's more difficult routines,
+the |make_choices| procedure that chooses angles and control points for
+the splines of a curve when the user has not specified them explicitly.
+The parameter to |make_choices| points to a list of knots and
+path information, as described above.
+
+A path decomposes into independent segments at ``breakpoint'' knots,
+which are knots whose left and right angles are both prespecified in
+some way (i.e., their |left_type| and |right_type| aren't both open).
+
+@c
+@<Declare the procedure called |solve_choices|@>
+void mp_make_choices (MP mp,pointer knots) {
+ pointer h; /* the first breakpoint */
+ pointer p,q; /* consecutive breakpoints being processed */
+ @<Other local variables for |make_choices|@>;
+ check_arith; /* make sure that |arith_error=false| */
+ if ( mp->internal[mp_tracing_choices]>0 )
+ mp_print_path(mp, knots,", before choices",true);
+ @<If consecutive knots are equal, join them explicitly@>;
+ @<Find the first breakpoint, |h|, on the path;
+ insert an artificial breakpoint if the path is an unbroken cycle@>;
+ p=h;
+ do {
+ @<Fill in the control points between |p| and the next breakpoint,
+ then advance |p| to that breakpoint@>;
+ } while (p!=h);
+ if ( mp->internal[mp_tracing_choices]>0 )
+ mp_print_path(mp, knots,", after choices",true);
+ if ( mp->arith_error ) {
+ @<Report an unexpected problem during the choice-making@>;
+ }
+}
+
+@ @<Report an unexpected problem during the choice...@>=
+{
+ print_err("Some number got too big");
+@.Some number got too big@>
+ help2("The path that I just computed is out of range.")
+ ("So it will probably look funny. Proceed, for a laugh.");
+ mp_put_get_error(mp); mp->arith_error=false;
+}
+
+@ Two knots in a row with the same coordinates will always be joined
+by an explicit ``curve'' whose control points are identical with the
+knots.
+
+@<If consecutive knots are equal, join them explicitly@>=
+p=knots;
+do {
+ q=link(p);
+ if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
+ right_type(p)=mp_explicit;
+ if ( left_type(p)==mp_open ) {
+ left_type(p)=mp_curl; left_curl(p)=unity;
+ }
+ left_type(q)=mp_explicit;
+ if ( right_type(q)==mp_open ) {
+ right_type(q)=mp_curl; right_curl(q)=unity;
+ }
+ right_x(p)=x_coord(p); left_x(q)=x_coord(p);
+ right_y(p)=y_coord(p); left_y(q)=y_coord(p);
+ }
+ p=q;
+} while (p!=knots)
+
+@ If there are no breakpoints, it is necessary to compute the direction
+angles around an entire cycle. In this case the |left_type| of the first
+node is temporarily changed to |end_cycle|.
+
+@<Find the first breakpoint, |h|, on the path...@>=
+h=knots;
+while (1) {
+ if ( left_type(h)!=mp_open ) break;
+ if ( right_type(h)!=mp_open ) break;
+ h=link(h);
+ if ( h==knots ) {
+ left_type(h)=mp_end_cycle; break;
+ }
+}
+
+@ If |right_type(p)<given| and |q=link(p)|, we must have
+|right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
+
+@<Fill in the control points between |p| and the next breakpoint...@>=
+q=link(p);
+if ( right_type(p)>=mp_given ) {
+ while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
+ @<Fill in the control information between
+ consecutive breakpoints |p| and |q|@>;
+} else if ( right_type(p)==mp_endpoint ) {
+ @<Give reasonable values for the unused control points between |p| and~|q|@>;
+}
+p=q
+
+@ This step makes it possible to transform an explicitly computed path without
+checking the |left_type| and |right_type| fields.
+
+@<Give reasonable values for the unused control points between |p| and~|q|@>=
+{
+ right_x(p)=x_coord(p); right_y(p)=y_coord(p);
+ left_x(q)=x_coord(q); left_y(q)=y_coord(q);
+}
+
+@ Before we can go further into the way choices are made, we need to
+consider the underlying theory. The basic ideas implemented in |make_choices|
+are due to John Hobby, who introduced the notion of ``mock curvature''
+@^Hobby, John Douglas@>
+at a knot. Angles are chosen so that they preserve mock curvature when
+a knot is passed, and this has been found to produce excellent results.
+
+It is convenient to introduce some notations that simplify the necessary
+formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
+between knots |k| and |k+1|; and let
+$${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
+so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
+through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
+The control points for the spline from $z_k$ to $z\k$ will be denoted by
+$$\eqalign{z_k^+&=z_k+
+ \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
+ z\k^-&=z\k-
+ \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
+where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
+beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
+corresponding ``offset angles.'' These angles satisfy the condition
+$$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
+whenever the curve leaves an intermediate knot~|k| in the direction that
+it enters.
+
+@ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
+the curve at its beginning and ending points. This means that
+$\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
+where $f(\theta,\phi)$ is \MP's standard velocity function defined in
+the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
+z\k^-,z\k^{\phantom+};t)$
+has curvature
+@^curvature@>
+$${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
+\qquad{\rm and}\qquad
+{2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
+at |t=0| and |t=1|, respectively. The mock curvature is the linear
+@^mock curvature@>
+approximation to this true curvature that arises in the limit for
+small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
+The standard velocity function satisfies
+$$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
+hence the mock curvatures are respectively
+$${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
+\qquad{\rm and}\qquad
+{2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
+
+@ The turning angles $\psi_k$ are given, and equation $(*)$ above
+determines $\phi_k$ when $\theta_k$ is known, so the task of
+angle selection is essentially to choose appropriate values for each
+$\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
+from $(**)$, we obtain a system of linear equations of the form
+$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
+where
+$$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
+\qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
+\qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
+\qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
+The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
+will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
+$C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
+hence they have a unique solution. Moreover, in most cases the tensions
+are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
+solution numerically stable, and there is an exponential damping
+effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
+a factor of~$O(2^{-j})$.
+
+@ However, we still must consider the angles at the starting and ending
+knots of a non-cyclic path. These angles might be given explicitly, or
+they might be specified implicitly in terms of an amount of ``curl.''
+
+Let's assume that angles need to be determined for a non-cyclic path
+starting at $z_0$ and ending at~$z_n$. Then equations of the form
+$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
+have been given for $0<k<n$, and it will be convenient to introduce
+equations of the same form for $k=0$ and $k=n$, where
+$$A_0=B_0=C_n=D_n=0.$$
+If $\theta_0$ is supposed to have a given value $E_0$, we simply
+define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
+parameter, $\gamma_0$, has been specified at~$z_0$; this means
+that the mock curvature at $z_0$ should be $\gamma_0$ times the
+mock curvature at $z_1$; i.e.,
+$${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
+=\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
+This equation simplifies to
+$$(\alpha_0\chi_0+3-\beta_1)\theta_0+
+ \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
+ -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
+where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
+\chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
+It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
+hence the linear equations remain nonsingular.
+
+Similar considerations apply at the right end, when the final angle $\phi_n$
+may or may not need to be determined. It is convenient to let $\psi_n=0$,
+hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
+or we have
+$$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
+(\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
+ \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
+
+When |make_choices| chooses angles, it must compute the coefficients of
+these linear equations, then solve the equations. To compute the coefficients,
+it is necessary to compute arctangents of the given turning angles~$\psi_k$.
+When the equations are solved, the chosen directions $\theta_k$ are put
+back into the form of control points by essentially computing sines and
+cosines.
+
+@ OK, we are ready to make the hard choices of |make_choices|.
+Most of the work is relegated to an auxiliary procedure
+called |solve_choices|, which has been introduced to keep
+|make_choices| from being extremely long.
+
+@<Fill in the control information between...@>=
+@<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
+ set $n$ to the length of the path@>;
+@<Remove |open| types at the breakpoints@>;
+mp_solve_choices(mp, p,q,n)
+
+@ It's convenient to precompute quantities that will be needed several
+times later. The values of |delta_x[k]| and |delta_y[k]| will be the
+coordinates of $z\k-z_k$, and the magnitude of this vector will be
+|delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
+and $z\k-z_k$ will be stored in |psi[k]|.
+
+@<Glob...@>=
+int path_size; /* maximum number of knots between breakpoints of a path */
+scaled *delta_x;
+scaled *delta_y;
+scaled *delta; /* knot differences */
+angle *psi; /* turning angles */
+
+@ @<Allocate or initialize ...@>=
+mp->delta_x = NULL;
+mp->delta_y = NULL;
+mp->delta = NULL;
+mp->psi = NULL;
+
+@ @<Dealloc variables@>=
+xfree(mp->delta_x);
+xfree(mp->delta_y);
+xfree(mp->delta);
+xfree(mp->psi);
+
+@ @<Other local variables for |make_choices|@>=
+ int k,n; /* current and final knot numbers */
+ pointer s,t; /* registers for list traversal */
+ scaled delx,dely; /* directions where |open| meets |explicit| */
+ fraction sine,cosine; /* trig functions of various angles */
+
+@ @<Calculate the turning angles...@>=
+{
+RESTART:
+ k=0; s=p; n=mp->path_size;
+ do {
+ t=link(s);
+ mp->delta_x[k]=x_coord(t)-x_coord(s);
+ mp->delta_y[k]=y_coord(t)-y_coord(s);
+ mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
+ if ( k>0 ) {
+ sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
+ cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
+ mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
+ mp_take_fraction(mp, mp->delta_y[k],sine),
+ mp_take_fraction(mp, mp->delta_y[k],cosine)-
+ mp_take_fraction(mp, mp->delta_x[k],sine));
+ }
+ incr(k); s=t;
+ if ( k==mp->path_size ) {
+ mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
+ goto RESTART; /* retry, loop size has changed */
+ }
+ if ( s==q ) n=k;
+ } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
+ if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
+}
+
+@ When we get to this point of the code, |right_type(p)| is either
+|given| or |curl| or |open|. If it is |open|, we must have
+|left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
+case, the |open| type is converted to |given|; however, if the
+velocity coming into this knot is zero, the |open| type is
+converted to a |curl|, since we don't know the incoming direction.
+
+Similarly, |left_type(q)| is either |given| or |curl| or |open| or
+|mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
+
+@<Remove |open| types at the breakpoints@>=
+if ( left_type(q)==mp_open ) {
+ delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
+ if ( (delx==0)&&(dely==0) ) {
+ left_type(q)=mp_curl; left_curl(q)=unity;
+ } else {
+ left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
+ }
+}
+if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
+ delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
+ if ( (delx==0)&&(dely==0) ) {
+ right_type(p)=mp_curl; right_curl(p)=unity;
+ } else {
+ right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
+ }
+}
+
+@ Linear equations need to be solved whenever |n>1|; and also when |n=1|
+and exactly one of the breakpoints involves a curl. The simplest case occurs
+when |n=1| and there is a curl at both breakpoints; then we simply draw
+a straight line.
+
+But before coding up the simple cases, we might as well face the general case,
+since we must deal with it sooner or later, and since the general case
+is likely to give some insight into the way simple cases can be handled best.
+
+When there is no cycle, the linear equations to be solved form a tridiagonal
+system, and we can apply the standard technique of Gaussian elimination
+to convert that system to a sequence of equations of the form
+$$\theta_0+u_0\theta_1=v_0,\quad
+\theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
+\theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
+\theta_n=v_n.$$
+It is possible to do this diagonalization while generating the equations.
+Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
+$\theta_1$, $\theta_0$; thus, the equations will be solved.
+
+The procedure is slightly more complex when there is a cycle, but the
+basic idea will be nearly the same. In the cyclic case the right-hand
+sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
+the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
+$\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
+ending routine will take account of the fact that $\theta_n=\theta_0$ and
+eliminate the $w$'s from the system, after which the solution can be
+obtained as before.
+
+When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
+variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
+and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
+of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
+
+@<Glob...@>=
+angle *theta; /* values of $\theta_k$ */
+fraction *uu; /* values of $u_k$ */
+angle *vv; /* values of $v_k$ */
+fraction *ww; /* values of $w_k$ */
+
+@ @<Allocate or initialize ...@>=
+mp->theta = NULL;
+mp->uu = NULL;
+mp->vv = NULL;
+mp->ww = NULL;
+
+@ @<Dealloc variables@>=
+xfree(mp->theta);
+xfree(mp->uu);
+xfree(mp->vv);
+xfree(mp->ww);
+
+@ @<Declare |mp_reallocate| functions@>=
+void mp_reallocate_paths (MP mp, int l);
+
+@ @c
+void mp_reallocate_paths (MP mp, int l) {
+ XREALLOC (mp->delta_x, l, scaled);
+ XREALLOC (mp->delta_y, l, scaled);
+ XREALLOC (mp->delta, l, scaled);
+ XREALLOC (mp->psi, l, angle);
+ XREALLOC (mp->theta, l, angle);
+ XREALLOC (mp->uu, l, fraction);
+ XREALLOC (mp->vv, l, angle);
+ XREALLOC (mp->ww, l, fraction);
+ mp->path_size = l;
+}
+
+@ Our immediate problem is to get the ball rolling by setting up the
+first equation or by realizing that no equations are needed, and to fit
+this initialization into a framework suitable for the overall computation.
+
+@<Declare the procedure called |solve_choices|@>=
+@<Declare subroutines needed by |solve_choices|@>
+void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
+ int k; /* current knot number */
+ pointer r,s,t; /* registers for list traversal */
+ @<Other local variables for |solve_choices|@>;
+ k=0; s=p; r=0;
+ while (1) {
+ t=link(s);
+ if ( k==0 ) {
+ @<Get the linear equations started; or |return|
+ with the control points in place, if linear equations
+ needn't be solved@>
+ } else {
+ switch (left_type(s)) {
+ case mp_end_cycle: case mp_open:
+ @<Set up equation to match mock curvatures
+ at $z_k$; then |goto found| with $\theta_n$
+ adjusted to equal $\theta_0$, if a cycle has ended@>;
+ break;
+ case mp_curl:
+ @<Set up equation for a curl at $\theta_n$
+ and |goto found|@>;
+ break;
+ case mp_given:
+ @<Calculate the given value of $\theta_n$
+ and |goto found|@>;
+ break;
+ } /* there are no other cases */
+ }
+ r=s; s=t; incr(k);
+ }
+FOUND:
+ @<Finish choosing angles and assigning control points@>;
+}
+
+@ On the first time through the loop, we have |k=0| and |r| is not yet
+defined. The first linear equation, if any, will have $A_0=B_0=0$.
+
+@<Get the linear equations started...@>=
+switch (right_type(s)) {
+case mp_given:
+ if ( left_type(t)==mp_given ) {
+ @<Reduce to simple case of two givens and |return|@>
+ } else {
+ @<Set up the equation for a given value of $\theta_0$@>;
+ }
+ break;
+case mp_curl:
+ if ( left_type(t)==mp_curl ) {
+ @<Reduce to simple case of straight line and |return|@>
+ } else {
+ @<Set up the equation for a curl at $\theta_0$@>;
+ }
+ break;
+case mp_open:
+ mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
+ /* this begins a cycle */
+ break;
+} /* there are no other cases */
+
+@ The general equation that specifies equality of mock curvature at $z_k$ is
+$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
+as derived above. We want to combine this with the already-derived equation
+$\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
+a new equation
+$\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
+equation
+$$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1}
+ -A_kw_{k-1}\theta_0$$
+by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
+fixed-point arithmetic, avoiding the chance of overflow while retaining
+suitable precision.
+
+The calculations will be performed in several registers that
+provide temporary storage for intermediate quantities.
+
+@<Other local variables for |solve_choices|@>=
+fraction aa,bb,cc,ff,acc; /* temporary registers */
+scaled dd,ee; /* likewise, but |scaled| */
+scaled lt,rt; /* tension values */
+
+@ @<Set up equation to match mock curvatures...@>=
+{ @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
+ $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
+ and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
+ @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
+ mp->uu[k]=mp_take_fraction(mp, ff,bb);
+ @<Calculate the values of $v_k$ and $w_k$@>;
+ if ( left_type(s)==mp_end_cycle ) {
+ @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
+ }
+}
+
+@ Since tension values are never less than 3/4, the values |aa| and
+|bb| computed here are never more than 4/5.
+
+@<Calculate the values $\\{aa}=...@>=
+if ( abs(right_tension(r))==unity) {
+ aa=fraction_half; dd=2*mp->delta[k];
+} else {
+ aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
+ dd=mp_take_fraction(mp, mp->delta[k],
+ fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
+}
+if ( abs(left_tension(t))==unity ){
+ bb=fraction_half; ee=2*mp->delta[k-1];
+} else {
+ bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
+ ee=mp_take_fraction(mp, mp->delta[k-1],
+ fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
+}
+cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
+
+@ The ratio to be calculated in this step can be written in the form
+$$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
+ \\{cc}\cdot\\{dd},$$
+because of the quantities just calculated. The values of |dd| and |ee|
+will not be needed after this step has been performed.
+
+@<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
+dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
+if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
+ if ( lt<rt ) {
+ ff=mp_make_fraction(mp, lt,rt);
+ ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
+ dd=mp_take_fraction(mp, dd,ff);
+ } else {
+ ff=mp_make_fraction(mp, rt,lt);
+ ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
+ ee=mp_take_fraction(mp, ee,ff);
+ }
+}
+ff=mp_make_fraction(mp, ee,ee+dd)
+
+@ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
+equation was specified by a curl. In that case we must use a special
+method of computation to prevent overflow.
+
+Fortunately, the calculations turn out to be even simpler in this ``hard''
+case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
+$-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
+
+@<Calculate the values of $v_k$ and $w_k$@>=
+acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
+if ( right_type(r)==mp_curl ) {
+ mp->ww[k]=0;
+ mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
+} else {
+ ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
+ $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
+ acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
+ ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
+ mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
+ if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
+ else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
+}
+
+@ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
+v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
+$\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
+for |0<=k<n|, so that the cyclic case can be finished up just as if there
+were no cycle.
+
+The idea in the following code is to observe that
+$$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
+&=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
+ -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
+so we can solve for $\theta_n=\theta_0$.
+
+@<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
+{
+aa=0; bb=fraction_one; /* we have |k=n| */
+do { decr(k);
+if ( k==0 ) k=n;
+ aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
+ bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
+} while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
+aa=mp_make_fraction(mp, aa,fraction_one-bb);
+mp->theta[n]=aa; mp->vv[0]=aa;
+for (k=1;k<=n-1;k++) {
+ mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
+}
+goto FOUND;
+}
+
+@ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
+ if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
+
+@<Calculate the given value of $\theta_n$...@>=
+{
+ mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
+ reduce_angle(mp->theta[n]);
+ goto FOUND;
+}
+
+@ @<Set up the equation for a given value of $\theta_0$@>=
+{
+ mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
+ reduce_angle(mp->vv[0]);
+ mp->uu[0]=0; mp->ww[0]=0;
+}
+
+@ @<Set up the equation for a curl at $\theta_0$@>=
+{ cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
+ if ( (rt==unity)&&(lt==unity) )
+ mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
+ else
+ mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
+ mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
+}
+
+@ @<Set up equation for a curl at $\theta_n$...@>=
+{ cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
+ if ( (rt==unity)&&(lt==unity) )
+ ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
+ else
+ ff=mp_curl_ratio(mp, cc,lt,rt);
+ mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
+ fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
+ goto FOUND;
+}
+
+@ The |curl_ratio| subroutine has three arguments, which our previous notation
+encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
+a somewhat tedious program to calculate
+$${(3-\alpha)\alpha^2\gamma+\beta^3\over
+ \alpha^3\gamma+(3-\beta)\beta^2},$$
+with the result reduced to 4 if it exceeds 4. (This reduction of curl
+is necessary only if the curl and tension are both large.)
+The values of $\alpha$ and $\beta$ will be at most~4/3.
+
+@<Declare subroutines needed by |solve_choices|@>=
+fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
+ scaled b_tension) {
+ fraction alpha,beta,num,denom,ff; /* registers */
+ alpha=mp_make_fraction(mp, unity,a_tension);
+ beta=mp_make_fraction(mp, unity,b_tension);
+ if ( alpha<=beta ) {
+ ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
+ gamma=mp_take_fraction(mp, gamma,ff);
+ beta=beta / 010000; /* convert |fraction| to |scaled| */
+ denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
+ num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
+ } else {
+ ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
+ beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
+ denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
+ /* $1365\approx 2^{12}/3$ */
+ num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
+ }
+ if ( num>=denom+denom+denom+denom ) return fraction_four;
+ else return mp_make_fraction(mp, num,denom);
+}
+
+@ We're in the home stretch now.
+
+@<Finish choosing angles and assigning control points@>=
+for (k=n-1;k>=0;k--) {
+ mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
+}
+s=p; k=0;
+do {
+ t=link(s);
+ mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
+ mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
+ mp_set_controls(mp, s,t,k);
+ incr(k); s=t;
+} while (k!=n)
+
+@ The |set_controls| routine actually puts the control points into
+a pair of consecutive nodes |p| and~|q|. Global variables are used to
+record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
+$\cos\phi$ needed in this calculation.
+
+@<Glob...@>=
+fraction st;
+fraction ct;
+fraction sf;
+fraction cf; /* sines and cosines */
+
+@ @<Declare subroutines needed by |solve_choices|@>=
+void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
+ fraction rr,ss; /* velocities, divided by thrice the tension */
+ scaled lt,rt; /* tensions */
+ fraction sine; /* $\sin(\theta+\phi)$ */
+ lt=abs(left_tension(q)); rt=abs(right_tension(p));
+ rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
+ ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
+ if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
+ @<Decrease the velocities,
+ if necessary, to stay inside the bounding triangle@>;
+ }
+ right_x(p)=x_coord(p)+mp_take_fraction(mp,
+ mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
+ mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
+ right_y(p)=y_coord(p)+mp_take_fraction(mp,
+ mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
+ mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
+ left_x(q)=x_coord(q)-mp_take_fraction(mp,
+ mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
+ mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
+ left_y(q)=y_coord(q)-mp_take_fraction(mp,
+ mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
+ mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
+ right_type(p)=mp_explicit; left_type(q)=mp_explicit;
+}
+
+@ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
+$\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
+$\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
+there is no ``bounding triangle.''
+
+@<Decrease the velocities, if necessary...@>=
+if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
+ sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
+ mp_take_fraction(mp, abs(mp->sf),mp->ct);
+ if ( sine>0 ) {
+ sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
+ if ( right_tension(p)<0 )
+ if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
+ rr=mp_make_fraction(mp, abs(mp->sf),sine);
+ if ( left_tension(q)<0 )
+ if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
+ ss=mp_make_fraction(mp, abs(mp->st),sine);
+ }
+}
+
+@ Only the simple cases remain to be handled.
+
+@<Reduce to simple case of two givens and |return|@>=
+{
+ aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
+ mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
+ mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
+ mp_set_controls(mp, p,q,0); return;
+}
+
+@ @<Reduce to simple case of straight line and |return|@>=
+{
+ right_type(p)=mp_explicit; left_type(q)=mp_explicit;
+ lt=abs(left_tension(q)); rt=abs(right_tension(p));
+ if ( rt==unity ) {
+ if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
+ else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
+ if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
+ else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
+ } else {
+ ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
+ right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
+ right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
+ }
+ if ( lt==unity ) {
+ if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
+ else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
+ if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
+ else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
+ } else {
+ ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
+ left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
+ left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
+ }
+ return;
+}
+
+@* \[19] Measuring paths.
+\MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
+allow the user to measure the bounding box of anything that can go into a
+picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
+by just finding the bounding box of the knots and the control points. We
+need a more accurate version of the bounding box, but we can still use the
+easy estimate to save time by focusing on the interesting parts of the path.
+
+@ Computing an accurate bounding box involves a theme that will come up again
+and again. Given a Bernshte{\u\i}n polynomial
+@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
+$$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
+we can conveniently bisect its range as follows:
+
+\smallskip
+\textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
+
+\smallskip
+\textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
+|0<=k<n-j|, for |0<=j<n|.
+
+\smallskip\noindent
+Then
+$$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
+ =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
+This formula gives us the coefficients of polynomials to use over the ranges
+$0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
+
+@ Now here's a subroutine that's handy for all sorts of path computations:
+Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
+returns the unique |fraction| value |t| between 0 and~1 at which
+$B(a,b,c;t)$ changes from positive to negative, or returns
+|t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
+is already negative at |t=0|), |crossing_point| returns the value zero.
+
+@d no_crossing { return (fraction_one+1); }
+@d one_crossing { return fraction_one; }
+@d zero_crossing { return 0; }
+@d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
+
+@c fraction mp_do_crossing_point (integer a, integer b, integer c) {
+ integer d; /* recursive counter */
+ integer x,xx,x0,x1,x2; /* temporary registers for bisection */
+ if ( a<0 ) zero_crossing;
+ if ( c>=0 ) {
+ if ( b>=0 ) {
+ if ( c>0 ) { no_crossing; }
+ else if ( (a==0)&&(b==0) ) { no_crossing;}
+ else { one_crossing; }
+ }
+ if ( a==0 ) zero_crossing;
+ } else if ( a==0 ) {
+ if ( b<=0 ) zero_crossing;
+ }
+ @<Use bisection to find the crossing point, if one exists@>;
+}
+
+@ The general bisection method is quite simple when $n=2$, hence
+|crossing_point| does not take much time. At each stage in the
+recursion we have a subinterval defined by |l| and~|j| such that
+$B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
+the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
+
+It is convenient for purposes of calculation to combine the values
+of |l| and~|j| in a single variable $d=2^l+j$, because the operation
+of bisection then corresponds simply to doubling $d$ and possibly
+adding~1. Furthermore it proves to be convenient to modify
+our previous conventions for bisection slightly, maintaining the
+variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
+With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
+equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
+
+The following code maintains the invariant relations
+$0\L|x0|<\max(|x1|,|x1|+|x2|)$,
+$\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
+it has been constructed in such a way that no arithmetic overflow
+will occur if the inputs satisfy
+$a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
+
+@<Use bisection to find the crossing point...@>=
+d=1; x0=a; x1=a-b; x2=b-c;
+do {
+ x=half(x1+x2);
+ if ( x1-x0>x0 ) {
+ x2=x; x0+=x0; d+=d;
+ } else {
+ xx=x1+x-x0;
+ if ( xx>x0 ) {
+ x2=x; x0+=x0; d+=d;
+ } else {
+ x0=x0-xx;
+ if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
+ x1=x; d=d+d+1;
+ }
+ }
+} while (d<fraction_one);
+return (d-fraction_one)
+
+@ Here is a routine that computes the $x$ or $y$ coordinate of the point on
+a cubic corresponding to the |fraction| value~|t|.
+
+It is convenient to define a \.{WEB} macro |t_of_the_way| such that
+|t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
+
+@d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
+
+@c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
+ scaled x1,x2,x3; /* intermediate values */
+ x1=t_of_the_way(knot_coord(p),right_coord(p));
+ x2=t_of_the_way(right_coord(p),left_coord(q));
+ x3=t_of_the_way(left_coord(q),knot_coord(q));
+ x1=t_of_the_way(x1,x2);
+ x2=t_of_the_way(x2,x3);
+ return t_of_the_way(x1,x2);
+}
+
+@ The actual bounding box information is stored in global variables.
+Since it is convenient to address the $x$ and $y$ information
+separately, we define arrays indexed by |x_code..y_code| and use
+macros to give them more convenient names.
+
+@<Types...@>=
+enum mp_bb_code {
+ mp_x_code=0, /* index for |minx| and |maxx| */
+ mp_y_code /* index for |miny| and |maxy| */
+} ;
+
+@
+@d minx mp->bbmin[mp_x_code]
+@d maxx mp->bbmax[mp_x_code]
+@d miny mp->bbmin[mp_y_code]
+@d maxy mp->bbmax[mp_y_code]
+
+@<Glob...@>=
+scaled bbmin[mp_y_code+1];
+scaled bbmax[mp_y_code+1];
+/* the result of procedures that compute bounding box information */
+
+@ Now we're ready for the key part of the bounding box computation.
+The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
+$$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
+ \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
+$$
+for $0<t\le1$. In other words, the procedure adjusts the bounds to
+accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
+The |c| parameter is |x_code| or |y_code|.
+
+@c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
+ boolean wavy; /* whether we need to look for extremes */
+ scaled del1,del2,del3,del,dmax; /* proportional to the control
+ points of a quadratic derived from a cubic */
+ fraction t,tt; /* where a quadratic crosses zero */
+ scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
+ x=knot_coord(q);
+ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
+ @<Check the control points against the bounding box and set |wavy:=true|
+ if any of them lie outside@>;
+ if ( wavy ) {
+ del1=right_coord(p)-knot_coord(p);
+ del2=left_coord(q)-right_coord(p);
+ del3=knot_coord(q)-left_coord(q);
+ @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
+ also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
+ if ( del<0 ) {
+ negate(del1); negate(del2); negate(del3);
+ };
+ t=mp_crossing_point(mp, del1,del2,del3);
+ if ( t<fraction_one ) {
+ @<Test the extremes of the cubic against the bounding box@>;
+ }
+ }
+}
+
+@ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
+if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
+if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
+
+@ @<Check the control points against the bounding box and set...@>=
+wavy=true;
+if ( mp->bbmin[c]<=right_coord(p) )
+ if ( right_coord(p)<=mp->bbmax[c] )
+ if ( mp->bbmin[c]<=left_coord(q) )
+ if ( left_coord(q)<=mp->bbmax[c] )
+ wavy=false
+
+@ If |del1=del2=del3=0|, it's impossible to obey the title of this
+section. We just set |del=0| in that case.
+
+@<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
+if ( del1!=0 ) del=del1;
+else if ( del2!=0 ) del=del2;
+else del=del3;
+if ( del!=0 ) {
+ dmax=abs(del1);
+ if ( abs(del2)>dmax ) dmax=abs(del2);
+ if ( abs(del3)>dmax ) dmax=abs(del3);
+ while ( dmax<fraction_half ) {
+ dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
+ }
+}
+
+@ Since |crossing_point| has tried to choose |t| so that
+$B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
+slope, the value of |del2| computed below should not be positive.
+But rounding error could make it slightly positive in which case we
+must cut it to zero to avoid confusion.
+
+@<Test the extremes of the cubic against the bounding box@>=
+{
+ x=mp_eval_cubic(mp, p,q,t);
+ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
+ del2=t_of_the_way(del2,del3);
+ /* now |0,del2,del3| represent the derivative on the remaining interval */
+ if ( del2>0 ) del2=0;
+ tt=mp_crossing_point(mp, 0,-del2,-del3);
+ if ( tt<fraction_one ) {
+ @<Test the second extreme against the bounding box@>;
+ }
+}
+
+@ @<Test the second extreme against the bounding box@>=
+{
+ x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
+ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
+}
+
+@ Finding the bounding box of a path is basically a matter of applying
+|bound_cubic| twice for each pair of adjacent knots.
+
+@c void mp_path_bbox (MP mp,pointer h) {
+ pointer p,q; /* a pair of adjacent knots */
+ minx=x_coord(h); miny=y_coord(h);
+ maxx=minx; maxy=miny;
+ p=h;
+ do {
+ if ( right_type(p)==mp_endpoint ) return;
+ q=link(p);
+ mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
+ mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
+ p=q;
+ } while (p!=h);
+}
+
+@ Another important way to measure a path is to find its arc length. This
+is best done by using the general bisection algorithm to subdivide the path
+until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
+by simple means.
+
+Since the arc length is the integral with respect to time of the magnitude of
+the velocity, it is natural to use Simpson's rule for the approximation.
+@^Simpson's rule@>
+If $\dot B(t)$ is the spline velocity, Simpson's rule gives
+$$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
+for the arc length of a path of length~1. For a cubic spline
+$B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
+$3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
+approximation is
+$$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
+where
+$$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
+is the result of the bisection algorithm.
+
+@ The remaining problem is how to decide when a subpath is ``well behaved.''
+This could be done via the theoretical error bound for Simpson's rule,
+@^Simpson's rule@>
+but this is impractical because it requires an estimate of the fourth
+derivative of the quantity being integrated. It is much easier to just perform
+a bisection step and see how much the arc length estimate changes. Since the
+error for Simpson's rule is proportional to the fourth power of the sample
+spacing, the remaining error is typically about $1\over16$ of the amount of
+the change. We say ``typically'' because the error has a pseudo-random behavior
+that could cause the two estimates to agree when each contain large errors.
+
+To protect against disasters such as undetected cusps, the bisection process
+should always continue until all the $dz_i$ vectors belong to a single
+$90^\circ$ sector. This ensures that no point on the spline can have velocity
+less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
+If such a spline happens to produce an erroneous arc length estimate that
+is little changed by bisection, the amount of the error is likely to be fairly
+small. We will try to arrange things so that freak accidents of this type do
+not destroy the inverse relationship between the \&{arclength} and
+\&{arctime} operations.
+@:arclength_}{\&{arclength} primitive@>
+@:arctime_}{\&{arctime} primitive@>
+
+@ The \&{arclength} and \&{arctime} operations are both based on a recursive
+@^recursion@>
+function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
+$dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
+returns the time when the arc length reaches |a_goal| if there is such a time.
+Thus the return value is either an arc length less than |a_goal| or, if the
+arc length would be at least |a_goal|, it returns a time value decreased by
+|two|. This allows the caller to use the sign of the result to distinguish
+between arc lengths and time values. On certain types of overflow, it is
+possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
+Otherwise, the result is always less than |a_goal|.
+
+Rather than halving the control point coordinates on each recursive call to
+|arc_test|, it is better to keep them proportional to velocity on the original
+curve and halve the results instead. This means that recursive calls can
+potentially use larger error tolerances in their arc length estimates. How
+much larger depends on to what extent the errors behave as though they are
+independent of each other. To save computing time, we use optimistic assumptions
+and increase the tolerance by a factor of about $\sqrt2$ for each recursive
+call.
+
+In addition to the tolerance parameter, |arc_test| should also have parameters
+for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
+${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
+and they are needed in different instances of |arc_test|.
+
+@c @<Declare subroutines needed by |arc_test|@>
+scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
+ scaled dx2, scaled dy2, scaled v0, scaled v02,
+ scaled v2, scaled a_goal, scaled tol) {
+ boolean simple; /* are the control points confined to a $90^\circ$ sector? */
+ scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
+ scaled v002, v022;
+ /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
+ scaled arc; /* best arc length estimate before recursion */
+ @<Other local variables in |arc_test|@>;
+ @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
+ |dx2|, |dy2|@>;
+ @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
+ set |arc_test| and |return|@>;
+ @<Test if the control points are confined to one quadrant or rotating them
+ $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
+ if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
+ if ( arc < a_goal ) {
+ return arc;
+ } else {
+ @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
+ that time minus |two|@>;
+ }
+ } else {
+ @<Use one or two recursive calls to compute the |arc_test| function@>;
+ }
+}
+
+@ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
+calls, but $1.5$ is an adequate approximation. It is best to avoid using
+|make_fraction| in this inner loop.
+@^inner loop@>
+
+@<Use one or two recursive calls to compute the |arc_test| function@>=
+{
+ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
+ large as possible@>;
+ tol = tol + halfp(tol);
+ a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
+ halfp(v02), a_new, tol);
+ if ( a<0 ) {
+ return (-halfp(two-a));
+ } else {
+ @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
+ b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
+ halfp(v02), v022, v2, a_new, tol);
+ if ( b<0 )
+ return (-halfp(-b) - half_unit);
+ else
+ return (a + half(b-a));
+ }
+}
+
+@ @<Other local variables in |arc_test|@>=
+scaled a,b; /* results of recursive calls */
+scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
+
+@ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
+a_aux = el_gordo - a_goal;
+if ( a_goal > a_aux ) {
+ a_aux = a_goal - a_aux;
+ a_new = el_gordo;
+} else {
+ a_new = a_goal + a_goal;
+ a_aux = 0;
+}
+
+@ There is no need to maintain |a_aux| at this point so we use it as a temporary
+to force the additions and subtractions to be done in an order that avoids
+overflow.
+
+@<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
+if ( a > a_aux ) {
+ a_aux = a_aux - a;
+ a_new = a_new + a_aux;
+}
+
+@ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
+|fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
+this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
+this bound. Note that recursive calls will maintain this invariant.
+
+@<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
+dx01 = half(dx0 + dx1);
+dx12 = half(dx1 + dx2);
+dx02 = half(dx01 + dx12);
+dy01 = half(dy0 + dy1);
+dy12 = half(dy1 + dy2);
+dy02 = half(dy01 + dy12)
+
+@ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
+|a_goal=el_gordo| is guaranteed to yield the arc length.
+
+@<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
+v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
+v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
+tmp = halfp(v02+2);
+arc1 = v002 + half(halfp(v0+tmp) - v002);
+arc = v022 + half(halfp(v2+tmp) - v022);
+if ( (arc < el_gordo-arc1) ) {
+ arc = arc+arc1;
+} else {
+ mp->arith_error = true;
+ if ( a_goal==el_gordo ) return (el_gordo);
+ else return (-two);
+}
+
+@ @<Other local variables in |arc_test|@>=
+scaled tmp, tmp2; /* all purpose temporary registers */
+scaled arc1; /* arc length estimate for the first half */
+
+@ @<Test if the control points are confined to one quadrant or rotating...@>=
+simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
+ ((dx0<=0) && (dx1<=0) && (dx2<=0));
+if ( simple )
+ simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
+ ((dy0<=0) && (dy1<=0) && (dy2<=0));
+if ( ! simple ) {
+ simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
+ ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
+ if ( simple )
+ simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
+ ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
+}
+
+@ Since Simpson's rule is based on approximating the integrand by a parabola,
+@^Simpson's rule@>
+it is appropriate to use the same approximation to decide when the integral
+reaches the intermediate value |a_goal|. At this point
+$$\eqalign{
+ {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
+ {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
+ {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
+ {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
+ {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
+}
+$$
+and
+$$ {\vb\dot B(t)\vb\over 3} \approx
+ \cases{B\left(\hbox{|v0|},
+ \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
+ {1\over 2}\hbox{|v02|}; 2t \right)&
+ if $t\le{1\over 2}$\cr
+ B\left({1\over 2}\hbox{|v02|},
+ \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
+ \hbox{|v2|}; 2t-1 \right)&
+ if $t\ge{1\over 2}$.\cr}
+ \eqno (*)
+$$
+We can integrate $\vb\dot B(t)\vb$ by using
+$$\int 3B(a,b,c;\tau)\,dt =
+ {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
+$$
+
+This construction allows us to find the time when the arc length reaches
+|a_goal| by solving a cubic equation of the form
+$$ B(0,a,a+b,a+b+c;\tau) = x, $$
+where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
+and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
+@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
+$d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
+$\tau$ given $a$, $b$, $c$, and $x$.
+
+@<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
+{
+ tmp = (v02 + 2) / 4;
+ if ( a_goal<=arc1 ) {
+ tmp2 = halfp(v0);
+ return
+ (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
+ } else {
+ tmp2 = halfp(v2);
+ return ((half_unit - two) +
+ halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
+ }
+}
+
+@ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
+$$ B(0, a, a+b, a+b+c; t) = x. $$
+This routine is based on |crossing_point| but is simplified by the
+assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
+If rounding error causes this condition to be violated slightly, we just ignore
+it and proceed with binary search. This finds a time when the function value
+reaches |x| and the slope is positive.
+
+@<Declare subroutines needed by |arc_test|@>=
+scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
+ scaled ab, bc, ac; /* bisection results */
+ integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
+ integer xx; /* temporary for updating |x| */
+ if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
+@:this can't happen rising?}{\quad rising?@>
+ if ( x<=0 ) {
+ return 0;
+ } else if ( x >= a+b+c ) {
+ return unity;
+ } else {
+ t = 1;
+ @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
+ |el_gordo div 3|@>;
+ do {
+ t+=t;
+ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
+ xx = x - a - ab - ac;
+ if ( xx < -x ) { x+=x; b=ab; c=ac; }
+ else { x = x + xx; a=ac; b=bc; t = t+1; };
+ } while (t < unity);
+ return (t - unity);
+ }
+}
+
+@ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
+ab = half(a+b);
+bc = half(b+c);
+ac = half(ab+bc)
+
+@ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
+
+@<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
+while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
+ a = halfp(a);
+ b = half(b);
+ c = halfp(c);
+ x = halfp(x);
+}
+
+@ It is convenient to have a simpler interface to |arc_test| that requires no
+unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
+length less than |fraction_four|.
+
+@d arc_tol 16 /* quit when change in arc length estimate reaches this */
+
+@c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
+ scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
+ scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
+ scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
+ v0 = mp_pyth_add(mp, dx0,dy0);
+ v1 = mp_pyth_add(mp, dx1,dy1);
+ v2 = mp_pyth_add(mp, dx2,dy2);
+ if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
+ mp->arith_error = true;
+ if ( a_goal==el_gordo ) return el_gordo;
+ else return (-two);
+ } else {
+ v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
+ return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
+ v0, v02, v2, a_goal, arc_tol));
+ }
+}
+
+@ Now it is easy to find the arc length of an entire path.
+
+@c scaled mp_get_arc_length (MP mp,pointer h) {
+ pointer p,q; /* for traversing the path */
+ scaled a,a_tot; /* current and total arc lengths */
+ a_tot = 0;
+ p = h;
+ while ( right_type(p)!=mp_endpoint ){
+ q = link(p);
+ a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
+ left_x(q)-right_x(p), left_y(q)-right_y(p),
+ x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
+ a_tot = mp_slow_add(mp, a, a_tot);
+ if ( q==h ) break; else p=q;
+ }
+ check_arith;
+ return a_tot;
+}
+
+@ The inverse operation of finding the time on a path~|h| when the arc length
+reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
+is required to handle very large times or negative times on cyclic paths. For
+non-cyclic paths, |arc0| values that are negative or too large cause
+|get_arc_time| to return 0 or the length of path~|h|.
+
+If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
+time value greater than the length of the path. Since it could be much greater,
+we must be prepared to compute the arc length of path~|h| and divide this into
+|arc0| to find how many multiples of the length of path~|h| to add.
+
+@c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
+ pointer p,q; /* for traversing the path */
+ scaled t_tot; /* accumulator for the result */
+ scaled t; /* the result of |do_arc_test| */
+ scaled arc; /* portion of |arc0| not used up so far */
+ integer n; /* number of extra times to go around the cycle */
+ if ( arc0<0 ) {
+ @<Deal with a negative |arc0| value and |return|@>;
+ }
+ if ( arc0==el_gordo ) decr(arc0);
+ t_tot = 0;
+ arc = arc0;
+ p = h;
+ while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
+ q = link(p);
+ t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
+ left_x(q)-right_x(p), left_y(q)-right_y(p),
+ x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
+ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
+ if ( q==h ) {
+ @<Update |t_tot| and |arc| to avoid going around the cyclic
+ path too many times but set |arith_error:=true| and |goto done| on
+ overflow@>;
+ }
+ p = q;
+ }
+ check_arith;
+ return t_tot;
+}
+
+@ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
+if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
+else { t_tot = t_tot + unity; arc = arc - t; }
+
+@ @<Deal with a negative |arc0| value and |return|@>=
+{
+ if ( left_type(h)==mp_endpoint ) {
+ t_tot=0;
+ } else {
+ p = mp_htap_ypoc(mp, h);
+ t_tot = -mp_get_arc_time(mp, p, -arc0);
+ mp_toss_knot_list(mp, p);
+ }
+ check_arith;
+ return t_tot;
+}
+
+@ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
+if ( arc>0 ) {
+ n = arc / (arc0 - arc);
+ arc = arc - n*(arc0 - arc);
+ if ( t_tot > (el_gordo / (n+1)) ) {
+ return el_gordo;
+ }
+ t_tot = (n + 1)*t_tot;
+}
+
+@* \[20] Data structures for pens.
+A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
+in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
+@:stroke}{\&{stroke} command@>
+converted into an area fill as described in the next part of this program.
+The mathematics behind this process is based on simple aspects of the theory
+of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
+[``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
+Foundations of Computer Science {\bf 24} (1983), 100--111].
+
+Polygonal pens are created from paths via \MP's \&{makepen} primitive.
+@:makepen_}{\&{makepen} primitive@>
+This path representation is almost sufficient for our purposes except that
+a pen path should always be a convex polygon with the vertices in
+counter-clockwise order.
+Since we will need to scan pen polygons both forward and backward, a pen
+should be represented as a doubly linked ring of knot nodes. There is
+room for the extra back pointer because we do not need the
+|left_type| or |right_type| fields. In fact, we don't need the |left_x|,
+|left_y|, |right_x|, or |right_y| fields either but we leave these alone
+so that certain procedures can operate on both pens and paths. In particular,
+pens can be copied using |copy_path| and recycled using |toss_knot_list|.
+
+@d knil info
+ /* this replaces the |left_type| and |right_type| fields in a pen knot */
+
+@ The |make_pen| procedure turns a path into a pen by initializing
+the |knil| pointers and making sure the knots form a convex polygon.
+Thus each cubic in the given path becomes a straight line and the control
+points are ignored. If the path is not cyclic, the ends are connected by a
+straight line.
+
+@d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
+
+@c @<Declare a function called |convex_hull|@>
+pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
+ pointer p,q; /* two consecutive knots */
+ q=h;
+ do {
+ p=q; q=link(q);
+ knil(q)=p;
+ } while (q!=h);
+ if ( need_hull ){
+ h=mp_convex_hull(mp, h);
+ @<Make sure |h| isn't confused with an elliptical pen@>;
+ }
+ return h;
+}
+
+@ The only information required about an elliptical pen is the overall
+transformation that has been applied to the original \&{pencircle}.
+@:pencircle_}{\&{pencircle} primitive@>
+Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
+and $(0,1)$ are transformed, an elliptical pen can be stored in a single
+knot node and transformed as if it were a path.
+
+@d pen_is_elliptical(A) ((A)==link((A)))
+
+@c pointer mp_get_pen_circle (MP mp,scaled diam) {
+ pointer h; /* the knot node to return */
+ h=mp_get_node(mp, knot_node_size);
+ link(h)=h; knil(h)=h;
+ originator(h)=mp_program_code;
+ x_coord(h)=0; y_coord(h)=0;
+ left_x(h)=diam; left_y(h)=0;
+ right_x(h)=0; right_y(h)=diam;
+ return h;
+}
+
+@ If the polygon being returned by |make_pen| has only one vertex, it will
+be interpreted as an elliptical pen. This is no problem since a degenerate
+polygon can equally well be thought of as a degenerate ellipse. We need only
+initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
+
+@<Make sure |h| isn't confused with an elliptical pen@>=
+if ( pen_is_elliptical( h) ){
+ left_x(h)=x_coord(h); left_y(h)=y_coord(h);
+ right_x(h)=x_coord(h); right_y(h)=y_coord(h);
+}
+
+@ We have to cheat a little here but most operations on pens only use
+the first three words in each knot node.
+@^data structure assumptions@>
+
+@<Initialize a pen at |test_pen| so that it fits in nine words@>=
+x_coord(test_pen)=-half_unit;
+y_coord(test_pen)=0;
+x_coord(test_pen+3)=half_unit;
+y_coord(test_pen+3)=0;
+x_coord(test_pen+6)=0;
+y_coord(test_pen+6)=unity;
+link(test_pen)=test_pen+3;
+link(test_pen+3)=test_pen+6;
+link(test_pen+6)=test_pen;
+knil(test_pen)=test_pen+6;
+knil(test_pen+3)=test_pen;
+knil(test_pen+6)=test_pen+3
+
+@ Printing a polygonal pen is very much like printing a path
+
+@<Declare subroutines for printing expressions@>=
+void mp_pr_pen (MP mp,pointer h) {
+ pointer p,q; /* for list traversal */
+ if ( pen_is_elliptical(h) ) {
+ @<Print the elliptical pen |h|@>;
+ } else {
+ p=h;
+ do {
+ mp_print_two(mp, x_coord(p),y_coord(p));
+ mp_print_nl(mp, " .. ");
+ @<Advance |p| making sure the links are OK and |return| if there is
+ a problem@>;
+ } while (p!=h);
+ mp_print(mp, "cycle");
+ }
+}
+
+@ @<Advance |p| making sure the links are OK and |return| if there is...@>=
+q=link(p);
+if ( (q==null) || (knil(q)!=p) ) {
+ mp_print_nl(mp, "???"); return; /* this won't happen */
+@.???@>
+}
+p=q
+
+@ @<Print the elliptical pen |h|@>=
+{
+mp_print(mp, "pencircle transformed (");
+mp_print_scaled(mp, x_coord(h));
+mp_print_char(mp, ',');
+mp_print_scaled(mp, y_coord(h));
+mp_print_char(mp, ',');
+mp_print_scaled(mp, left_x(h)-x_coord(h));
+mp_print_char(mp, ',');
+mp_print_scaled(mp, right_x(h)-x_coord(h));
+mp_print_char(mp, ',');
+mp_print_scaled(mp, left_y(h)-y_coord(h));
+mp_print_char(mp, ',');
+mp_print_scaled(mp, right_y(h)-y_coord(h));
+mp_print_char(mp, ')');
+}
+
+@ Here us another version of |pr_pen| that prints the pen as a diagnostic
+message.
+
+@<Declare subroutines for printing expressions@>=
+void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
+ mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
+@.Pen at line...@>
+ mp_pr_pen(mp, h);
+ mp_end_diagnostic(mp, true);
+}
+
+@ Making a polygonal pen into a path involves restoring the |left_type| and
+|right_type| fields and setting the control points so as to make a polygonal
+path.
+
+@c
+void mp_make_path (MP mp,pointer h) {
+ pointer p; /* for traversing the knot list */
+ small_number k; /* a loop counter */
+ @<Other local variables in |make_path|@>;
+ if ( pen_is_elliptical(h) ) {
+ @<Make the elliptical pen |h| into a path@>;
+ } else {
+ p=h;
+ do {
+ left_type(p)=mp_explicit;
+ right_type(p)=mp_explicit;
+ @<copy the coordinates of knot |p| into its control points@>;
+ p=link(p);
+ } while (p!=h);
+ }
+}
+
+@ @<copy the coordinates of knot |p| into its control points@>=
+left_x(p)=x_coord(p);
+left_y(p)=y_coord(p);
+right_x(p)=x_coord(p);
+right_y(p)=y_coord(p)
+
+@ We need an eight knot path to get a good approximation to an ellipse.
+
+@<Make the elliptical pen |h| into a path@>=
+{
+ @<Extract the transformation parameters from the elliptical pen~|h|@>;
+ p=h;
+ for (k=0;k<=7;k++ ) {
+ @<Initialize |p| as the |k|th knot of a circle of unit diameter,
+ transforming it appropriately@>;
+ if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
+ p=link(p);
+ }
+}
+
+@ @<Extract the transformation parameters from the elliptical pen~|h|@>=
+center_x=x_coord(h);
+center_y=y_coord(h);
+width_x=left_x(h)-center_x;
+width_y=left_y(h)-center_y;
+height_x=right_x(h)-center_x;
+height_y=right_y(h)-center_y
+
+@ @<Other local variables in |make_path|@>=
+scaled center_x,center_y; /* translation parameters for an elliptical pen */
+scaled width_x,width_y; /* the effect of a unit change in $x$ */
+scaled height_x,height_y; /* the effect of a unit change in $y$ */
+scaled dx,dy; /* the vector from knot |p| to its right control point */
+integer kk;
+ /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
+
+@ The only tricky thing here are the tables |half_cos| and |d_cos| used to
+find the point $k/8$ of the way around the circle and the direction vector
+to use there.
+
+@<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
+kk=(k+6)% 8;
+x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
+ +mp_take_fraction(mp, mp->half_cos[kk],height_x);
+y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
+ +mp_take_fraction(mp, mp->half_cos[kk],height_y);
+dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
+ +mp_take_fraction(mp, mp->d_cos[k],height_x);
+dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
+ +mp_take_fraction(mp, mp->d_cos[k],height_y);
+right_x(p)=x_coord(p)+dx;
+right_y(p)=y_coord(p)+dy;
+left_x(p)=x_coord(p)-dx;
+left_y(p)=y_coord(p)-dy;
+left_type(p)=mp_explicit;
+right_type(p)=mp_explicit;
+originator(p)=mp_program_code
+
+@ @<Glob...@>=
+fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
+fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
+
+@ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
+$({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
+function for $\theta=\phi=22.5^\circ$. This comes out to be
+$$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
+ \approx 0.132608244919772.
+$$
+
+@<Set init...@>=
+mp->half_cos[0]=fraction_half;
+mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
+mp->half_cos[2]=0;
+mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
+mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
+mp->d_cos[2]=0;
+for (k=3;k<= 4;k++ ) {
+ mp->half_cos[k]=-mp->half_cos[4-k];
+ mp->d_cos[k]=-mp->d_cos[4-k];
+}
+for (k=5;k<= 7;k++ ) {
+ mp->half_cos[k]=mp->half_cos[8-k];
+ mp->d_cos[k]=mp->d_cos[8-k];
+}
+
+@ The |convex_hull| function forces a pen polygon to be convex when it is
+returned by |make_pen| and after any subsequent transformation where rounding
+error might allow the convexity to be lost.
+The convex hull algorithm used here is described by F.~P. Preparata and
+M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
+
+@<Declare a function called |convex_hull|@>=
+@<Declare a procedure called |move_knot|@>
+pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
+ pointer l,r; /* the leftmost and rightmost knots */
+ pointer p,q; /* knots being scanned */
+ pointer s; /* the starting point for an upcoming scan */
+ scaled dx,dy; /* a temporary pointer */
+ if ( pen_is_elliptical(h) ) {
+ return h;
+ } else {
+ @<Set |l| to the leftmost knot in polygon~|h|@>;
+ @<Set |r| to the rightmost knot in polygon~|h|@>;
+ if ( l!=r ) {
+ s=link(r);
+ @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
+ move them past~|r|@>;
+ @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
+ move them past~|l|@>;
+ @<Sort the path from |l| to |r| by increasing $x$@>;
+ @<Sort the path from |r| to |l| by decreasing $x$@>;
+ }
+ if ( l!=link(l) ) {
+ @<Do a Gramm scan and remove vertices where there is no left turn@>;
+ }
+ return l;
+ }
+}
+
+@ All comparisons are done primarily on $x$ and secondarily on $y$.
+
+@<Set |l| to the leftmost knot in polygon~|h|@>=
+l=h;
+p=link(h);
+while ( p!=h ) {
+ if ( x_coord(p)<=x_coord(l) )
+ if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
+ l=p;
+ p=link(p);
+}
+
+@ @<Set |r| to the rightmost knot in polygon~|h|@>=
+r=h;
+p=link(h);
+while ( p!=h ) {
+ if ( x_coord(p)>=x_coord(r) )
+ if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
+ r=p;
+ p=link(p);
+}
+
+@ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
+dx=x_coord(r)-x_coord(l);
+dy=y_coord(r)-y_coord(l);
+p=link(l);
+while ( p!=r ) {
+ q=link(p);
+ if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
+ mp_move_knot(mp, p, r);
+ p=q;
+}
+
+@ The |move_knot| procedure removes |p| from a doubly linked list and inserts
+it after |q|.
+
+@ @<Declare a procedure called |move_knot|@>=
+void mp_move_knot (MP mp,pointer p, pointer q) {
+ link(knil(p))=link(p);
+ knil(link(p))=knil(p);
+ knil(p)=q;
+ link(p)=link(q);
+ link(q)=p;
+ knil(link(p))=p;
+}
+
+@ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
+p=s;
+while ( p!=l ) {
+ q=link(p);
+ if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
+ mp_move_knot(mp, p,l);
+ p=q;
+}
+
+@ The list is likely to be in order already so we just do linear insertions.
+Secondary comparisons on $y$ ensure that the sort is consistent with the
+choice of |l| and |r|.
+
+@<Sort the path from |l| to |r| by increasing $x$@>=
+p=link(l);
+while ( p!=r ) {
+ q=knil(p);
+ while ( x_coord(q)>x_coord(p) ) q=knil(q);
+ while ( x_coord(q)==x_coord(p) ) {
+ if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
+ }
+ if ( q==knil(p) ) p=link(p);
+ else { p=link(p); mp_move_knot(mp, knil(p),q); };
+}
+
+@ @<Sort the path from |r| to |l| by decreasing $x$@>=
+p=link(r);
+while ( p!=l ){
+ q=knil(p);
+ while ( x_coord(q)<x_coord(p) ) q=knil(q);
+ while ( x_coord(q)==x_coord(p) ) {
+ if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
+ }
+ if ( q==knil(p) ) p=link(p);
+ else { p=link(p); mp_move_knot(mp, knil(p),q); };
+}
+
+@ The condition involving |ab_vs_cd| tests if there is not a left turn
+at knot |q|. There usually will be a left turn so we streamline the case
+where the |then| clause is not executed.
+
+@<Do a Gramm scan and remove vertices where there...@>=
+{
+p=l; q=link(l);
+while (1) {
+ dx=x_coord(q)-x_coord(p);
+ dy=y_coord(q)-y_coord(p);
+ p=q; q=link(q);
+ if ( p==l ) break;
+ if ( p!=r )
+ if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
+ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
+ }
+ }
+}
+
+@ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
+{
+s=knil(p);
+mp_free_node(mp, p,knot_node_size);
+link(s)=q; knil(q)=s;
+if ( s==l ) p=s;
+else { p=knil(s); q=s; };
+}
+
+@ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
+offset associated with the given direction |(x,y)|. If two different offsets
+apply, it chooses one of them.
+
+@c
+void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
+ pointer p,q; /* consecutive knots */
+ scaled wx,wy,hx,hy;
+ /* the transformation matrix for an elliptical pen */
+ fraction xx,yy; /* untransformed offset for an elliptical pen */
+ fraction d; /* a temporary register */
+ if ( pen_is_elliptical(h) ) {
+ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
+ } else {
+ q=h;
+ do {
+ p=q; q=link(q);
+ } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
+ do {
+ p=q; q=link(q);
+ } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
+ mp->cur_x=x_coord(p);
+ mp->cur_y=y_coord(p);
+ }
+}
+
+@ @<Glob...@>=
+scaled cur_x;
+scaled cur_y; /* all-purpose return value registers */
+
+@ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
+if ( (x==0) && (y==0) ) {
+ mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
+} else {
+ @<Find the non-constant part of the transformation for |h|@>;
+ while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
+ x+=x; y+=y;
+ };
+ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
+ untransformed version of |(x,y)|@>;
+ mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
+ mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
+}
+
+@ @<Find the non-constant part of the transformation for |h|@>=
+wx=left_x(h)-x_coord(h);
+wy=left_y(h)-y_coord(h);
+hx=right_x(h)-x_coord(h);
+hy=right_y(h)-y_coord(h)
+
+@ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
+yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
+xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
+d=mp_pyth_add(mp, xx,yy);
+if ( d>0 ) {
+ xx=half(mp_make_fraction(mp, xx,d));
+ yy=half(mp_make_fraction(mp, yy,d));
+}
+
+@ Finding the bounding box of a pen is easy except if the pen is elliptical.
+But we can handle that case by just calling |find_offset| twice. The answer
+is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
+
+@c
+void mp_pen_bbox (MP mp,pointer h) {
+ pointer p; /* for scanning the knot list */
+ if ( pen_is_elliptical(h) ) {
+ @<Find the bounding box of an elliptical pen@>;
+ } else {
+ minx=x_coord(h); maxx=minx;
+ miny=y_coord(h); maxy=miny;
+ p=link(h);
+ while ( p!=h ) {
+ if ( x_coord(p)<minx ) minx=x_coord(p);
+ if ( y_coord(p)<miny ) miny=y_coord(p);
+ if ( x_coord(p)>maxx ) maxx=x_coord(p);
+ if ( y_coord(p)>maxy ) maxy=y_coord(p);
+ p=link(p);
+ }
+ }
+}
+
+@ @<Find the bounding box of an elliptical pen@>=
+{
+mp_find_offset(mp, 0,fraction_one,h);
+maxx=mp->cur_x;
+minx=2*x_coord(h)-mp->cur_x;
+mp_find_offset(mp, -fraction_one,0,h);
+maxy=mp->cur_y;
+miny=2*y_coord(h)-mp->cur_y;
+}
+
+@* \[21] Edge structures.
+Now we come to \MP's internal scheme for representing pictures.
+The representation is very different from \MF's edge structures
+because \MP\ pictures contain \ps\ graphics objects instead of pixel
+images. However, the basic idea is somewhat similar in that shapes
+are represented via their boundaries.
+
+The main purpose of edge structures is to keep track of graphical objects
+until it is time to translate them into \ps. Since \MP\ does not need to
+know anything about an edge structure other than how to translate it into
+\ps\ and how to find its bounding box, edge structures can be just linked
+lists of graphical objects. \MP\ has no easy way to determine whether
+two such objects overlap, but it suffices to draw the first one first and
+let the second one overwrite it if necessary.
+
+@<Types...@>=
+enum mp_graphical_object_code {
+ @<Graphical object codes@>
+ mp_final_graphic
+};
+
+@ Let's consider the types of graphical objects one at a time.
+First of all, a filled contour is represented by a eight-word node. The first
+word contains |type| and |link| fields, and the next six words contain a
+pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
+parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
+give the relevant information.
+
+@d path_p(A) link((A)+1)
+ /* a pointer to the path that needs filling */
+@d pen_p(A) info((A)+1)
+ /* a pointer to the pen to fill or stroke with */
+@d color_model(A) type((A)+2) /* the color model */
+@d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
+@d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
+@d obj_grey_loc obj_red_loc /* the location for the color */
+@d red_val(A) mp->mem[(A)+3].sc
+ /* the red component of the color in the range $0\ldots1$ */
+@d cyan_val red_val
+@d grey_val red_val
+@d green_val(A) mp->mem[(A)+4].sc
+ /* the green component of the color in the range $0\ldots1$ */
+@d magenta_val green_val
+@d blue_val(A) mp->mem[(A)+5].sc
+ /* the blue component of the color in the range $0\ldots1$ */
+@d yellow_val blue_val
+@d black_val(A) mp->mem[(A)+6].sc
+ /* the blue component of the color in the range $0\ldots1$ */
+@d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
+@:mp_linejoin_}{\&{linejoin} primitive@>
+@d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
+@:mp_miterlimit_}{\&{miterlimit} primitive@>
+@d obj_color_part(A) mp->mem[(A)+3-red_part].sc
+ /* interpret an object pointer that has been offset by |red_part..blue_part| */
+@d pre_script(A) mp->mem[(A)+8].hh.lh
+@d post_script(A) mp->mem[(A)+8].hh.rh
+@d fill_node_size 9
+
+@ @<Graphical object codes@>=
+mp_fill_code=1,
+
+@ @c
+pointer mp_new_fill_node (MP mp,pointer p) {
+ /* make a fill node for cyclic path |p| and color black */
+ pointer t; /* the new node */
+ t=mp_get_node(mp, fill_node_size);
+ type(t)=mp_fill_code;
+ path_p(t)=p;
+ pen_p(t)=null; /* |null| means don't use a pen */
+ red_val(t)=0;
+ green_val(t)=0;
+ blue_val(t)=0;
+ black_val(t)=0;
+ color_model(t)=mp_uninitialized_model;
+ pre_script(t)=null;
+ post_script(t)=null;
+ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
+ return t;
+}
+
+@ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
+if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
+else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
+else ljoin_val(t)=0;
+if ( mp->internal[mp_miterlimit]<unity )
+ miterlim_val(t)=unity;
+else
+ miterlim_val(t)=mp->internal[mp_miterlimit]
+
+@ A stroked path is represented by an eight-word node that is like a filled
+contour node except that it contains the current \&{linecap} value, a scale
+factor for the dash pattern, and a pointer that is non-null if the stroke
+is to be dashed. The purpose of the scale factor is to allow a picture to
+be transformed without touching the picture that |dash_p| points to.
+
+@d dash_p(A) link((A)+9)
+ /* a pointer to the edge structure that gives the dash pattern */
+@d lcap_val(A) type((A)+9)
+ /* the value of \&{linecap} */
+@:mp_linecap_}{\&{linecap} primitive@>
+@d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
+@d stroked_node_size 11
+
+@ @<Graphical object codes@>=
+mp_stroked_code=2,
+
+@ @c
+pointer mp_new_stroked_node (MP mp,pointer p) {
+ /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
+ pointer t; /* the new node */
+ t=mp_get_node(mp, stroked_node_size);
+ type(t)=mp_stroked_code;
+ path_p(t)=p; pen_p(t)=null;
+ dash_p(t)=null;
+ dash_scale(t)=unity;
+ red_val(t)=0;
+ green_val(t)=0;
+ blue_val(t)=0;
+ black_val(t)=0;
+ color_model(t)=mp_uninitialized_model;
+ pre_script(t)=null;
+ post_script(t)=null;
+ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
+ if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
+ else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
+ else lcap_val(t)=0;
+ return t;
+}
+
+@ When a dashed line is computed in a transformed coordinate system, the dash
+lengths get scaled like the pen shape and we need to compensate for this. Since
+there is no unique scale factor for an arbitrary transformation, we use the
+the square root of the determinant. The properties of the determinant make it
+easier to maintain the |dash_scale|. The computation is fairly straight-forward
+except for the initialization of the scale factor |s|. The factor of 64 is
+needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
+to counteract the effect of |take_fraction|.
+
+@<Declare subroutines needed by |print_edges|@>=
+scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
+ scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
+ integer s; /* amount by which the result of |square_rt| needs to be scaled */
+ @<Initialize |maxabs|@>;
+ s=64;
+ while ( (maxabs<fraction_one) && (s>1) ){
+ a+=a; b+=b; c+=c; d+=d;
+ maxabs+=maxabs; s=halfp(s);
+ }
+ return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
+}
+@#
+scaled mp_get_pen_scale (MP mp,pointer p) {
+ return mp_sqrt_det(mp,
+ left_x(p)-x_coord(p), right_x(p)-x_coord(p),
+ left_y(p)-y_coord(p), right_y(p)-y_coord(p));
+}
+
+@ @<Internal library ...@>=
+scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
+
+
+@ @<Initialize |maxabs|@>=
+maxabs=abs(a);
+if ( abs(b)>maxabs ) maxabs=abs(b);
+if ( abs(c)>maxabs ) maxabs=abs(c);
+if ( abs(d)>maxabs ) maxabs=abs(d)
+
+@ When a picture contains text, this is represented by a fourteen-word node
+where the color information and |type| and |link| fields are augmented by
+additional fields that describe the text and how it is transformed.
+The |path_p| and |pen_p| pointers are replaced by a number that identifies
+the font and a string number that gives the text to be displayed.
+The |width|, |height|, and |depth| fields
+give the dimensions of the text at its design size, and the remaining six
+words give a transformation to be applied to the text. The |new_text_node|
+function initializes everything to default values so that the text comes out
+black with its reference point at the origin.
+
+@d text_p(A) link((A)+1) /* a string pointer for the text to display */
+@d font_n(A) info((A)+1) /* the font number */
+@d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
+@d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
+@d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
+@d text_tx_loc(A) ((A)+11)
+ /* the first of six locations for transformation parameters */
+@d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
+@d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
+@d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
+@d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
+@d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
+@d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
+@d text_trans_part(A) mp->mem[(A)+11-x_part].sc
+ /* interpret a text node pointer that has been offset by |x_part..yy_part| */
+@d text_node_size 17
+
+@ @<Graphical object codes@>=
+mp_text_code=3,
+
+@ @c @<Declare text measuring subroutines@>
+pointer mp_new_text_node (MP mp,char *f,str_number s) {
+ /* make a text node for font |f| and text string |s| */
+ pointer t; /* the new node */
+ t=mp_get_node(mp, text_node_size);
+ type(t)=mp_text_code;
+ text_p(t)=s;
+ font_n(t)=mp_find_font(mp, f); /* this identifies the font */
+ red_val(t)=0;
+ green_val(t)=0;
+ blue_val(t)=0;
+ black_val(t)=0;
+ color_model(t)=mp_uninitialized_model;
+ pre_script(t)=null;
+ post_script(t)=null;
+ tx_val(t)=0; ty_val(t)=0;
+ txx_val(t)=unity; txy_val(t)=0;
+ tyx_val(t)=0; tyy_val(t)=unity;
+ mp_set_text_box(mp, t); /* this finds the bounding box */
+ return t;
+}
+
+@ The last two types of graphical objects that can occur in an edge structure
+are clipping paths and \&{setbounds} paths. These are slightly more difficult
+@:set_bounds_}{\&{setbounds} primitive@>
+to implement because we must keep track of exactly what is being clipped or
+bounded when pictures get merged together. For this reason, each clipping or
+\&{setbounds} operation is represented by a pair of nodes: first comes a
+two-word node whose |path_p| gives the relevant path, then there is the list
+of objects to clip or bound followed by a two-word node whose second word is
+unused.
+
+Using at least two words for each graphical object node allows them all to be
+allocated and deallocated similarly with a global array |gr_object_size| to
+give the size in words for each object type.
+
+@d start_clip_size 2
+@d start_bounds_size 2
+@d stop_clip_size 2 /* the second word is not used here */
+@d stop_bounds_size 2 /* the second word is not used here */
+@#
+@d stop_type(A) ((A)+2)
+ /* matching |type| for |start_clip_code| or |start_bounds_code| */
+@d has_color(A) (type((A))<mp_start_clip_code)
+ /* does a graphical object have color fields? */
+@d has_pen(A) (type((A))<mp_text_code)
+ /* does a graphical object have a |pen_p| field? */
+@d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
+@d is_stop(A) (type((A))>=mp_stop_clip_code)
+
+@ @<Graphical object codes@>=
+mp_start_clip_code=4, /* |type| of a node that starts clipping */
+mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
+mp_stop_clip_code=6, /* |type| of a node that stops clipping */
+mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
+
+@ @c
+pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
+ /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
+ pointer t; /* the new node */
+ t=mp_get_node(mp, mp->gr_object_size[c]);
+ type(t)=c;
+ path_p(t)=p;
+ return t;
+}
+
+@ We need an array to keep track of the sizes of graphical objects.
+
+@<Glob...@>=
+small_number gr_object_size[mp_stop_bounds_code+1];
+
+@ @<Set init...@>=
+mp->gr_object_size[mp_fill_code]=fill_node_size;
+mp->gr_object_size[mp_stroked_code]=stroked_node_size;
+mp->gr_object_size[mp_text_code]=text_node_size;
+mp->gr_object_size[mp_start_clip_code]=start_clip_size;
+mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
+mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
+mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
+
+@ All the essential information in an edge structure is encoded as a linked list
+of graphical objects as we have just seen, but it is helpful to add some
+redundant information. A single edge structure might be used as a dash pattern
+many times, and it would be nice to avoid scanning the same structure
+repeatedly. Thus, an edge structure known to be a suitable dash pattern
+has a header that gives a list of dashes in a sorted order designed for rapid
+translation into \ps.
+
+Each dash is represented by a three-word node containing the initial and final
+$x$~coordinates as well as the usual |link| field. The |link| fields points to
+the dash node with the next higher $x$-coordinates and the final link points
+to a special location called |null_dash|. (There should be no overlap between
+dashes). Since the $y$~coordinate of the dash pattern is needed to determine
+the period of repetition, this needs to be stored in the edge header along
+with a pointer to the list of dash nodes.
+
+@d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
+@d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
+@d dash_node_size 3
+@d dash_list link
+ /* in an edge header this points to the first dash node */
+@d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
+
+@ It is also convenient for an edge header to contain the bounding
+box information needed by the \&{llcorner} and \&{urcorner} operators
+so that this does not have to be recomputed unnecessarily. This is done by
+adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
+how far the bounding box computation has gotten. Thus if the user asks for
+the bounding box and then adds some more text to the picture before asking
+for more bounding box information, the second computation need only look at
+the additional text.
+
+When the bounding box has not been computed, the |bblast| pointer points
+to a dummy link at the head of the graphical object list while the |minx_val|
+and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
+fields contain |-el_gordo|.
+
+Since the bounding box of pictures containing objects of type
+|mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
+@:mp_true_corners_}{\&{truecorners} primitive@>
+data might not be valid for all values of this parameter. Hence, the |bbtype|
+field is needed to keep track of this.
+
+@d minx_val(A) mp->mem[(A)+2].sc
+@d miny_val(A) mp->mem[(A)+3].sc
+@d maxx_val(A) mp->mem[(A)+4].sc
+@d maxy_val(A) mp->mem[(A)+5].sc
+@d bblast(A) link((A)+6) /* last item considered in bounding box computation */
+@d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
+@d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
+@d no_bounds 0
+ /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
+@d bounds_set 1
+ /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
+@d bounds_unset 2
+ /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
+
+@c
+void mp_init_bbox (MP mp,pointer h) {
+ /* Initialize the bounding box information in edge structure |h| */
+ bblast(h)=dummy_loc(h);
+ bbtype(h)=no_bounds;
+ minx_val(h)=el_gordo;
+ miny_val(h)=el_gordo;
+ maxx_val(h)=-el_gordo;
+ maxy_val(h)=-el_gordo;
+}
+
+@ The only other entries in an edge header are a reference count in the first
+word and a pointer to the tail of the object list in the last word.
+
+@d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
+@d edge_header_size 8
+
+@c
+void mp_init_edges (MP mp,pointer h) {
+ /* initialize an edge header to null values */
+ dash_list(h)=null_dash;
+ obj_tail(h)=dummy_loc(h);
+ link(dummy_loc(h))=null;
+ ref_count(h)=null;
+ mp_init_bbox(mp, h);
+}
+
+@ Here is how edge structures are deleted. The process can be recursive because
+of the need to dereference edge structures that are used as dash patterns.
+@^recursion@>
+
+@d add_edge_ref(A) incr(ref_count(A))
+@d delete_edge_ref(A) {
+ if ( ref_count((A))==null )
+ mp_toss_edges(mp, A);
+ else
+ decr(ref_count(A));
+ }
+
+@<Declare the recycling subroutines@>=
+void mp_flush_dash_list (MP mp,pointer h);
+pointer mp_toss_gr_object (MP mp,pointer p) ;
+void mp_toss_edges (MP mp,pointer h) ;
+
+@ @c void mp_toss_edges (MP mp,pointer h) {
+ pointer p,q; /* pointers that scan the list being recycled */
+ pointer r; /* an edge structure that object |p| refers to */
+ mp_flush_dash_list(mp, h);
+ q=link(dummy_loc(h));
+ while ( (q!=null) ) {
+ p=q; q=link(q);
+ r=mp_toss_gr_object(mp, p);
+ if ( r!=null ) delete_edge_ref(r);
+ }
+ mp_free_node(mp, h,edge_header_size);
+}
+void mp_flush_dash_list (MP mp,pointer h) {
+ pointer p,q; /* pointers that scan the list being recycled */
+ q=dash_list(h);
+ while ( q!=null_dash ) {
+ p=q; q=link(q);
+ mp_free_node(mp, p,dash_node_size);
+ }
+ dash_list(h)=null_dash;
+}
+pointer mp_toss_gr_object (MP mp,pointer p) {
+ /* returns an edge structure that needs to be dereferenced */
+ pointer e; /* the edge structure to return */
+ e=null;
+ @<Prepare to recycle graphical object |p|@>;
+ mp_free_node(mp, p,mp->gr_object_size[type(p)]);
+ return e;
+}
+
+@ @<Prepare to recycle graphical object |p|@>=
+switch (type(p)) {
+case mp_fill_code:
+ mp_toss_knot_list(mp, path_p(p));
+ if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
+ if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
+ if ( post_script(p)!=null ) delete_str_ref(post_script(p));
+ break;
+case mp_stroked_code:
+ mp_toss_knot_list(mp, path_p(p));
+ if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
+ if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
+ if ( post_script(p)!=null ) delete_str_ref(post_script(p));
+ e=dash_p(p);
+ break;
+case mp_text_code:
+ delete_str_ref(text_p(p));
+ if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
+ if ( post_script(p)!=null ) delete_str_ref(post_script(p));
+ break;
+case mp_start_clip_code:
+case mp_start_bounds_code:
+ mp_toss_knot_list(mp, path_p(p));
+ break;
+case mp_stop_clip_code:
+case mp_stop_bounds_code:
+ break;
+} /* there are no other cases */
+
+@ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
+to be done before making a significant change to an edge structure. Much of
+the work is done in a separate routine |copy_objects| that copies a list of
+graphical objects into a new edge header.
+
+@c @<Declare a function called |copy_objects|@>
+pointer mp_private_edges (MP mp,pointer h) {
+ /* make a private copy of the edge structure headed by |h| */
+ pointer hh; /* the edge header for the new copy */
+ pointer p,pp; /* pointers for copying the dash list */
+ if ( ref_count(h)==null ) {
+ return h;
+ } else {
+ decr(ref_count(h));
+ hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
+ @<Copy the dash list from |h| to |hh|@>;
+ @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
+ point into the new object list@>;
+ return hh;
+ }
+}
+
+@ Here we use the fact that |dash_list(hh)=link(hh)|.
+@^data structure assumptions@>
+
+@<Copy the dash list from |h| to |hh|@>=
+pp=hh; p=dash_list(h);
+while ( (p!=null_dash) ) {
+ link(pp)=mp_get_node(mp, dash_node_size);
+ pp=link(pp);
+ start_x(pp)=start_x(p);
+ stop_x(pp)=stop_x(p);
+ p=link(p);
+}
+link(pp)=null_dash;
+dash_y(hh)=dash_y(h)
+
+
+@ |h| is an edge structure
+
+@c
+mp_dash_object *mp_export_dashes (MP mp, pointer h) {
+ mp_dash_object *d;
+ pointer p;
+ scaled *dashes = NULL;
+ int num_dashes = 1;
+ if (h==null || dash_list(h)==null_dash)
+ return NULL;
+ p = dash_list(h);
+ d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
+ start_x(null_dash)=start_x(p)+dash_y(h);
+ while (p != null_dash) {
+ dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
+ dashes[(num_dashes-1)] = (stop_x(p)-start_x(p));
+ dashes[(num_dashes)] = (start_x(link(p))-stop_x(p));
+ dashes[(num_dashes+1)] = -1; /* terminus */
+ num_dashes+=2;
+ p=link(p);
+ }
+ d->array_field = dashes;
+ d->offset_field = mp_dash_offset(mp, h);
+ d->scale_field = dash_scale(h);
+ return d;
+}
+
+
+
+@ @<Copy the bounding box information from |h| to |hh|...@>=
+minx_val(hh)=minx_val(h);
+miny_val(hh)=miny_val(h);
+maxx_val(hh)=maxx_val(h);
+maxy_val(hh)=maxy_val(h);
+bbtype(hh)=bbtype(h);
+p=dummy_loc(h); pp=dummy_loc(hh);
+while ((p!=bblast(h)) ) {
+ if ( p==null ) mp_confusion(mp, "bblast");
+@:this can't happen bblast}{\quad bblast@>
+ p=link(p); pp=link(pp);
+}
+bblast(hh)=pp
+
+@ Here is the promised routine for copying graphical objects into a new edge
+structure. It starts copying at object~|p| and stops just before object~|q|.
+If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
+structure requires further initialization by |init_bbox|.
+
+@<Declare a function called |copy_objects|@>=
+pointer mp_copy_objects (MP mp, pointer p, pointer q) {
+ pointer hh; /* the new edge header */
+ pointer pp; /* the last newly copied object */
+ small_number k; /* temporary register */
+ hh=mp_get_node(mp, edge_header_size);
+ dash_list(hh)=null_dash;
+ ref_count(hh)=null;
+ pp=dummy_loc(hh);
+ while ( (p!=q) ) {
+ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
+ }
+ obj_tail(hh)=pp;
+ link(pp)=null;
+ return hh;
+}
+
+@ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
+{ k=mp->gr_object_size[type(p)];
+ link(pp)=mp_get_node(mp, k);
+ pp=link(pp);
+ while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
+ @<Fix anything in graphical object |pp| that should differ from the
+ corresponding field in |p|@>;
+ p=link(p);
+}
+
+@ @<Fix anything in graphical object |pp| that should differ from the...@>=
+if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
+if ( post_script(p)!=null ) add_str_ref(post_script(p));
+switch (type(p)) {
+case mp_start_clip_code:
+case mp_start_bounds_code:
+ path_p(pp)=mp_copy_path(mp, path_p(p));
+ break;
+case mp_fill_code:
+ path_p(pp)=mp_copy_path(mp, path_p(p));
+ if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
+ break;
+case mp_stroked_code:
+ path_p(pp)=mp_copy_path(mp, path_p(p));
+ pen_p(pp)=copy_pen(pen_p(p));
+ if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
+ break;
+case mp_text_code:
+ add_str_ref(text_p(pp));
+ break;
+case mp_stop_clip_code:
+case mp_stop_bounds_code:
+ break;
+} /* there are no other cases */
+
+@ Here is one way to find an acceptable value for the second argument to
+|copy_objects|. Given a non-null graphical object list, |skip_1component|
+skips past one picture component, where a ``picture component'' is a single
+graphical object, or a start bounds or start clip object and everything up
+through the matching stop bounds or stop clip object. The macro version avoids
+procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
+unless |p| points to a stop bounds or stop clip node, in which case it executes
+|e| instead.
+
+@d skip_component(A)
+ if ( ! is_start_or_stop((A)) ) (A)=link((A));
+ else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
+ else
+
+@c
+pointer mp_skip_1component (MP mp,pointer p) {
+ integer lev; /* current nesting level */
+ lev=0;
+ do {
+ if ( is_start_or_stop(p) ) {
+ if ( is_stop(p) ) decr(lev); else incr(lev);
+ }
+ p=link(p);
+ } while (lev!=0);
+ return p;
+}
+
+@ Here is a diagnostic routine for printing an edge structure in symbolic form.
+
+@<Declare subroutines for printing expressions@>=
+@<Declare subroutines needed by |print_edges|@>
+void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
+ pointer p; /* a graphical object to be printed */
+ pointer hh,pp; /* temporary pointers */
+ scaled scf; /* a scale factor for the dash pattern */
+ boolean ok_to_dash; /* |false| for polygonal pen strokes */
+ mp_print_diagnostic(mp, "Edge structure",s,nuline);
+ p=dummy_loc(h);
+ while ( link(p)!=null ) {
+ p=link(p);
+ mp_print_ln(mp);
+ switch (type(p)) {
+ @<Cases for printing graphical object node |p|@>;
+ default:
+ mp_print(mp, "[unknown object type!]");
+ break;
+ }
+ }
+ mp_print_nl(mp, "End edges");
+ if ( p!=obj_tail(h) ) mp_print(mp, "?");
+@.End edges?@>
+ mp_end_diagnostic(mp, true);
+}
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_fill_code:
+ mp_print(mp, "Filled contour ");
+ mp_print_obj_color(mp, p);
+ mp_print_char(mp, ':'); mp_print_ln(mp);
+ mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
+ if ( (pen_p(p)!=null) ) {
+ @<Print join type for graphical object |p|@>;
+ mp_print(mp, " with pen"); mp_print_ln(mp);
+ mp_pr_pen(mp, pen_p(p));
+ }
+ break;
+
+@ @<Print join type for graphical object |p|@>=
+switch (ljoin_val(p)) {
+case 0:
+ mp_print(mp, "mitered joins limited ");
+ mp_print_scaled(mp, miterlim_val(p));
+ break;
+case 1:
+ mp_print(mp, "round joins");
+ break;
+case 2:
+ mp_print(mp, "beveled joins");
+ break;
+default:
+ mp_print(mp, "?? joins");
+@.??@>
+ break;
+}
+
+@ For stroked nodes, we need to print |lcap_val(p)| as well.
+
+@<Print join and cap types for stroked node |p|@>=
+switch (lcap_val(p)) {
+case 0:mp_print(mp, "butt"); break;
+case 1:mp_print(mp, "round"); break;
+case 2:mp_print(mp, "square"); break;
+default: mp_print(mp, "??"); break;
+@.??@>
+}
+mp_print(mp, " ends, ");
+@<Print join type for graphical object |p|@>
+
+@ Here is a routine that prints the color of a graphical object if it isn't
+black (the default color).
+
+@<Declare subroutines needed by |print_edges|@>=
+@<Declare a procedure called |print_compact_node|@>
+void mp_print_obj_color (MP mp,pointer p) {
+ if ( color_model(p)==mp_grey_model ) {
+ if ( grey_val(p)>0 ) {
+ mp_print(mp, "greyed ");
+ mp_print_compact_node(mp, obj_grey_loc(p),1);
+ };
+ } else if ( color_model(p)==mp_cmyk_model ) {
+ if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
+ (yellow_val(p)>0) || (black_val(p)>0) ) {
+ mp_print(mp, "processcolored ");
+ mp_print_compact_node(mp, obj_cyan_loc(p),4);
+ };
+ } else if ( color_model(p)==mp_rgb_model ) {
+ if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
+ mp_print(mp, "colored ");
+ mp_print_compact_node(mp, obj_red_loc(p),3);
+ };
+ }
+}
+
+@ We also need a procedure for printing consecutive scaled values as if they
+were a known big node.
+
+@<Declare a procedure called |print_compact_node|@>=
+void mp_print_compact_node (MP mp,pointer p, small_number k) {
+ pointer q; /* last location to print */
+ q=p+k-1;
+ mp_print_char(mp, '(');
+ while ( p<=q ){
+ mp_print_scaled(mp, mp->mem[p].sc);
+ if ( p<q ) mp_print_char(mp, ',');
+ incr(p);
+ }
+ mp_print_char(mp, ')');
+}
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_stroked_code:
+ mp_print(mp, "Filled pen stroke ");
+ mp_print_obj_color(mp, p);
+ mp_print_char(mp, ':'); mp_print_ln(mp);
+ mp_pr_path(mp, path_p(p));
+ if ( dash_p(p)!=null ) {
+ mp_print_nl(mp, "dashed (");
+ @<Finish printing the dash pattern that |p| refers to@>;
+ }
+ mp_print_ln(mp);
+ @<Print join and cap types for stroked node |p|@>;
+ mp_print(mp, " with pen"); mp_print_ln(mp);
+ if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
+@.???@>
+ else mp_pr_pen(mp, pen_p(p));
+ break;
+
+@ Normally, the |dash_list| field in an edge header is set to |null_dash|
+when it is not known to define a suitable dash pattern. This is disallowed
+here because the |dash_p| field should never point to such an edge header.
+Note that memory is allocated for |start_x(null_dash)| and we are free to
+give it any convenient value.
+
+@<Finish printing the dash pattern that |p| refers to@>=
+ok_to_dash=pen_is_elliptical(pen_p(p));
+if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
+hh=dash_p(p);
+pp=dash_list(hh);
+if ( (pp==null_dash) || (dash_y(hh)<0) ) {
+ mp_print(mp, " ??");
+} else { start_x(null_dash)=start_x(pp)+dash_y(hh);
+ while ( pp!=null_dash ) {
+ mp_print(mp, "on ");
+ mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
+ mp_print(mp, " off ");
+ mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
+ pp = link(pp);
+ if ( pp!=null_dash ) mp_print_char(mp, ' ');
+ }
+ mp_print(mp, ") shifted ");
+ mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
+ if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
+}
+
+@ @<Declare subroutines needed by |print_edges|@>=
+scaled mp_dash_offset (MP mp,pointer h) {
+ scaled x; /* the answer */
+ if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
+@:this can't happen dash0}{\quad dash0@>
+ if ( dash_y(h)==0 ) {
+ x=0;
+ } else {
+ x=-(start_x(dash_list(h)) % dash_y(h));
+ if ( x<0 ) x=x+dash_y(h);
+ }
+ return x;
+}
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_text_code:
+ mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
+ mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
+ mp_print_char(mp, '"'); mp_print_ln(mp);
+ mp_print_obj_color(mp, p);
+ mp_print(mp, "transformed ");
+ mp_print_compact_node(mp, text_tx_loc(p),6);
+ break;
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_start_clip_code:
+ mp_print(mp, "clipping path:");
+ mp_print_ln(mp);
+ mp_pr_path(mp, path_p(p));
+ break;
+case mp_stop_clip_code:
+ mp_print(mp, "stop clipping");
+ break;
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_start_bounds_code:
+ mp_print(mp, "setbounds path:");
+ mp_print_ln(mp);
+ mp_pr_path(mp, path_p(p));
+ break;
+case mp_stop_bounds_code:
+ mp_print(mp, "end of setbounds");
+ break;
+
+@ To initialize the |dash_list| field in an edge header~|h|, we need a
+subroutine that scans an edge structure and tries to interpret it as a dash
+pattern. This can only be done when there are no filled regions or clipping
+paths and all the pen strokes have the same color. The first step is to let
+$y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
+project all the pen stroke paths onto the line $y=y_0$ and require that there
+be no retracing. If the resulting paths cover a range of $x$~coordinates of
+length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
+finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
+
+@c @<Declare a procedure called |x_retrace_error|@>
+pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
+ pointer p; /* this scans the stroked nodes in the object list */
+ pointer p0; /* if not |null| this points to the first stroked node */
+ pointer pp,qq,rr; /* pointers into |path_p(p)| */
+ pointer d,dd; /* pointers used to create the dash list */
+ scaled y0;
+ @<Other local variables in |make_dashes|@>;
+ y0=0; /* the initial $y$ coordinate */
+ if ( dash_list(h)!=null_dash )
+ return h;
+ p0=null;
+ p=link(dummy_loc(h));
+ while ( p!=null ) {
+ if ( type(p)!=mp_stroked_code ) {
+ @<Compain that the edge structure contains a node of the wrong type
+ and |goto not_found|@>;
+ }
+ pp=path_p(p);
+ if ( p0==null ){ p0=p; y0=y_coord(pp); };
+ @<Make |d| point to a new dash node created from stroke |p| and path |pp|
+ or |goto not_found| if there is an error@>;
+ @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
+ p=link(p);
+ }
+ if ( dash_list(h)==null_dash )
+ goto NOT_FOUND; /* No error message */
+ @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
+ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
+ return h;
+NOT_FOUND:
+ @<Flush the dash list, recycle |h| and return |null|@>;
+}
+
+@ @<Compain that the edge structure contains a node of the wrong type...@>=
+{
+print_err("Picture is too complicated to use as a dash pattern");
+help3("When you say `dashed p', picture p should not contain any")
+ ("text, filled regions, or clipping paths. This time it did")
+ ("so I'll just make it a solid line instead.");
+mp_put_get_error(mp);
+goto NOT_FOUND;
+}
+
+@ A similar error occurs when monotonicity fails.
+
+@<Declare a procedure called |x_retrace_error|@>=
+void mp_x_retrace_error (MP mp) {
+print_err("Picture is too complicated to use as a dash pattern");
+help3("When you say `dashed p', every path in p should be monotone")
+ ("in x and there must be no overlapping. This failed")
+ ("so I'll just make it a solid line instead.");
+mp_put_get_error(mp);
+}
+
+@ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
+handle the case where the pen stroke |p| is itself dashed.
+
+@<Make |d| point to a new dash node created from stroke |p| and path...@>=
+@<Make sure |p| and |p0| are the same color and |goto not_found| if there is
+ an error@>;
+rr=pp;
+if ( link(pp)!=pp ) {
+ do {
+ qq=rr; rr=link(rr);
+ @<Check for retracing between knots |qq| and |rr| and |goto not_found|
+ if there is a problem@>;
+ } while (right_type(rr)!=mp_endpoint);
+}
+d=mp_get_node(mp, dash_node_size);
+if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
+if ( x_coord(pp)<x_coord(rr) ) {
+ start_x(d)=x_coord(pp);
+ stop_x(d)=x_coord(rr);
+} else {
+ start_x(d)=x_coord(rr);
+ stop_x(d)=x_coord(pp);
+}
+
+@ We also need to check for the case where the segment from |qq| to |rr| is
+monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
+
+@<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
+x0=x_coord(qq);
+x1=right_x(qq);
+x2=left_x(rr);
+x3=x_coord(rr);
+if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
+ if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
+ if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
+ mp_x_retrace_error(mp); goto NOT_FOUND;
+ }
+ }
+}
+if ( (x_coord(pp)>x0) || (x0>x3) ) {
+ if ( (x_coord(pp)<x0) || (x0<x3) ) {
+ mp_x_retrace_error(mp); goto NOT_FOUND;
+ }
+}
+
+@ @<Other local variables in |make_dashes|@>=
+ scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
+
+@ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
+if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
+ (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
+ print_err("Picture is too complicated to use as a dash pattern");
+ help3("When you say `dashed p', everything in picture p should")
+ ("be the same color. I can\'t handle your color changes")
+ ("so I'll just make it a solid line instead.");
+ mp_put_get_error(mp);
+ goto NOT_FOUND;
+}
+
+@ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
+start_x(null_dash)=stop_x(d);
+dd=h; /* this makes |link(dd)=dash_list(h)| */
+while ( start_x(link(dd))<stop_x(d) )
+ dd=link(dd);
+if ( dd!=h ) {
+ if ( (stop_x(dd)>start_x(d)) )
+ { mp_x_retrace_error(mp); goto NOT_FOUND; };
+}
+link(d)=link(dd);
+link(dd)=d
+
+@ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
+d=dash_list(h);
+while ( (link(d)!=null_dash) )
+ d=link(d);
+dd=dash_list(h);
+dash_y(h)=stop_x(d)-start_x(dd);
+if ( abs(y0)>dash_y(h) ) {
+ dash_y(h)=abs(y0);
+} else if ( d!=dd ) {
+ dash_list(h)=link(dd);
+ stop_x(d)=stop_x(dd)+dash_y(h);
+ mp_free_node(mp, dd,dash_node_size);
+}
+
+@ We get here when the argument is a null picture or when there is an error.
+Recovering from an error involves making |dash_list(h)| empty to indicate
+that |h| is not known to be a valid dash pattern. We also dereference |h|
+since it is not being used for the return value.
+
+@<Flush the dash list, recycle |h| and return |null|@>=
+mp_flush_dash_list(mp, h);
+delete_edge_ref(h);
+return null
+
+@ Having carefully saved the dashed stroked nodes in the
+corresponding dash nodes, we must be prepared to break up these dashes into
+smaller dashes.
+
+@<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
+d=h; /* now |link(d)=dash_list(h)| */
+while ( link(d)!=null_dash ) {
+ ds=info(link(d));
+ if ( ds==null ) {
+ d=link(d);
+ } else {
+ hh=dash_p(ds);
+ hsf=dash_scale(ds);
+ if ( (hh==null) ) mp_confusion(mp, "dash1");
+@:this can't happen dash0}{\quad dash1@>
+ if ( dash_y(hh)==0 ) {
+ d=link(d);
+ } else {
+ if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
+@:this can't happen dash0}{\quad dash1@>
+ @<Replace |link(d)| by a dashed version as determined by edge header
+ |hh| and scale factor |ds|@>;
+ }
+ }
+}
+
+@ @<Other local variables in |make_dashes|@>=
+pointer dln; /* |link(d)| */
+pointer hh; /* an edge header that tells how to break up |dln| */
+scaled hsf; /* the dash pattern from |hh| gets scaled by this */
+pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
+scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
+
+@ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
+dln=link(d);
+dd=dash_list(hh);
+xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
+ mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
+start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
+ +mp_take_scaled(mp, hsf,dash_y(hh));
+stop_x(null_dash)=start_x(null_dash);
+@<Advance |dd| until finding the first dash that overlaps |dln| when
+ offset by |xoff|@>;
+while ( start_x(dln)<=stop_x(dln) ) {
+ @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
+ @<Insert a dash between |d| and |dln| for the overlap with the offset version
+ of |dd|@>;
+ dd=link(dd);
+ start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
+}
+link(d)=link(dln);
+mp_free_node(mp, dln,dash_node_size)
+
+@ The name of this module is a bit of a lie because we just find the
+first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
+overlap possible. It could be that the unoffset version of dash |dln| falls
+in the gap between |dd| and its predecessor.
+
+@<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
+while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
+ dd=link(dd);
+}
+
+@ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
+if ( dd==null_dash ) {
+ dd=dash_list(hh);
+ xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
+}
+
+@ At this point we already know that
+|start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
+
+@<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
+if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
+ link(d)=mp_get_node(mp, dash_node_size);
+ d=link(d);
+ link(d)=dln;
+ if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
+ start_x(d)=start_x(dln);
+ else
+ start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
+ if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
+ stop_x(d)=stop_x(dln);
+ else
+ stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
+}
+
+@ The next major task is to update the bounding box information in an edge
+header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
+header's bounding box to accommodate the box computed by |path_bbox| or
+|pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
+|maxy|.)
+
+@c void mp_adjust_bbox (MP mp,pointer h) {
+ if ( minx<minx_val(h) ) minx_val(h)=minx;
+ if ( miny<miny_val(h) ) miny_val(h)=miny;
+ if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
+ if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
+}
+
+@ Here is a special routine for updating the bounding box information in
+edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
+that is to be stroked with the pen~|pp|.
+
+@c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
+ pointer q; /* a knot node adjacent to knot |p| */
+ fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
+ scaled d; /* a factor for adjusting the length of |(dx,dy)| */
+ scaled z; /* a coordinate being tested against the bounding box */
+ scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
+ integer i; /* a loop counter */
+ if ( right_type(p)!=mp_endpoint ) {
+ q=link(p);
+ while (1) {
+ @<Make |(dx,dy)| the final direction for the path segment from
+ |q| to~|p|; set~|d|@>;
+ d=mp_pyth_add(mp, dx,dy);
+ if ( d>0 ) {
+ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
+ for (i=1;i<= 2;i++) {
+ @<Use |(dx,dy)| to generate a vertex of the square end cap and
+ update the bounding box to accommodate it@>;
+ dx=-dx; dy=-dy;
+ }
+ }
+ if ( right_type(p)==mp_endpoint ) {
+ return;
+ } else {
+ @<Advance |p| to the end of the path and make |q| the previous knot@>;
+ }
+ }
+ }
+}
+
+@ @<Make |(dx,dy)| the final direction for the path segment from...@>=
+if ( q==link(p) ) {
+ dx=x_coord(p)-right_x(p);
+ dy=y_coord(p)-right_y(p);
+ if ( (dx==0)&&(dy==0) ) {
+ dx=x_coord(p)-left_x(q);
+ dy=y_coord(p)-left_y(q);
+ }
+} else {
+ dx=x_coord(p)-left_x(p);
+ dy=y_coord(p)-left_y(p);
+ if ( (dx==0)&&(dy==0) ) {
+ dx=x_coord(p)-right_x(q);
+ dy=y_coord(p)-right_y(q);
+ }
+}
+dx=x_coord(p)-x_coord(q);
+dy=y_coord(p)-y_coord(q)
+
+@ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
+dx=mp_make_fraction(mp, dx,d);
+dy=mp_make_fraction(mp, dy,d);
+mp_find_offset(mp, -dy,dx,pp);
+xx=mp->cur_x; yy=mp->cur_y
+
+@ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
+mp_find_offset(mp, dx,dy,pp);
+d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
+if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
+ mp_confusion(mp, "box_ends");
+@:this can't happen box ends}{\quad\\{box\_ends}@>
+z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
+if ( z<minx_val(h) ) minx_val(h)=z;
+if ( z>maxx_val(h) ) maxx_val(h)=z;
+z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
+if ( z<miny_val(h) ) miny_val(h)=z;
+if ( z>maxy_val(h) ) maxy_val(h)=z
+
+@ @<Advance |p| to the end of the path and make |q| the previous knot@>=
+do {
+ q=p;
+ p=link(p);
+} while (right_type(p)!=mp_endpoint)
+
+@ The major difficulty in finding the bounding box of an edge structure is the
+effect of clipping paths. We treat them conservatively by only clipping to the
+clipping path's bounding box, but this still
+requires recursive calls to |set_bbox| in order to find the bounding box of
+@^recursion@>
+the objects to be clipped. Such calls are distinguished by the fact that the
+boolean parameter |top_level| is false.
+
+@c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
+ pointer p; /* a graphical object being considered */
+ scaled sminx,sminy,smaxx,smaxy;
+ /* for saving the bounding box during recursive calls */
+ scaled x0,x1,y0,y1; /* temporary registers */
+ integer lev; /* nesting level for |mp_start_bounds_code| nodes */
+ @<Wipe out any existing bounding box information if |bbtype(h)| is
+ incompatible with |internal[mp_true_corners]|@>;
+ while ( link(bblast(h))!=null ) {
+ p=link(bblast(h));
+ bblast(h)=p;
+ switch (type(p)) {
+ case mp_stop_clip_code:
+ if ( top_level ) mp_confusion(mp, "bbox"); else return;
+@:this can't happen bbox}{\quad bbox@>
+ break;
+ @<Other cases for updating the bounding box based on the type of object |p|@>;
+ } /* all cases are enumerated above */
+ }
+ if ( ! top_level ) mp_confusion(mp, "bbox");
+}
+
+@ @<Internal library declarations@>=
+void mp_set_bbox (MP mp,pointer h, boolean top_level);
+
+@ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
+switch (bbtype(h)) {
+case no_bounds:
+ break;
+case bounds_set:
+ if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
+ break;
+case bounds_unset:
+ if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
+ break;
+} /* there are no other cases */
+
+@ @<Other cases for updating the bounding box...@>=
+case mp_fill_code:
+ mp_path_bbox(mp, path_p(p));
+ if ( pen_p(p)!=null ) {
+ x0=minx; y0=miny;
+ x1=maxx; y1=maxy;
+ mp_pen_bbox(mp, pen_p(p));
+ minx=minx+x0;
+ miny=miny+y0;
+ maxx=maxx+x1;
+ maxy=maxy+y1;
+ }
+ mp_adjust_bbox(mp, h);
+ break;
+
+@ @<Other cases for updating the bounding box...@>=
+case mp_start_bounds_code:
+ if ( mp->internal[mp_true_corners]>0 ) {
+ bbtype(h)=bounds_unset;
+ } else {
+ bbtype(h)=bounds_set;
+ mp_path_bbox(mp, path_p(p));
+ mp_adjust_bbox(mp, h);
+ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
+ |bblast(h)|@>;
+ }
+ break;
+case mp_stop_bounds_code:
+ if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
+@:this can't happen bbox2}{\quad bbox2@>
+ break;
+
+@ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
+lev=1;
+while ( lev!=0 ) {
+ if ( link(p)==null ) mp_confusion(mp, "bbox2");
+@:this can't happen bbox2}{\quad bbox2@>
+ p=link(p);
+ if ( type(p)==mp_start_bounds_code ) incr(lev);
+ else if ( type(p)==mp_stop_bounds_code ) decr(lev);
+}
+bblast(h)=p
+
+@ It saves a lot of grief here to be slightly conservative and not account for
+omitted parts of dashed lines. We also don't worry about the material omitted
+when using butt end caps. The basic computation is for round end caps and
+|box_ends| augments it for square end caps.
+
+@<Other cases for updating the bounding box...@>=
+case mp_stroked_code:
+ mp_path_bbox(mp, path_p(p));
+ x0=minx; y0=miny;
+ x1=maxx; y1=maxy;
+ mp_pen_bbox(mp, pen_p(p));
+ minx=minx+x0;
+ miny=miny+y0;
+ maxx=maxx+x1;
+ maxy=maxy+y1;
+ mp_adjust_bbox(mp, h);
+ if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
+ mp_box_ends(mp, path_p(p), pen_p(p), h);
+ break;
+
+@ The height width and depth information stored in a text node determines a
+rectangle that needs to be transformed according to the transformation
+parameters stored in the text node.
+
+@<Other cases for updating the bounding box...@>=
+case mp_text_code:
+ x1=mp_take_scaled(mp, txx_val(p),width_val(p));
+ y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
+ y1=mp_take_scaled(mp, txy_val(p),height_val(p));
+ minx=tx_val(p);
+ maxx=minx;
+ if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
+ else { minx=minx+y1; maxx=maxx+y0; }
+ if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
+ x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
+ y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
+ y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
+ miny=ty_val(p);
+ maxy=miny;
+ if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
+ else { miny=miny+y1; maxy=maxy+y0; }
+ if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
+ mp_adjust_bbox(mp, h);
+ break;
+
+@ This case involves a recursive call that advances |bblast(h)| to the node of
+type |mp_stop_clip_code| that matches |p|.
+
+@<Other cases for updating the bounding box...@>=
+case mp_start_clip_code:
+ mp_path_bbox(mp, path_p(p));
+ x0=minx; y0=miny;
+ x1=maxx; y1=maxy;
+ sminx=minx_val(h); sminy=miny_val(h);
+ smaxx=maxx_val(h); smaxy=maxy_val(h);
+ @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
+ starting at |link(p)|@>;
+ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
+ |y0|, |y1|@>;
+ minx=sminx; miny=sminy;
+ maxx=smaxx; maxy=smaxy;
+ mp_adjust_bbox(mp, h);
+ break;
+
+@ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
+minx_val(h)=el_gordo;
+miny_val(h)=el_gordo;
+maxx_val(h)=-el_gordo;
+maxy_val(h)=-el_gordo;
+mp_set_bbox(mp, h,false)
+
+@ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
+if ( minx_val(h)<x0 ) minx_val(h)=x0;
+if ( miny_val(h)<y0 ) miny_val(h)=y0;
+if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
+if ( maxy_val(h)>y1 ) maxy_val(h)=y1
+
+@* \[22] Finding an envelope.
+When \MP\ has a path and a polygonal pen, it needs to express the desired
+shape in terms of things \ps\ can understand. The present task is to compute
+a new path that describes the region to be filled. It is convenient to
+define this as a two step process where the first step is determining what
+offset to use for each segment of the path.
+
+@ Given a pointer |c| to a cyclic path,
+and a pointer~|h| to the first knot of a pen polygon,
+the |offset_prep| routine changes the path into cubics that are
+associated with particular pen offsets. Thus if the cubic between |p|
+and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
+has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
+to because |l-k| could be negative.)
+
+After overwriting the type information with offset differences, we no longer
+have a true path so we refer to the knot list returned by |offset_prep| as an
+``envelope spec.''
+@^envelope spec@>
+Since an envelope spec only determines relative changes in pen offsets,
+|offset_prep| sets a global variable |spec_offset| to the relative change from
+|h| to the first offset.
+
+@d zero_off 16384 /* added to offset changes to make them positive */
+
+@<Glob...@>=
+integer spec_offset; /* number of pen edges between |h| and the initial offset */
+
+@ @c @<Declare subroutines needed by |offset_prep|@>
+pointer mp_offset_prep (MP mp,pointer c, pointer h) {
+ halfword n; /* the number of vertices in the pen polygon */
+ pointer p,q,q0,r,w, ww; /* for list manipulation */
+ integer k_needed; /* amount to be added to |info(p)| when it is computed */
+ pointer w0; /* a pointer to pen offset to use just before |p| */
+ scaled dxin,dyin; /* the direction into knot |p| */
+ integer turn_amt; /* change in pen offsets for the current cubic */
+ @<Other local variables for |offset_prep|@>;
+ dx0=0; dy0=0;
+ @<Initialize the pen size~|n|@>;
+ @<Initialize the incoming direction and pen offset at |c|@>;
+ p=c; k_needed=0;
+ do {
+ q=link(p);
+ @<Split the cubic between |p| and |q|, if necessary, into cubics
+ associated with single offsets, after which |q| should
+ point to the end of the final such cubic@>;
+ NOT_FOUND:
+ @<Advance |p| to node |q|, removing any ``dead'' cubics that
+ might have been introduced by the splitting process@>;
+ } while (q!=c);
+ @<Fix the offset change in |info(c)| and set |c| to the return value of
+ |offset_prep|@>;
+ return c;
+}
+
+@ We shall want to keep track of where certain knots on the cyclic path
+wind up in the envelope spec. It doesn't suffice just to keep pointers to
+knot nodes because some nodes are deleted while removing dead cubics. Thus
+|offset_prep| updates the following pointers
+
+@<Glob...@>=
+pointer spec_p1;
+pointer spec_p2; /* pointers to distinguished knots */
+
+@ @<Set init...@>=
+mp->spec_p1=null; mp->spec_p2=null;
+
+@ @<Initialize the pen size~|n|@>=
+n=0; p=h;
+do {
+ incr(n);
+ p=link(p);
+} while (p!=h)
+
+@ Since the true incoming direction isn't known yet, we just pick a direction
+consistent with the pen offset~|h|. If this is wrong, it can be corrected
+later.
+
+@<Initialize the incoming direction and pen offset at |c|@>=
+dxin=x_coord(link(h))-x_coord(knil(h));
+dyin=y_coord(link(h))-y_coord(knil(h));
+if ( (dxin==0)&&(dyin==0) ) {
+ dxin=y_coord(knil(h))-y_coord(h);
+ dyin=x_coord(h)-x_coord(knil(h));
+}
+w0=h
+
+@ We must be careful not to remove the only cubic in a cycle.
+
+But we must also be careful for another reason. If the user-supplied
+path starts with a set of degenerate cubics, the target node |q| can
+be collapsed to the initial node |p| which might be the same as the
+initial node |c| of the curve. This would cause the |offset_prep| routine
+to bail out too early, causing distress later on. (See for example
+the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
+on Sarovar.)
+
+@<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
+q0=q;
+do {
+ r=link(p);
+ if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
+ x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
+ x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
+ r!=p ) {
+ @<Remove the cubic following |p| and update the data structures
+ to merge |r| into |p|@>;
+ }
+ p=r;
+} while (p!=q);
+/* Check if we removed too much */
+if(q!=q0)
+ q = link(q)
+
+@ @<Remove the cubic following |p| and update the data structures...@>=
+{ k_needed=info(p)-zero_off;
+ if ( r==q ) {
+ q=p;
+ } else {
+ info(p)=k_needed+info(r);
+ k_needed=0;
+ };
+ if ( r==c ) { info(p)=info(c); c=p; };
+ if ( r==mp->spec_p1 ) mp->spec_p1=p;
+ if ( r==mp->spec_p2 ) mp->spec_p2=p;
+ r=p; mp_remove_cubic(mp, p);
+}
+
+@ Not setting the |info| field of the newly created knot allows the splitting
+routine to work for paths.
+
+@<Declare subroutines needed by |offset_prep|@>=
+void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
+ scaled v; /* an intermediate value */
+ pointer q,r; /* for list manipulation */
+ q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
+ originator(r)=mp_program_code;
+ left_type(r)=mp_explicit; right_type(r)=mp_explicit;
+ v=t_of_the_way(right_x(p),left_x(q));
+ right_x(p)=t_of_the_way(x_coord(p),right_x(p));
+ left_x(q)=t_of_the_way(left_x(q),x_coord(q));
+ left_x(r)=t_of_the_way(right_x(p),v);
+ right_x(r)=t_of_the_way(v,left_x(q));
+ x_coord(r)=t_of_the_way(left_x(r),right_x(r));
+ v=t_of_the_way(right_y(p),left_y(q));
+ right_y(p)=t_of_the_way(y_coord(p),right_y(p));
+ left_y(q)=t_of_the_way(left_y(q),y_coord(q));
+ left_y(r)=t_of_the_way(right_y(p),v);
+ right_y(r)=t_of_the_way(v,left_y(q));
+ y_coord(r)=t_of_the_way(left_y(r),right_y(r));
+}
+
+@ This does not set |info(p)| or |right_type(p)|.
+
+@<Declare subroutines needed by |offset_prep|@>=
+void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
+ pointer q; /* the node that disappears */
+ q=link(p); link(p)=link(q);
+ right_x(p)=right_x(q); right_y(p)=right_y(q);
+ mp_free_node(mp, q,knot_node_size);
+}
+
+@ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
+strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
+mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
+$k$th pen offset, the $k$th pen edge direction is defined by the formula
+$$d_k=(u\k-u_k,\,v\k-v_k).$$
+When listed by increasing $k$, these directions occur in counter-clockwise
+order so that $d_k\preceq d\k$ for all~$k$.
+The goal of |offset_prep| is to find an offset index~|k| to associate with
+each cubic, such that the direction $d(t)$ of the cubic satisfies
+$$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
+We may have to split a cubic into many pieces before each
+piece corresponds to a unique offset.
+
+@<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
+info(p)=zero_off+k_needed;
+k_needed=0;
+@<Prepare for derivative computations;
+ |goto not_found| if the current cubic is dead@>;
+@<Find the initial direction |(dx,dy)|@>;
+@<Update |info(p)| and find the offset $w_k$ such that
+ $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
+ the direction change at |p|@>;
+@<Find the final direction |(dxin,dyin)|@>;
+@<Decide on the net change in pen offsets and set |turn_amt|@>;
+@<Complete the offset splitting process@>;
+w0=mp_pen_walk(mp, w0,turn_amt)
+
+@ @<Declare subroutines needed by |offset_prep|@>=
+pointer mp_pen_walk (MP mp,pointer w, integer k) {
+ /* walk |k| steps around a pen from |w| */
+ while ( k>0 ) { w=link(w); decr(k); };
+ while ( k<0 ) { w=knil(w); incr(k); };
+ return w;
+}
+
+@ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
+calculated from the quadratic polynomials
+${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
+${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
+Since we may be calculating directions from several cubics
+split from the current one, it is desirable to do these calculations
+without losing too much precision. ``Scaled up'' values of the
+derivatives, which will be less tainted by accumulated errors than
+derivatives found from the cubics themselves, are maintained in
+local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
+$X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
+represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$.
+
+@<Other local variables for |offset_prep|@>=
+integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
+integer t0,t1,t2; /* coefficients of polynomial for slope testing */
+integer du,dv,dx,dy; /* for directions of the pen and the curve */
+integer dx0,dy0; /* initial direction for the first cubic in the curve */
+integer max_coef; /* used while scaling */
+integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
+fraction t; /* where the derivative passes through zero */
+fraction s; /* a temporary value */
+
+@ @<Prepare for derivative computations...@>=
+x0=right_x(p)-x_coord(p);
+x2=x_coord(q)-left_x(q);
+x1=left_x(q)-right_x(p);
+y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
+y1=left_y(q)-right_y(p);
+max_coef=abs(x0);
+if ( abs(x1)>max_coef ) max_coef=abs(x1);
+if ( abs(x2)>max_coef ) max_coef=abs(x2);
+if ( abs(y0)>max_coef ) max_coef=abs(y0);
+if ( abs(y1)>max_coef ) max_coef=abs(y1);
+if ( abs(y2)>max_coef ) max_coef=abs(y2);
+if ( max_coef==0 ) goto NOT_FOUND;
+while ( max_coef<fraction_half ) {
+ double(max_coef);
+ double(x0); double(x1); double(x2);
+ double(y0); double(y1); double(y2);
+}
+
+@ Let us first solve a special case of the problem: Suppose we
+know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
+and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
+$d(0)\succ d_{k-1}$.
+Then, in a sense, we're halfway done, since one of the two relations
+in $(*)$ is satisfied, and the other couldn't be satisfied for
+any other value of~|k|.
+
+Actually, the conditions can be relaxed somewhat since a relation such as
+$d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
+matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
+the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
+and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
+Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
+counterclockwise direction.
+
+The |fin_offset_prep| subroutine solves the stated subproblem.
+It has a parameter called |rise| that is |1| in
+case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
+the derivative of the cubic following |p|.
+The |w| parameter should point to offset~$w_k$ and |info(p)| should already
+be set properly. The |turn_amt| parameter gives the absolute value of the
+overall net change in pen offsets.
+
+@<Declare subroutines needed by |offset_prep|@>=
+void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
+ x0,integer x1, integer x2, integer y0, integer y1, integer y2,
+ integer rise, integer turn_amt) {
+ pointer ww; /* for list manipulation */
+ scaled du,dv; /* for slope calculation */
+ integer t0,t1,t2; /* test coefficients */
+ fraction t; /* place where the derivative passes a critical slope */
+ fraction s; /* slope or reciprocal slope */
+ integer v; /* intermediate value for updating |x0..y2| */
+ pointer q; /* original |link(p)| */
+ q=link(p);
+ while (1) {
+ if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
+ else ww=knil(w); /* a pointer to $w_{k-1}$ */
+ @<Compute test coefficients |(t0,t1,t2)|
+ for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
+ t=mp_crossing_point(mp, t0,t1,t2);
+ if ( t>=fraction_one ) {
+ if ( turn_amt>0 ) t=fraction_one; else return;
+ }
+ @<Split the cubic at $t$,
+ and split off another cubic if the derivative crosses back@>;
+ w=ww;
+ }
+}
+
+@ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
+$-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
+function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
+begins to fail.
+
+@<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
+du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
+if ( abs(du)>=abs(dv) ) {
+ s=mp_make_fraction(mp, dv,du);
+ t0=mp_take_fraction(mp, x0,s)-y0;
+ t1=mp_take_fraction(mp, x1,s)-y1;
+ t2=mp_take_fraction(mp, x2,s)-y2;
+ if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
+} else {
+ s=mp_make_fraction(mp, du,dv);
+ t0=x0-mp_take_fraction(mp, y0,s);
+ t1=x1-mp_take_fraction(mp, y1,s);
+ t2=x2-mp_take_fraction(mp, y2,s);
+ if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
+}
+if ( t0<0 ) t0=0 /* should be positive without rounding error */
+
+@ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
+$(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
+respectively, yielding another solution of $(*)$.
+
+@<Split the cubic at $t$, and split off another...@>=
+{
+mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
+decr(turn_amt);
+v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
+x0=t_of_the_way(v,x1);
+v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
+y0=t_of_the_way(v,y1);
+if ( turn_amt<0 ) {
+ t1=t_of_the_way(t1,t2);
+ if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
+ t=mp_crossing_point(mp, 0,-t1,-t2);
+ if ( t>fraction_one ) t=fraction_one;
+ incr(turn_amt);
+ if ( (t==fraction_one)&&(link(p)!=q) ) {
+ info(link(p))=info(link(p))-rise;
+ } else {
+ mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
+ v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
+ x2=t_of_the_way(x1,v);
+ v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
+ y2=t_of_the_way(y1,v);
+ }
+}
+}
+
+@ Now we must consider the general problem of |offset_prep|, when
+nothing is known about a given cubic. We start by finding its
+direction in the vicinity of |t=0|.
+
+If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
+has not yet introduced any more numerical errors. Thus we can compute
+the true initial direction for the given cubic, even if it is almost
+degenerate.
+
+@<Find the initial direction |(dx,dy)|@>=
+dx=x0; dy=y0;
+if ( dx==0 && dy==0 ) {
+ dx=x1; dy=y1;
+ if ( dx==0 && dy==0 ) {
+ dx=x2; dy=y2;
+ }
+}
+if ( p==c ) { dx0=dx; dy0=dy; }
+
+@ @<Find the final direction |(dxin,dyin)|@>=
+dxin=x2; dyin=y2;
+if ( dxin==0 && dyin==0 ) {
+ dxin=x1; dyin=y1;
+ if ( dxin==0 && dyin==0 ) {
+ dxin=x0; dyin=y0;
+ }
+}
+
+@ The next step is to bracket the initial direction between consecutive
+edges of the pen polygon. We must be careful to turn clockwise only if
+this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
+counter-clockwise in order to make \&{doublepath} envelopes come out
+@:double_path_}{\&{doublepath} primitive@>
+right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
+
+@<Update |info(p)| and find the offset $w_k$ such that...@>=
+turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
+w=mp_pen_walk(mp, w0, turn_amt);
+w0=w;
+info(p)=info(p)+turn_amt
+
+@ Decide how many pen offsets to go away from |w| in order to find the offset
+for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
+|w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
+in the sense determined by |ccw| is less than or equal to $180^\circ$.
+
+If the pen polygon has only two edges, they could both be parallel
+to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
+such edge in order to avoid an infinite loop.
+
+@<Declare subroutines needed by |offset_prep|@>=
+integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
+ scaled dy, boolean ccw) {
+ pointer ww; /* a neighbor of knot~|w| */
+ integer s; /* turn amount so far */
+ integer t; /* |ab_vs_cd| result */
+ s=0;
+ if ( ccw ) {
+ ww=link(w);
+ do {
+ t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
+ dx,(y_coord(ww)-y_coord(w)));
+ if ( t<0 ) break;
+ incr(s);
+ w=ww; ww=link(ww);
+ } while (t>0);
+ } else {
+ ww=knil(w);
+ while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
+ dx,(y_coord(w)-y_coord(ww))) < 0) {
+ decr(s);
+ w=ww; ww=knil(ww);
+ }
+ }
+ return s;
+}
+
+@ When we're all done, the final offset is |w0| and the final curve direction
+is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
+can correct |info(c)| which was erroneously based on an incoming offset
+of~|h|.
+
+@d fix_by(A) info(c)=info(c)+(A)
+
+@<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
+mp->spec_offset=info(c)-zero_off;
+if ( link(c)==c ) {
+ info(c)=zero_off+n;
+} else {
+ fix_by(k_needed);
+ while ( w0!=h ) { fix_by(1); w0=link(w0); };
+ while ( info(c)<=zero_off-n ) fix_by(n);
+ while ( info(c)>zero_off ) fix_by(-n);
+ if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
+}
+
+@ Finally we want to reduce the general problem to situations that
+|fin_offset_prep| can handle. We split the cubic into at most three parts
+with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
+
+@<Complete the offset splitting process@>=
+ww=knil(w);
+@<Compute test coeff...@>;
+@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
+ |t:=fraction_one+1|@>;
+if ( t>fraction_one ) {
+ mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
+} else {
+ mp_split_cubic(mp, p,t); r=link(p);
+ x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
+ x2a=t_of_the_way(x1a,x1);
+ y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
+ y2a=t_of_the_way(y1a,y1);
+ mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
+ info(r)=zero_off-1;
+ if ( turn_amt>=0 ) {
+ t1=t_of_the_way(t1,t2);
+ if ( t1>0 ) t1=0;
+ t=mp_crossing_point(mp, 0,-t1,-t2);
+ if ( t>fraction_one ) t=fraction_one;
+ @<Split off another rising cubic for |fin_offset_prep|@>;
+ mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
+ } else {
+ mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
+ }
+}
+
+@ @<Split off another rising cubic for |fin_offset_prep|@>=
+mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
+x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
+x0a=t_of_the_way(x1,x1a);
+y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
+y0a=t_of_the_way(y1,y1a);
+mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
+x2=x0a; y2=y0a
+
+@ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
+When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
+need to decide whether the directions are parallel or antiparallel. We
+can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
+should be avoided when the value of |turn_amt| already determines the
+answer. If |t2<0|, there is one crossing and it is antiparallel only if
+|turn_amt>=0|. If |turn_amt<0|, there should always be at least one
+crossing and the first crossing cannot be antiparallel.
+
+@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
+t=mp_crossing_point(mp, t0,t1,t2);
+if ( turn_amt>=0 ) {
+ if ( t2<0 ) {
+ t=fraction_one+1;
+ } else {
+ u0=t_of_the_way(x0,x1);
+ u1=t_of_the_way(x1,x2);
+ ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
+ v0=t_of_the_way(y0,y1);
+ v1=t_of_the_way(y1,y2);
+ ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
+ if ( ss<0 ) t=fraction_one+1;
+ }
+} else if ( t>fraction_one ) {
+ t=fraction_one;
+}
+
+@ @<Other local variables for |offset_prep|@>=
+integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
+integer ss = 0; /* the part of the dot product computed so far */
+int d_sign; /* sign of overall change in direction for this cubic */
+
+@ If the cubic almost has a cusp, it is a numerically ill-conditioned
+problem to decide which way it loops around but that's OK as long we're
+consistent. To make \&{doublepath} envelopes work properly, reversing
+the path should always change the sign of |turn_amt|.
+
+@<Decide on the net change in pen offsets and set |turn_amt|@>=
+d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
+if ( d_sign==0 ) {
+ @<Check rotation direction based on node position@>
+}
+if ( d_sign==0 ) {
+ if ( dx==0 ) {
+ if ( dy>0 ) d_sign=1; else d_sign=-1;
+ } else {
+ if ( dx>0 ) d_sign=1; else d_sign=-1;
+ }
+}
+@<Make |ss| negative if and only if the total change in direction is
+ more than $180^\circ$@>;
+turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
+if ( ss<0 ) turn_amt=turn_amt-d_sign*n
+
+@ We check rotation direction by looking at the vector connecting the current
+node with the next. If its angle with incoming and outgoing tangents has the
+same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
+Otherwise we proceed to the cusp code.
+
+@<Check rotation direction based on node position@>=
+u0=x_coord(q)-x_coord(p);
+u1=y_coord(q)-y_coord(p);
+d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
+ mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
+
+@ In order to be invariant under path reversal, the result of this computation
+should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
+then swapped with |(x2,y2)|. We make use of the identities
+|take_fraction(-a,-b)=take_fraction(a,b)| and
+|t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
+
+@<Make |ss| negative if and only if the total change in direction is...@>=
+t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
+t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
+if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
+if ( t0>0 ) {
+ t=mp_crossing_point(mp, t0,t1,-t0);
+ u0=t_of_the_way(x0,x1);
+ u1=t_of_the_way(x1,x2);
+ v0=t_of_the_way(y0,y1);
+ v1=t_of_the_way(y1,y2);
+} else {
+ t=mp_crossing_point(mp, -t0,t1,t0);
+ u0=t_of_the_way(x2,x1);
+ u1=t_of_the_way(x1,x0);
+ v0=t_of_the_way(y2,y1);
+ v1=t_of_the_way(y1,y0);
+}
+ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
+ mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
+
+@ Here's a routine that prints an envelope spec in symbolic form. It assumes
+that the |cur_pen| has not been walked around to the first offset.
+
+@c
+void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
+ pointer p,q; /* list traversal */
+ pointer w; /* the current pen offset */
+ mp_print_diagnostic(mp, "Envelope spec",s,true);
+ p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
+ mp_print_ln(mp);
+ mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
+ mp_print(mp, " % beginning with offset ");
+ mp_print_two(mp, x_coord(w),y_coord(w));
+ do {
+ while (1) {
+ q=link(p);
+ @<Print the cubic between |p| and |q|@>;
+ p=q;
+ if ((p==cur_spec) || (info(p)!=zero_off))
+ break;
+ }
+ if ( info(p)!=zero_off ) {
+ @<Update |w| as indicated by |info(p)| and print an explanation@>;
+ }
+ } while (p!=cur_spec);
+ mp_print_nl(mp, " & cycle");
+ mp_end_diagnostic(mp, true);
+}
+
+@ @<Update |w| as indicated by |info(p)| and print an explanation@>=
+{
+ w=mp_pen_walk(mp, w, (info(p)-zero_off));
+ mp_print(mp, " % ");
+ if ( info(p)>zero_off ) mp_print(mp, "counter");
+ mp_print(mp, "clockwise to offset ");
+ mp_print_two(mp, x_coord(w),y_coord(w));
+}
+
+@ @<Print the cubic between |p| and |q|@>=
+{
+ mp_print_nl(mp, " ..controls ");
+ mp_print_two(mp, right_x(p),right_y(p));
+ mp_print(mp, " and ");
+ mp_print_two(mp, left_x(q),left_y(q));
+ mp_print_nl(mp, " ..");
+ mp_print_two(mp, x_coord(q),y_coord(q));
+}
+
+@ Once we have an envelope spec, the remaining task to construct the actual
+envelope by offsetting each cubic as determined by the |info| fields in
+the knots. First we use |offset_prep| to convert the |c| into an envelope
+spec. Then we add the offsets so that |c| becomes a cyclic path that represents
+the envelope.
+
+The |ljoin| and |miterlim| parameters control the treatment of points where the
+pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
+The endpoints are easily located because |c| is given in undoubled form
+and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
+track of the endpoints and treat them like very sharp corners.
+Butt end caps are treated like beveled joins; round end caps are treated like
+round joins; and square end caps are achieved by setting |join_type:=3|.
+
+None of these parameters apply to inside joins where the convolution tracing
+has retrograde lines. In such cases we use a simple connect-the-endpoints
+approach that is achieved by setting |join_type:=2|.
+
+@c @<Declare a function called |insert_knot|@>
+pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
+ small_number lcap, scaled miterlim) {
+ pointer p,q,r,q0; /* for manipulating the path */
+ int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
+ pointer w,w0; /* the pen knot for the current offset */
+ scaled qx,qy; /* unshifted coordinates of |q| */
+ halfword k,k0; /* controls pen edge insertion */
+ @<Other local variables for |make_envelope|@>;
+ dxin=0; dyin=0; dxout=0; dyout=0;
+ mp->spec_p1=null; mp->spec_p2=null;
+ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
+ @<Use |offset_prep| to compute the envelope spec then walk |h| around to
+ the initial offset@>;
+ w=h;
+ p=c;
+ do {
+ q=link(p); q0=q;
+ qx=x_coord(q); qy=y_coord(q);
+ k=info(q);
+ k0=k; w0=w;
+ if ( k!=zero_off ) {
+ @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
+ }
+ @<Add offset |w| to the cubic from |p| to |q|@>;
+ while ( k!=zero_off ) {
+ @<Step |w| and move |k| one step closer to |zero_off|@>;
+ if ( (join_type==1)||(k==zero_off) )
+ q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
+ };
+ if ( q!=link(p) ) {
+ @<Set |p=link(p)| and add knots between |p| and |q| as
+ required by |join_type|@>;
+ }
+ p=q;
+ } while (q0!=c);
+ return c;
+}
+
+@ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
+c=mp_offset_prep(mp, c,h);
+if ( mp->internal[mp_tracing_specs]>0 )
+ mp_print_spec(mp, c,h,"");
+h=mp_pen_walk(mp, h,mp->spec_offset)
+
+@ Mitered and squared-off joins depend on path directions that are difficult to
+compute for degenerate cubics. The envelope spec computed by |offset_prep| can
+have degenerate cubics only if the entire cycle collapses to a single
+degenerate cubic. Setting |join_type:=2| in this case makes the computed
+envelope degenerate as well.
+
+@<Set |join_type| to indicate how to handle offset changes at~|q|@>=
+if ( k<zero_off ) {
+ join_type=2;
+} else {
+ if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
+ else if ( lcap==2 ) join_type=3;
+ else join_type=2-lcap;
+ if ( (join_type==0)||(join_type==3) ) {
+ @<Set the incoming and outgoing directions at |q|; in case of
+ degeneracy set |join_type:=2|@>;
+ if ( join_type==0 ) {
+ @<If |miterlim| is less than the secant of half the angle at |q|
+ then set |join_type:=2|@>;
+ }
+ }
+}
+
+@ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
+{
+ tmp=mp_take_fraction(mp, miterlim,fraction_half+
+ half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
+ if ( tmp<unity )
+ if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
+}
+
+@ @<Other local variables for |make_envelope|@>=
+fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
+scaled tmp; /* a temporary value */
+
+@ The coordinates of |p| have already been shifted unless |p| is the first
+knot in which case they get shifted at the very end.
+
+@<Add offset |w| to the cubic from |p| to |q|@>=
+right_x(p)=right_x(p)+x_coord(w);
+right_y(p)=right_y(p)+y_coord(w);
+left_x(q)=left_x(q)+x_coord(w);
+left_y(q)=left_y(q)+y_coord(w);
+x_coord(q)=x_coord(q)+x_coord(w);
+y_coord(q)=y_coord(q)+y_coord(w);
+left_type(q)=mp_explicit;
+right_type(q)=mp_explicit
+
+@ @<Step |w| and move |k| one step closer to |zero_off|@>=
+if ( k>zero_off ){ w=link(w); decr(k); }
+else { w=knil(w); incr(k); }
+
+@ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
+the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
+case the cubic containing these control points is ``yet to be examined.''
+
+@<Declare a function called |insert_knot|@>=
+pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
+ /* returns the inserted knot */
+ pointer r; /* the new knot */
+ r=mp_get_node(mp, knot_node_size);
+ link(r)=link(q); link(q)=r;
+ right_x(r)=right_x(q);
+ right_y(r)=right_y(q);
+ x_coord(r)=x;
+ y_coord(r)=y;
+ right_x(q)=x_coord(q);
+ right_y(q)=y_coord(q);
+ left_x(r)=x_coord(r);
+ left_y(r)=y_coord(r);
+ left_type(r)=mp_explicit;
+ right_type(r)=mp_explicit;
+ originator(r)=mp_program_code;
+ return r;
+}
+
+@ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
+
+@<Set |p=link(p)| and add knots between |p| and |q| as...@>=
+{
+ p=link(p);
+ if ( (join_type==0)||(join_type==3) ) {
+ if ( join_type==0 ) {
+ @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
+ } else {
+ @<Make |r| the last of two knots inserted between |p| and |q| to form a
+ squared join@>;
+ }
+ if ( r!=null ) {
+ right_x(r)=x_coord(r);
+ right_y(r)=y_coord(r);
+ }
+ }
+}
+
+@ For very small angles, adding a knot is unnecessary and would cause numerical
+problems, so we just set |r:=null| in that case.
+
+@<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
+{
+ det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
+ if ( abs(det)<26844 ) {
+ r=null; /* sine $<10^{-4}$ */
+ } else {
+ tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
+ mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
+ tmp=mp_make_fraction(mp, tmp,det);
+ r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
+ y_coord(p)+mp_take_fraction(mp, tmp,dyin));
+ }
+}
+
+@ @<Other local variables for |make_envelope|@>=
+fraction det; /* a determinant used for mitered join calculations */
+
+@ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
+{
+ ht_x=y_coord(w)-y_coord(w0);
+ ht_y=x_coord(w0)-x_coord(w);
+ while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
+ ht_x+=ht_x; ht_y+=ht_y;
+ }
+ @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
+ product with |(ht_x,ht_y)|@>;
+ tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
+ mp_take_fraction(mp, dyin,ht_y));
+ r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
+ y_coord(p)+mp_take_fraction(mp, tmp,dyin));
+ tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
+ mp_take_fraction(mp, dyout,ht_y));
+ r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
+ y_coord(q)+mp_take_fraction(mp, tmp,dyout));
+}
+
+@ @<Other local variables for |make_envelope|@>=
+fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
+scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
+halfword kk; /* keeps track of the pen vertices being scanned */
+pointer ww; /* the pen vertex being tested */
+
+@ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
+from zero to |max_ht|.
+
+@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
+max_ht=0;
+kk=zero_off;
+ww=w;
+while (1) {
+ @<Step |ww| and move |kk| one step closer to |k0|@>;
+ if ( kk==k0 ) break;
+ tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
+ mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
+ if ( tmp>max_ht ) max_ht=tmp;
+}
+
+
+@ @<Step |ww| and move |kk| one step closer to |k0|@>=
+if ( kk>k0 ) { ww=link(ww); decr(kk); }
+else { ww=knil(ww); incr(kk); }
+
+@ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
+if ( left_type(c)==mp_endpoint ) {
+ mp->spec_p1=mp_htap_ypoc(mp, c);
+ mp->spec_p2=mp->path_tail;
+ originator(mp->spec_p1)=mp_program_code;
+ link(mp->spec_p2)=link(mp->spec_p1);
+ link(mp->spec_p1)=c;
+ mp_remove_cubic(mp, mp->spec_p1);
+ c=mp->spec_p1;
+ if ( c!=link(c) ) {
+ originator(mp->spec_p2)=mp_program_code;
+ mp_remove_cubic(mp, mp->spec_p2);
+ } else {
+ @<Make |c| look like a cycle of length one@>;
+ }
+}
+
+@ @<Make |c| look like a cycle of length one@>=
+{
+ left_type(c)=mp_explicit; right_type(c)=mp_explicit;
+ left_x(c)=x_coord(c); left_y(c)=y_coord(c);
+ right_x(c)=x_coord(c); right_y(c)=y_coord(c);
+}
+
+@ In degenerate situations we might have to look at the knot preceding~|q|.
+That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
+
+@<Set the incoming and outgoing directions at |q|; in case of...@>=
+dxin=x_coord(q)-left_x(q);
+dyin=y_coord(q)-left_y(q);
+if ( (dxin==0)&&(dyin==0) ) {
+ dxin=x_coord(q)-right_x(p);
+ dyin=y_coord(q)-right_y(p);
+ if ( (dxin==0)&&(dyin==0) ) {
+ dxin=x_coord(q)-x_coord(p);
+ dyin=y_coord(q)-y_coord(p);
+ if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
+ dxin=dxin+x_coord(w);
+ dyin=dyin+y_coord(w);
+ }
+ }
+}
+tmp=mp_pyth_add(mp, dxin,dyin);
+if ( tmp==0 ) {
+ join_type=2;
+} else {
+ dxin=mp_make_fraction(mp, dxin,tmp);
+ dyin=mp_make_fraction(mp, dyin,tmp);
+ @<Set the outgoing direction at |q|@>;
+}
+
+@ If |q=c| then the coordinates of |r| and the control points between |q|
+and~|r| have already been offset by |h|.
+
+@<Set the outgoing direction at |q|@>=
+dxout=right_x(q)-x_coord(q);
+dyout=right_y(q)-y_coord(q);
+if ( (dxout==0)&&(dyout==0) ) {
+ r=link(q);
+ dxout=left_x(r)-x_coord(q);
+ dyout=left_y(r)-y_coord(q);
+ if ( (dxout==0)&&(dyout==0) ) {
+ dxout=x_coord(r)-x_coord(q);
+ dyout=y_coord(r)-y_coord(q);
+ }
+}
+if ( q==c ) {
+ dxout=dxout-x_coord(h);
+ dyout=dyout-y_coord(h);
+}
+tmp=mp_pyth_add(mp, dxout,dyout);
+if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
+@:this can't happen degerate spec}{\quad degenerate spec@>
+dxout=mp_make_fraction(mp, dxout,tmp);
+dyout=mp_make_fraction(mp, dyout,tmp)
+
+@* \[23] Direction and intersection times.
+A path of length $n$ is defined parametrically by functions $x(t)$ and
+$y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
+reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
+we shall consider operations that determine special times associated with
+given paths: the first time that a path travels in a given direction, and
+a pair of times at which two paths cross each other.
+
+@ Let's start with the easier task. The function |find_direction_time| is
+given a direction |(x,y)| and a path starting at~|h|. If the path never
+travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
+it will be nonnegative.
+
+Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
+direction is undefined, the direction time will be~0. If $\bigl(x'(t),
+y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
+assumed to match any given direction at time~|t|.
+
+The routine solves this problem in nondegenerate cases by rotating the path
+and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
+to find when a given path first travels ``due east.''
+
+@c
+scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
+ scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
+ pointer p,q; /* for list traversal */
+ scaled n; /* the direction time at knot |p| */
+ scaled tt; /* the direction time within a cubic */
+ @<Other local variables for |find_direction_time|@>;
+ @<Normalize the given direction for better accuracy;
+ but |return| with zero result if it's zero@>;
+ n=0; p=h; phi=0;
+ while (1) {
+ if ( right_type(p)==mp_endpoint ) break;
+ q=link(p);
+ @<Rotate the cubic between |p| and |q|; then
+ |goto found| if the rotated cubic travels due east at some time |tt|;
+ but |break| if an entire cyclic path has been traversed@>;
+ p=q; n=n+unity;
+ }
+ return (-unity);
+FOUND:
+ return (n+tt);
+}
+
+@ @<Normalize the given direction for better accuracy...@>=
+if ( abs(x)<abs(y) ) {
+ x=mp_make_fraction(mp, x,abs(y));
+ if ( y>0 ) y=fraction_one; else y=-fraction_one;
+} else if ( x==0 ) {
+ return 0;
+} else {
+ y=mp_make_fraction(mp, y,abs(x));
+ if ( x>0 ) x=fraction_one; else x=-fraction_one;
+}
+
+@ Since we're interested in the tangent directions, we work with the
+derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
+B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
+$B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
+in order to achieve better accuracy.
+
+The given path may turn abruptly at a knot, and it might pass the critical
+tangent direction at such a time. Therefore we remember the direction |phi|
+in which the previous rotated cubic was traveling. (The value of |phi| will be
+undefined on the first cubic, i.e., when |n=0|.)
+
+@<Rotate the cubic between |p| and |q|; then...@>=
+tt=0;
+@<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
+ points of the rotated derivatives@>;
+if ( y1==0 ) if ( x1>=0 ) goto FOUND;
+if ( n>0 ) {
+ @<Exit to |found| if an eastward direction occurs at knot |p|@>;
+ if ( p==h ) break;
+ };
+if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
+@<Exit to |found| if the curve whose derivatives are specified by
+ |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
+
+@ @<Other local variables for |find_direction_time|@>=
+scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
+angle theta,phi; /* angles of exit and entry at a knot */
+fraction t; /* temp storage */
+
+@ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
+x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
+x3=x_coord(q)-left_x(q);
+y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
+y3=y_coord(q)-left_y(q);
+max=abs(x1);
+if ( abs(x2)>max ) max=abs(x2);
+if ( abs(x3)>max ) max=abs(x3);
+if ( abs(y1)>max ) max=abs(y1);
+if ( abs(y2)>max ) max=abs(y2);
+if ( abs(y3)>max ) max=abs(y3);
+if ( max==0 ) goto FOUND;
+while ( max<fraction_half ){
+ max+=max; x1+=x1; x2+=x2; x3+=x3;
+ y1+=y1; y2+=y2; y3+=y3;
+}
+t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
+y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
+t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
+y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
+t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
+y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
+
+@ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
+theta=mp_n_arg(mp, x1,y1);
+if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
+if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
+
+@ In this step we want to use the |crossing_point| routine to find the
+roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
+Several complications arise: If the quadratic equation has a double root,
+the curve never crosses zero, and |crossing_point| will find nothing;
+this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
+equation has simple roots, or only one root, we may have to negate it
+so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
+And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
+identically zero.
+
+@ @<Exit to |found| if the curve whose derivatives are specified by...@>=
+if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
+if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
+ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
+ either |goto found| or |goto done|@>;
+}
+if ( y1<=0 ) {
+ if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
+ else if ( y2>0 ){ y2=-y2; y3=-y3; };
+}
+@<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
+ $B(x_1,x_2,x_3;t)\ge0$@>;
+DONE:
+
+@ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
+two roots, because we know that it isn't identically zero.
+
+It must be admitted that the |crossing_point| routine is not perfectly accurate;
+rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
+miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
+subject to rounding errors. Yet this code optimistically tries to
+do the right thing.
+
+@d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
+
+@<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
+t=mp_crossing_point(mp, y1,y2,y3);
+if ( t>fraction_one ) goto DONE;
+y2=t_of_the_way(y2,y3);
+x1=t_of_the_way(x1,x2);
+x2=t_of_the_way(x2,x3);
+x1=t_of_the_way(x1,x2);
+if ( x1>=0 ) we_found_it;
+if ( y2>0 ) y2=0;
+tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
+if ( t>fraction_one ) goto DONE;
+x1=t_of_the_way(x1,x2);
+x2=t_of_the_way(x2,x3);
+if ( t_of_the_way(x1,x2)>=0 ) {
+ t=t_of_the_way(tt,fraction_one); we_found_it;
+}
+
+@ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
+ either |goto found| or |goto done|@>=
+{
+ if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
+ t=mp_make_fraction(mp, y1,y1-y2);
+ x1=t_of_the_way(x1,x2);
+ x2=t_of_the_way(x2,x3);
+ if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
+ } else if ( y3==0 ) {
+ if ( y1==0 ) {
+ @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
+ } else if ( x3>=0 ) {
+ tt=unity; goto FOUND;
+ }
+ }
+ goto DONE;
+}
+
+@ At this point we know that the derivative of |y(t)| is identically zero,
+and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
+traveling east.
+
+@<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
+{
+ t=mp_crossing_point(mp, -x1,-x2,-x3);
+ if ( t<=fraction_one ) we_found_it;
+ if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
+ t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
+ }
+}
+
+@ The intersection of two cubics can be found by an interesting variant
+of the general bisection scheme described in the introduction to
+|crossing_point|.\
+Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$,
+we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
+if an intersection exists. First we find the smallest rectangle that
+encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
+the smallest rectangle that encloses
+$\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
+But if the rectangles do overlap, we bisect the intervals, getting
+new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
+tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
+between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
+finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
+levels of bisection we will have determined the intersection times $t_1$
+and~$t_2$ to $l$~bits of accuracy.
+
+\def\submin{_{\rm min}} \def\submax{_{\rm max}}
+As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
+and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
+themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
+to determine when the enclosing rectangles overlap. Here's why:
+The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
+and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
+if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
+\min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
+overlap if and only if $u\submin\L x\submax$ and
+$x\submin\L u\submax$. Letting
+$$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
+ U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
+we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
+reduces to
+$$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
+Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
+the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
+coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
+because of the overlap condition; i.e., we know that $X\submin$,
+$X\submax$, and their relatives are bounded, hence $X\submax-
+U\submin$ and $X\submin-U\submax$ are bounded.
+
+@ Incidentally, if the given cubics intersect more than once, the process
+just sketched will not necessarily find the lexicographically smallest pair
+$(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
+order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
+$t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
+$a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
+$a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
+Shuffled order agrees with lexicographic order if all pairs of solutions
+$(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
+$t_2<t_2'$; but in general, lexicographic order can be quite different,
+and the bisection algorithm would be substantially less efficient if it were
+constrained by lexicographic order.
+
+For example, suppose that an overlap has been found for $l=3$ and
+$(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
+either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
+Then there is probably an intersection in one of the subintervals
+$(.1011,.011x)$; but lexicographic order would require us to explore
+$(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
+want to store all of the subdivision data for the second path, so the
+subdivisions would have to be regenerated many times. Such inefficiencies
+would be associated with every `1' in the binary representation of~$t_1$.
+
+@ The subdivision process introduces rounding errors, hence we need to
+make a more liberal test for overlap. It is not hard to show that the
+computed values of $U_i$ differ from the truth by at most~$l$, on
+level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
+If $\beta$ is an upper bound on the absolute error in the computed
+components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
+the test `$X\submin-U\submax\L|delx|$' by the more liberal test
+`$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
+
+More accuracy is obtained if we try the algorithm first with |tol=0|;
+the more liberal tolerance is used only if an exact approach fails.
+It is convenient to do this double-take by letting `3' in the preceding
+paragraph be a parameter, which is first 0, then 3.
+
+@<Glob...@>=
+unsigned int tol_step; /* either 0 or 3, usually */
+
+@ We shall use an explicit stack to implement the recursive bisection
+method described above. The |bisect_stack| array will contain numerous 5-word
+packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
+comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
+
+The following macros define the allocation of stack positions to
+the quantities needed for bisection-intersection.
+
+@d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
+@d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
+@d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
+@d stack_min(A) mp->bisect_stack[(A)+3]
+ /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
+@d stack_max(A) mp->bisect_stack[(A)+4]
+ /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
+@d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
+@#
+@d u_packet(A) ((A)-5)
+@d v_packet(A) ((A)-10)
+@d x_packet(A) ((A)-15)
+@d y_packet(A) ((A)-20)
+@d l_packets (mp->bisect_ptr-int_packets)
+@d r_packets mp->bisect_ptr
+@d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
+@d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
+@d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
+@d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
+@d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
+@d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
+@d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
+@d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
+@#
+@d u1l stack_1(ul_packet) /* $U'_1$ */
+@d u2l stack_2(ul_packet) /* $U'_2$ */
+@d u3l stack_3(ul_packet) /* $U'_3$ */
+@d v1l stack_1(vl_packet) /* $V'_1$ */
+@d v2l stack_2(vl_packet) /* $V'_2$ */
+@d v3l stack_3(vl_packet) /* $V'_3$ */
+@d x1l stack_1(xl_packet) /* $X'_1$ */
+@d x2l stack_2(xl_packet) /* $X'_2$ */
+@d x3l stack_3(xl_packet) /* $X'_3$ */
+@d y1l stack_1(yl_packet) /* $Y'_1$ */
+@d y2l stack_2(yl_packet) /* $Y'_2$ */
+@d y3l stack_3(yl_packet) /* $Y'_3$ */
+@d u1r stack_1(ur_packet) /* $U''_1$ */
+@d u2r stack_2(ur_packet) /* $U''_2$ */
+@d u3r stack_3(ur_packet) /* $U''_3$ */
+@d v1r stack_1(vr_packet) /* $V''_1$ */
+@d v2r stack_2(vr_packet) /* $V''_2$ */
+@d v3r stack_3(vr_packet) /* $V''_3$ */
+@d x1r stack_1(xr_packet) /* $X''_1$ */
+@d x2r stack_2(xr_packet) /* $X''_2$ */
+@d x3r stack_3(xr_packet) /* $X''_3$ */
+@d y1r stack_1(yr_packet) /* $Y''_1$ */
+@d y2r stack_2(yr_packet) /* $Y''_2$ */
+@d y3r stack_3(yr_packet) /* $Y''_3$ */
+@#
+@d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
+@d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
+@d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
+@d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
+@d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
+@d int_increment (int_packets+int_packets+5) /* number of stack words per level */
+
+@<Glob...@>=
+integer *bisect_stack;
+unsigned int bisect_ptr;
+
+@ @<Allocate or initialize ...@>=
+mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
+
+@ @<Dealloc variables@>=
+xfree(mp->bisect_stack);
+
+@ @<Check the ``constant''...@>=
+if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
+
+@ Computation of the min and max is a tedious but fairly fast sequence of
+instructions; exactly four comparisons are made in each branch.
+
+@d set_min_max(A)
+ if ( stack_1((A))<0 ) {
+ if ( stack_3((A))>=0 ) {
+ if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
+ else stack_min((A))=stack_1((A));
+ stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
+ if ( stack_max((A))<0 ) stack_max((A))=0;
+ } else {
+ stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
+ if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
+ stack_max((A))=stack_1((A))+stack_2((A));
+ if ( stack_max((A))<0 ) stack_max((A))=0;
+ }
+ } else if ( stack_3((A))<=0 ) {
+ if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
+ else stack_max((A))=stack_1((A));
+ stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
+ if ( stack_min((A))>0 ) stack_min((A))=0;
+ } else {
+ stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
+ if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
+ stack_min((A))=stack_1((A))+stack_2((A));
+ if ( stack_min((A))>0 ) stack_min((A))=0;
+ }
+
+@ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
+the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
+routine uses global variables |cur_t| and |cur_tt| for this purpose;
+after successful completion, |cur_t| and |cur_tt| will contain |unity|
+plus the |scaled| values of $t_1$ and~$t_2$.
+
+The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
+finds no intersection. The routine gives up and gives an approximate answer
+if it has backtracked
+more than 5000 times (otherwise there are cases where several minutes
+of fruitless computation would be possible).
+
+@d max_patience 5000
+
+@<Glob...@>=
+integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
+integer time_to_go; /* this many backtracks before giving up */
+integer max_t; /* maximum of $2^{l+1}$ so far achieved */
+
+@ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
+$B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
+and |(pp,link(pp))|, respectively.
+
+@c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
+ pointer q,qq; /* |link(p)|, |link(pp)| */
+ mp->time_to_go=max_patience; mp->max_t=2;
+ @<Initialize for intersections at level zero@>;
+CONTINUE:
+ while (1) {
+ if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
+ if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
+ if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
+ if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
+ {
+ if ( mp->cur_t>=mp->max_t ){
+ if ( mp->max_t==two ) { /* we've done 17 bisections */
+ mp->cur_t=halfp(mp->cur_t+1);
+ mp->cur_tt=halfp(mp->cur_tt+1);
+ return;
+ }
+ mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
+ }
+ @<Subdivide for a new level of intersection@>;
+ goto CONTINUE;
+ }
+ if ( mp->time_to_go>0 ) {
+ decr(mp->time_to_go);
+ } else {
+ while ( mp->appr_t<unity ) {
+ mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
+ }
+ mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
+ }
+ @<Advance to the next pair |(cur_t,cur_tt)|@>;
+ }
+}
+
+@ The following variables are global, although they are used only by
+|cubic_intersection|, because it is necessary on some machines to
+split |cubic_intersection| up into two procedures.
+
+@<Glob...@>=
+integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
+integer tol; /* bound on the uncertainty in the overlap test */
+unsigned int uv;
+unsigned int xy; /* pointers to the current packets of interest */
+integer three_l; /* |tol_step| times the bisection level */
+integer appr_t;integer appr_tt; /* best approximations known to the answers */
+
+@ We shall assume that the coordinates are sufficiently non-extreme that
+integer overflow will not occur.
+@^overflow in arithmetic@>
+
+@<Initialize for intersections at level zero@>=
+q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
+u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
+u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
+v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
+v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
+x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
+x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
+y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
+y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
+mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
+mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
+mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
+
+@ @<Subdivide for a new level of intersection@>=
+stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
+stack_uv=mp->uv; stack_xy=mp->xy;
+mp->bisect_ptr=mp->bisect_ptr+int_increment;
+mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
+u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
+u2l=half(u1l+stack_2(u_packet(mp->uv)));
+u2r=half(u3r+stack_2(u_packet(mp->uv)));
+u3l=half(u2l+u2r); u1r=u3l;
+set_min_max(ul_packet); set_min_max(ur_packet);
+v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
+v2l=half(v1l+stack_2(v_packet(mp->uv)));
+v2r=half(v3r+stack_2(v_packet(mp->uv)));
+v3l=half(v2l+v2r); v1r=v3l;
+set_min_max(vl_packet); set_min_max(vr_packet);
+x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
+x2l=half(x1l+stack_2(x_packet(mp->xy)));
+x2r=half(x3r+stack_2(x_packet(mp->xy)));
+x3l=half(x2l+x2r); x1r=x3l;
+set_min_max(xl_packet); set_min_max(xr_packet);
+y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
+y2l=half(y1l+stack_2(y_packet(mp->xy)));
+y2r=half(y3r+stack_2(y_packet(mp->xy)));
+y3l=half(y2l+y2r); y1r=y3l;
+set_min_max(yl_packet); set_min_max(yr_packet);
+mp->uv=l_packets; mp->xy=l_packets;
+mp->delx+=mp->delx; mp->dely+=mp->dely;
+mp->tol=mp->tol-mp->three_l+mp->tol_step;
+mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
+
+@ @<Advance to the next pair |(cur_t,cur_tt)|@>=
+NOT_FOUND:
+if ( odd(mp->cur_tt) ) {
+ if ( odd(mp->cur_t) ) {
+ @<Descend to the previous level and |goto not_found|@>;
+ } else {
+ incr(mp->cur_t);
+ mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
+ +stack_3(u_packet(mp->uv));
+ mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
+ +stack_3(v_packet(mp->uv));
+ mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
+ decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
+ /* switch from |r_packets| to |l_packets| */
+ mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
+ +stack_3(x_packet(mp->xy));
+ mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
+ +stack_3(y_packet(mp->xy));
+ }
+} else {
+ incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
+ mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
+ -stack_3(x_packet(mp->xy));
+ mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
+ -stack_3(y_packet(mp->xy));
+ mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
+}
+
+@ @<Descend to the previous level...@>=
+{
+ mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
+ if ( mp->cur_t==0 ) return;
+ mp->bisect_ptr=mp->bisect_ptr-int_increment;
+ mp->three_l=mp->three_l-mp->tol_step;
+ mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
+ mp->uv=stack_uv; mp->xy=stack_xy;
+ goto NOT_FOUND;
+}
+
+@ The |path_intersection| procedure is much simpler.
+It invokes |cubic_intersection| in lexicographic order until finding a
+pair of cubics that intersect. The final intersection times are placed in
+|cur_t| and~|cur_tt|.
+
+@c void mp_path_intersection (MP mp,pointer h, pointer hh) {
+ pointer p,pp; /* link registers that traverse the given paths */
+ integer n,nn; /* integer parts of intersection times, minus |unity| */
+ @<Change one-point paths into dead cycles@>;
+ mp->tol_step=0;
+ do {
+ n=-unity; p=h;
+ do {
+ if ( right_type(p)!=mp_endpoint ) {
+ nn=-unity; pp=hh;
+ do {
+ if ( right_type(pp)!=mp_endpoint ) {
+ mp_cubic_intersection(mp, p,pp);
+ if ( mp->cur_t>0 ) {
+ mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
+ return;
+ }
+ }
+ nn=nn+unity; pp=link(pp);
+ } while (pp!=hh);
+ }
+ n=n+unity; p=link(p);
+ } while (p!=h);
+ mp->tol_step=mp->tol_step+3;
+ } while (mp->tol_step<=3);
+ mp->cur_t=-unity; mp->cur_tt=-unity;
+}
+
+@ @<Change one-point paths...@>=
+if ( right_type(h)==mp_endpoint ) {
+ right_x(h)=x_coord(h); left_x(h)=x_coord(h);
+ right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
+}
+if ( right_type(hh)==mp_endpoint ) {
+ right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
+ right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
+}
+
+@* \[24] Dynamic linear equations.
+\MP\ users define variables implicitly by stating equations that should be
+satisfied; the computer is supposed to be smart enough to solve those equations.
+And indeed, the computer tries valiantly to do so, by distinguishing five
+different types of numeric values:
+
+\smallskip\hang
+|type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
+of the variable whose address is~|p|.
+
+\smallskip\hang
+|type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
+points to a {\sl dependency list\/} that expresses the value of variable~|p|
+as a |scaled| number plus a sum of independent variables with |fraction|
+coefficients.
+
+\smallskip\hang
+|type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
+number'' reflecting the time this variable was first used in an equation;
+also |0<=m<64|, and each dependent variable
+that refers to this one is actually referring to the future value of
+this variable times~$2^m$. (Usually |m=0|, but higher degrees of
+scaling are sometimes needed to keep the coefficients in dependency lists
+from getting too large. The value of~|m| will always be even.)
+
+\smallskip\hang
+|type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
+equation before, but it has been explicitly declared to be numeric.
+
+\smallskip\hang
+|type(p)=undefined| means that variable |p| hasn't appeared before.
+
+\smallskip\noindent
+We have actually discussed these five types in the reverse order of their
+history during a computation: Once |known|, a variable never again
+becomes |dependent|; once |dependent|, it almost never again becomes
+|mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
+and once |mp_numeric_type|, it never again becomes |undefined| (except
+of course when the user specifically decides to scrap the old value
+and start again). A backward step may, however, take place: Sometimes
+a |dependent| variable becomes |mp_independent| again, when one of the
+independent variables it depends on is reverting to |undefined|.
+
+
+The next patch detects overflow of independent-variable serial
+numbers. Diagnosed and patched by Thorsten Dahlheimer.
+
+@d s_scale 64 /* the serial numbers are multiplied by this factor */
+@d new_indep(A) /* create a new independent variable */
+ { if ( mp->serial_no>el_gordo-s_scale )
+ mp_fatal_error(mp, "variable instance identifiers exhausted");
+ type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
+ value((A))=mp->serial_no;
+ }
+
+@<Glob...@>=
+integer serial_no; /* the most recent serial number, times |s_scale| */
+
+@ @<Make variable |q+s| newly independent@>=new_indep(q+s)
+
+@ But how are dependency lists represented? It's simple: The linear combination
+$\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
+|q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
+@t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
+of $\alpha_1$; and |link(p)| points to the dependency list
+$\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
+then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
+The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
+they appear in decreasing order of their |value| fields (i.e., of
+their serial numbers). \ (It is convenient to use decreasing order,
+since |value(null)=0|. If the independent variables were not sorted by
+serial number but by some other criterion, such as their location in |mem|,
+the equation-solving mechanism would be too system-dependent, because
+the ordering can affect the computed results.)
+
+The |link| field in the node that contains the constant term $\beta$ is
+called the {\sl final link\/} of the dependency list. \MP\ maintains
+a doubly-linked master list of all dependency lists, in terms of a permanently
+allocated node
+in |mem| called |dep_head|. If there are no dependencies, we have
+|link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
+otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
+and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
+points to its dependency list. If the final link of that dependency list
+occurs in location~|q|, then |link(q)| points to the next dependent
+variable (say~|r|); and we have |prev_dep(r)=q|, etc.
+
+@d dep_list(A) link(value_loc((A)))
+ /* half of the |value| field in a |dependent| variable */
+@d prev_dep(A) info(value_loc((A)))
+ /* the other half; makes a doubly linked list */
+@d dep_node_size 2 /* the number of words per dependency node */
+
+@<Initialize table entries...@>= mp->serial_no=0;
+link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
+info(dep_head)=null; dep_list(dep_head)=null;
+
+@ Actually the description above contains a little white lie. There's
+another kind of variable called |mp_proto_dependent|, which is
+just like a |dependent| one except that the $\alpha$ coefficients
+in its dependency list are |scaled| instead of being fractions.
+Proto-dependency lists are mixed with dependency lists in the
+nodes reachable from |dep_head|.
+
+@ Here is a procedure that prints a dependency list in symbolic form.
+The second parameter should be either |dependent| or |mp_proto_dependent|,
+to indicate the scaling of the coefficients.
+
+@<Declare subroutines for printing expressions@>=
+void mp_print_dependency (MP mp,pointer p, small_number t) {
+ integer v; /* a coefficient */
+ pointer pp,q; /* for list manipulation */
+ pp=p;
+ while (1) {
+ v=abs(value(p)); q=info(p);
+ if ( q==null ) { /* the constant term */
+ if ( (v!=0)||(p==pp) ) {
+ if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
+ mp_print_scaled(mp, value(p));
+ }
+ return;
+ }
+ @<Print the coefficient, unless it's $\pm1.0$@>;
+ if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
+@:this can't happen dep}{\quad dep@>
+ mp_print_variable_name(mp, q); v=value(q) % s_scale;
+ while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
+ p=link(p);
+ }
+}
+
+@ @<Print the coefficient, unless it's $\pm1.0$@>=
+if ( value(p)<0 ) mp_print_char(mp, '-');
+else if ( p!=pp ) mp_print_char(mp, '+');
+if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
+if ( v!=unity ) mp_print_scaled(mp, v)
+
+@ The maximum absolute value of a coefficient in a given dependency list
+is returned by the following simple function.
+
+@c fraction mp_max_coef (MP mp,pointer p) {
+ fraction x; /* the maximum so far */
+ x=0;
+ while ( info(p)!=null ) {
+ if ( abs(value(p))>x ) x=abs(value(p));
+ p=link(p);
+ }
+ return x;
+}
+
+@ One of the main operations needed on dependency lists is to add a multiple
+of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
+to dependency lists and |f| is a fraction.
+
+If the coefficient of any independent variable becomes |coef_bound| or
+more, in absolute value, this procedure changes the type of that variable
+to `|independent_needing_fix|', and sets the global variable |fix_needed|
+to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
+$\mu^2+\mu<8$; this means that the numbers we deal with won't
+get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
+2.3723$, the safer value 7/3 is taken as the threshold.)
+
+The changes mentioned in the preceding paragraph are actually done only if
+the global variable |watch_coefs| is |true|. But it usually is; in fact,
+it is |false| only when \MP\ is making a dependency list that will soon
+be equated to zero.
+
+Several procedures that act on dependency lists, including |p_plus_fq|,
+set the global variable |dep_final| to the final (constant term) node of
+the dependency list that they produce.
+
+@d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
+@d independent_needing_fix 0
+
+@<Glob...@>=
+boolean fix_needed; /* does at least one |independent| variable need scaling? */
+boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
+pointer dep_final; /* location of the constant term and final link */
+
+@ @<Set init...@>=
+mp->fix_needed=false; mp->watch_coefs=true;
+
+@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
+set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
+case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
+should be |mp_proto_dependent| if |q| is a proto-dependency list.
+
+List |q| is unchanged by the operation; but list |p| is totally destroyed.
+
+The final link of the dependency list or proto-dependency list returned
+by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
+constant term of the result will be located in the same |mem| location
+as the original constant term of~|p|.
+
+Coefficients of the result are assumed to be zero if they are less than
+a certain threshold. This compensates for inevitable rounding errors,
+and tends to make more variables `|known|'. The threshold is approximately
+$10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
+proto-dependencies.
+
+@d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
+@d half_fraction_threshold 1342 /* half of |fraction_threshold| */
+@d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
+@d half_scaled_threshold 4 /* half of |scaled_threshold| */
+
+@<Declare basic dependency-list subroutines@>=
+pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
+ pointer q, small_number t, small_number tt) ;
+
+@ @c
+pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
+ pointer q, small_number t, small_number tt) {
+ pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
+ pointer r,s; /* for list manipulation */
+ integer threshold; /* defines a neighborhood of zero */
+ integer v; /* temporary register */
+ if ( t==mp_dependent ) threshold=fraction_threshold;
+ else threshold=scaled_threshold;
+ r=temp_head; pp=info(p); qq=info(q);
+ while (1) {
+ if ( pp==qq ) {
+ if ( pp==null ) {
+ break;
+ } else {
+ @<Contribute a term from |p|, plus |f| times the
+ corresponding term from |q|@>
+ }
+ } else if ( value(pp)<value(qq) ) {
+ @<Contribute a term from |q|, multiplied by~|f|@>
+ } else {
+ link(r)=p; r=p; p=link(p); pp=info(p);
+ }
+ }
+ if ( t==mp_dependent )
+ value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
+ else
+ value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
+ link(r)=p; mp->dep_final=p;
+ return link(temp_head);
+}
+
+@ @<Contribute a term from |p|, plus |f|...@>=
+{
+ if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
+ else v=value(p)+mp_take_scaled(mp, f,value(q));
+ value(p)=v; s=p; p=link(p);
+ if ( abs(v)<threshold ) {
+ mp_free_node(mp, s,dep_node_size);
+ } else {
+ if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
+ type(qq)=independent_needing_fix; mp->fix_needed=true;
+ }
+ link(r)=s; r=s;
+ };
+ pp=info(p); q=link(q); qq=info(q);
+}
+
+@ @<Contribute a term from |q|, multiplied by~|f|@>=
+{
+ if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
+ else v=mp_take_scaled(mp, f,value(q));
+ if ( abs(v)>halfp(threshold) ) {
+ s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
+ if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
+ type(qq)=independent_needing_fix; mp->fix_needed=true;
+ }
+ link(r)=s; r=s;
+ }
+ q=link(q); qq=info(q);
+}
+
+@ It is convenient to have another subroutine for the special case
+of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
+both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
+
+@c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
+ pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
+ pointer r,s; /* for list manipulation */
+ integer threshold; /* defines a neighborhood of zero */
+ integer v; /* temporary register */
+ if ( t==mp_dependent ) threshold=fraction_threshold;
+ else threshold=scaled_threshold;
+ r=temp_head; pp=info(p); qq=info(q);
+ while (1) {
+ if ( pp==qq ) {
+ if ( pp==null ) {
+ break;
+ } else {
+ @<Contribute a term from |p|, plus the
+ corresponding term from |q|@>
+ }
+ } else {
+ if ( value(pp)<value(qq) ) {
+ s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
+ q=link(q); qq=info(q); link(r)=s; r=s;
+ } else {
+ link(r)=p; r=p; p=link(p); pp=info(p);
+ }
+ }
+ }
+ value(p)=mp_slow_add(mp, value(p),value(q));
+ link(r)=p; mp->dep_final=p;
+ return link(temp_head);
+}
+
+@ @<Contribute a term from |p|, plus the...@>=
+{
+ v=value(p)+value(q);
+ value(p)=v; s=p; p=link(p); pp=info(p);
+ if ( abs(v)<threshold ) {
+ mp_free_node(mp, s,dep_node_size);
+ } else {
+ if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
+ type(qq)=independent_needing_fix; mp->fix_needed=true;
+ }
+ link(r)=s; r=s;
+ }
+ q=link(q); qq=info(q);
+}
+
+@ A somewhat simpler routine will multiply a dependency list
+by a given constant~|v|. The constant is either a |fraction| less than
+|fraction_one|, or it is |scaled|. In the latter case we might be forced to
+convert a dependency list to a proto-dependency list.
+Parameters |t0| and |t1| are the list types before and after;
+they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
+and |v_is_scaled=true|.
+
+@c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
+ small_number t1, boolean v_is_scaled) {
+ pointer r,s; /* for list manipulation */
+ integer w; /* tentative coefficient */
+ integer threshold;
+ boolean scaling_down;
+ if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
+ if ( t1==mp_dependent ) threshold=half_fraction_threshold;
+ else threshold=half_scaled_threshold;
+ r=temp_head;
+ while ( info(p)!=null ) {
+ if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
+ else w=mp_take_scaled(mp, v,value(p));
+ if ( abs(w)<=threshold ) {
+ s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
+ } else {
+ if ( abs(w)>=coef_bound ) {
+ mp->fix_needed=true; type(info(p))=independent_needing_fix;
+ }
+ link(r)=p; r=p; value(p)=w; p=link(p);
+ }
+ }
+ link(r)=p;
+ if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
+ else value(p)=mp_take_fraction(mp, value(p),v);
+ return link(temp_head);
+}
+
+@ Similarly, we sometimes need to divide a dependency list
+by a given |scaled| constant.
+
+@<Declare basic dependency-list subroutines@>=
+pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
+ t0, small_number t1) ;
+
+@ @c
+pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
+ t0, small_number t1) {
+ pointer r,s; /* for list manipulation */
+ integer w; /* tentative coefficient */
+ integer threshold;
+ boolean scaling_down;
+ if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
+ if ( t1==mp_dependent ) threshold=half_fraction_threshold;
+ else threshold=half_scaled_threshold;
+ r=temp_head;
+ while ( info( p)!=null ) {
+ if ( scaling_down ) {
+ if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
+ else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
+ } else {
+ w=mp_make_scaled(mp, value(p),v);
+ }
+ if ( abs(w)<=threshold ) {
+ s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
+ } else {
+ if ( abs(w)>=coef_bound ) {
+ mp->fix_needed=true; type(info(p))=independent_needing_fix;
+ }
+ link(r)=p; r=p; value(p)=w; p=link(p);
+ }
+ }
+ link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
+ return link(temp_head);
+}
+
+@ Here's another utility routine for dependency lists. When an independent
+variable becomes dependent, we want to remove it from all existing
+dependencies. The |p_with_x_becoming_q| function computes the
+dependency list of~|p| after variable~|x| has been replaced by~|q|.
+
+This procedure has basically the same calling conventions as |p_plus_fq|:
+List~|q| is unchanged; list~|p| is destroyed; the constant node and the
+final link are inherited from~|p|; and the fourth parameter tells whether
+or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
+is not altered if |x| does not occur in list~|p|.
+
+@c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
+ pointer x, pointer q, small_number t) {
+ pointer r,s; /* for list manipulation */
+ integer v; /* coefficient of |x| */
+ integer sx; /* serial number of |x| */
+ s=p; r=temp_head; sx=value(x);
+ while ( value(info(s))>sx ) { r=s; s=link(s); };
+ if ( info(s)!=x ) {
+ return p;
+ } else {
+ link(temp_head)=p; link(r)=link(s); v=value(s);
+ mp_free_node(mp, s,dep_node_size);
+ return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
+ }
+}
+
+@ Here's a simple procedure that reports an error when a variable
+has just received a known value that's out of the required range.
+
+@<Declare basic dependency-list subroutines@>=
+void mp_val_too_big (MP mp,scaled x) ;
+
+@ @c void mp_val_too_big (MP mp,scaled x) {
+ if ( mp->internal[mp_warning_check]>0 ) {
+ print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
+@.Value is too large@>
+ help4("The equation I just processed has given some variable")
+ ("a value of 4096 or more. Continue and I'll try to cope")
+ ("with that big value; but it might be dangerous.")
+ ("(Set warningcheck:=0 to suppress this message.)");
+ mp_error(mp);
+ }
+}
+
+@ When a dependent variable becomes known, the following routine
+removes its dependency list. Here |p| points to the variable, and
+|q| points to the dependency list (which is one node long).
+
+@<Declare basic dependency-list subroutines@>=
+void mp_make_known (MP mp,pointer p, pointer q) ;
+
+@ @c void mp_make_known (MP mp,pointer p, pointer q) {
+ int t; /* the previous type */
+ prev_dep(link(q))=prev_dep(p);
+ link(prev_dep(p))=link(q); t=type(p);
+ type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
+ if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
+ if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
+@:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
+ mp_print_variable_name(mp, p);
+ mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
+ mp_end_diagnostic(mp, false);
+ }
+ if (( mp->cur_exp==p ) && mp->cur_type==t ) {
+ mp->cur_type=mp_known; mp->cur_exp=value(p);
+ mp_free_node(mp, p,value_node_size);
+ }
+}
+
+@ The |fix_dependencies| routine is called into action when |fix_needed|
+has been triggered. The program keeps a list~|s| of independent variables
+whose coefficients must be divided by~4.
+
+In unusual cases, this fixup process might reduce one or more coefficients
+to zero, so that a variable will become known more or less by default.
+
+@<Declare basic dependency-list subroutines@>=
+void mp_fix_dependencies (MP mp);
+
+@ @c void mp_fix_dependencies (MP mp) {
+ pointer p,q,r,s,t; /* list manipulation registers */
+ pointer x; /* an independent variable */
+ r=link(dep_head); s=null;
+ while ( r!=dep_head ){
+ t=r;
+ @<Run through the dependency list for variable |t|, fixing
+ all nodes, and ending with final link~|q|@>;
+ r=link(q);
+ if ( q==dep_list(t) ) mp_make_known(mp, t,q);
+ }
+ while ( s!=null ) {
+ p=link(s); x=info(s); free_avail(s); s=p;
+ type(x)=mp_independent; value(x)=value(x)+2;
+ }
+ mp->fix_needed=false;
+}
+
+@ @d independent_being_fixed 1 /* this variable already appears in |s| */
+
+@<Run through the dependency list for variable |t|...@>=
+r=value_loc(t); /* |link(r)=dep_list(t)| */
+while (1) {
+ q=link(r); x=info(q);
+ if ( x==null ) break;
+ if ( type(x)<=independent_being_fixed ) {
+ if ( type(x)<independent_being_fixed ) {
+ p=mp_get_avail(mp); link(p)=s; s=p;
+ info(s)=x; type(x)=independent_being_fixed;
+ }
+ value(q)=value(q) / 4;
+ if ( value(q)==0 ) {
+ link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
+ }
+ }
+ r=q;
+}
+
+
+@ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
+linking it into the list of all known dependencies. We assume that
+|dep_final| points to the final node of list~|p|.
+
+@c void mp_new_dep (MP mp,pointer q, pointer p) {
+ pointer r; /* what used to be the first dependency */
+ dep_list(q)=p; prev_dep(q)=dep_head;
+ r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
+ link(dep_head)=q;
+}
+
+@ Here is one of the ways a dependency list gets started.
+The |const_dependency| routine produces a list that has nothing but
+a constant term.
+
+@c pointer mp_const_dependency (MP mp, scaled v) {
+ mp->dep_final=mp_get_node(mp, dep_node_size);
+ value(mp->dep_final)=v; info(mp->dep_final)=null;
+ return mp->dep_final;
+}
+
+@ And here's a more interesting way to start a dependency list from scratch:
+The parameter to |single_dependency| is the location of an
+independent variable~|x|, and the result is the simple dependency list
+`|x+0|'.
+
+In the unlikely event that the given independent variable has been doubled so
+often that we can't refer to it with a nonzero coefficient,
+|single_dependency| returns the simple list `0'. This case can be
+recognized by testing that the returned list pointer is equal to
+|dep_final|.
+
+@c pointer mp_single_dependency (MP mp,pointer p) {
+ pointer q; /* the new dependency list */
+ integer m; /* the number of doublings */
+ m=value(p) % s_scale;
+ if ( m>28 ) {
+ return mp_const_dependency(mp, 0);
+ } else {
+ q=mp_get_node(mp, dep_node_size);
+ value(q)=two_to_the(28-m); info(q)=p;
+ link(q)=mp_const_dependency(mp, 0);
+ return q;
+ }
+}
+
+@ We sometimes need to make an exact copy of a dependency list.
+
+@c pointer mp_copy_dep_list (MP mp,pointer p) {
+ pointer q; /* the new dependency list */
+ q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
+ while (1) {
+ info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
+ if ( info(mp->dep_final)==null ) break;
+ link(mp->dep_final)=mp_get_node(mp, dep_node_size);
+ mp->dep_final=link(mp->dep_final); p=link(p);
+ }
+ return q;
+}
+
+@ But how do variables normally become known? Ah, now we get to the heart of the
+equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
+or |mp_proto_dependent| list,~|p|, in which at least one independent variable
+appears. It equates this list to zero, by choosing an independent variable
+with the largest coefficient and making it dependent on the others. The
+newly dependent variable is eliminated from all current dependencies,
+thereby possibly making other dependent variables known.
+
+The given list |p| is, of course, totally destroyed by all this processing.
+
+@c void mp_linear_eq (MP mp, pointer p, small_number t) {
+ pointer q,r,s; /* for link manipulation */
+ pointer x; /* the variable that loses its independence */
+ integer n; /* the number of times |x| had been halved */
+ integer v; /* the coefficient of |x| in list |p| */
+ pointer prev_r; /* lags one step behind |r| */
+ pointer final_node; /* the constant term of the new dependency list */
+ integer w; /* a tentative coefficient */
+ @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
+ x=info(q); n=value(x) % s_scale;
+ @<Divide list |p| by |-v|, removing node |q|@>;
+ if ( mp->internal[mp_tracing_equations]>0 ) {
+ @<Display the new dependency@>;
+ }
+ @<Simplify all existing dependencies by substituting for |x|@>;
+ @<Change variable |x| from |independent| to |dependent| or |known|@>;
+ if ( mp->fix_needed ) mp_fix_dependencies(mp);
+}
+
+@ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
+q=p; r=link(p); v=value(q);
+while ( info(r)!=null ) {
+ if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
+ r=link(r);
+}
+
+@ Here we want to change the coefficients from |scaled| to |fraction|,
+except in the constant term. In the common case of a trivial equation
+like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
+
+@<Divide list |p| by |-v|, removing node |q|@>=
+s=temp_head; link(s)=p; r=p;
+do {
+ if ( r==q ) {
+ link(s)=link(r); mp_free_node(mp, r,dep_node_size);
+ } else {
+ w=mp_make_fraction(mp, value(r),v);
+ if ( abs(w)<=half_fraction_threshold ) {
+ link(s)=link(r); mp_free_node(mp, r,dep_node_size);
+ } else {
+ value(r)=-w; s=r;
+ }
+ }
+ r=link(s);
+} while (info(r)!=null);
+if ( t==mp_proto_dependent ) {
+ value(r)=-mp_make_scaled(mp, value(r),v);
+} else if ( v!=-fraction_one ) {
+ value(r)=-mp_make_fraction(mp, value(r),v);
+}
+final_node=r; p=link(temp_head)
+
+@ @<Display the new dependency@>=
+if ( mp_interesting(mp, x) ) {
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
+ mp_print_variable_name(mp, x);
+@:]]]\#\#_}{\.{\#\#}@>
+ w=n;
+ while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
+ mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
+ mp_end_diagnostic(mp, false);
+}
+
+@ @<Simplify all existing dependencies by substituting for |x|@>=
+prev_r=dep_head; r=link(dep_head);
+while ( r!=dep_head ) {
+ s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
+ if ( info(q)==null ) {
+ mp_make_known(mp, r,q);
+ } else {
+ dep_list(r)=q;
+ do { q=link(q); } while (info(q)!=null);
+ prev_r=q;
+ }
+ r=link(prev_r);
+}
+
+@ @<Change variable |x| from |independent| to |dependent| or |known|@>=
+if ( n>0 ) @<Divide list |p| by $2^n$@>;
+if ( info(p)==null ) {
+ type(x)=mp_known;
+ value(x)=value(p);
+ if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
+ mp_free_node(mp, p,dep_node_size);
+ if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
+ mp->cur_exp=value(x); mp->cur_type=mp_known;
+ mp_free_node(mp, x,value_node_size);
+ }
+} else {
+ type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
+ if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
+}
+
+@ @<Divide list |p| by $2^n$@>=
+{
+ s=temp_head; link(temp_head)=p; r=p;
+ do {
+ if ( n>30 ) w=0;
+ else w=value(r) / two_to_the(n);
+ if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
+ link(s)=link(r);
+ mp_free_node(mp, r,dep_node_size);
+ } else {
+ value(r)=w; s=r;
+ }
+ r=link(s);
+ } while (info(s)!=null);
+ p=link(temp_head);
+}
+
+@ The |check_mem| procedure, which is used only when \MP\ is being
+debugged, makes sure that the current dependency lists are well formed.
+
+@<Check the list of linear dependencies@>=
+q=dep_head; p=link(q);
+while ( p!=dep_head ) {
+ if ( prev_dep(p)!=q ) {
+ mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
+@.Bad PREVDEP...@>
+ }
+ p=dep_list(p);
+ while (1) {
+ r=info(p); q=p; p=link(q);
+ if ( r==null ) break;
+ if ( value(info(p))>=value(r) ) {
+ mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
+@.Out of order...@>
+ }
+ }
+}
+
+@* \[25] Dynamic nonlinear equations.
+Variables of numeric type are maintained by the general scheme of
+independent, dependent, and known values that we have just studied;
+and the components of pair and transform variables are handled in the
+same way. But \MP\ also has five other types of values: \&{boolean},
+\&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
+
+Equations are allowed between nonlinear quantities, but only in a
+simple form. Two variables that haven't yet been assigned values are
+either equal to each other, or they're not.
+
+Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
+similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
+|mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
+|null| (which means that no other variables are equivalent to this one), or
+it points to another variable of the same undefined type. The pointers in the
+latter case form a cycle of nodes, which we shall call a ``ring.''
+Rings of undefined variables may include capsules, which arise as
+intermediate results within expressions or as \&{expr} parameters to macros.
+
+When one member of a ring receives a value, the same value is given to
+all the other members. In the case of paths and pictures, this implies
+making separate copies of a potentially large data structure; users should
+restrain their enthusiasm for such generality, unless they have lots and
+lots of memory space.
+
+@ The following procedure is called when a capsule node is being
+added to a ring (e.g., when an unknown variable is mentioned in an expression).
+
+@c pointer mp_new_ring_entry (MP mp,pointer p) {
+ pointer q; /* the new capsule node */
+ q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
+ type(q)=type(p);
+ if ( value(p)==null ) value(q)=p; else value(q)=value(p);
+ value(p)=q;
+ return q;
+}
+
+@ Conversely, we might delete a capsule or a variable before it becomes known.
+The following procedure simply detaches a quantity from its ring,
+without recycling the storage.
+
+@<Declare the recycling subroutines@>=
+void mp_ring_delete (MP mp,pointer p) {
+ pointer q;
+ q=value(p);
+ if ( q!=null ) if ( q!=p ){
+ while ( value(q)!=p ) q=value(q);
+ value(q)=value(p);
+ }
+}
+
+@ Eventually there might be an equation that assigns values to all of the
+variables in a ring. The |nonlinear_eq| subroutine does the necessary
+propagation of values.
+
+If the parameter |flush_p| is |true|, node |p| itself needn't receive a
+value, it will soon be recycled.
+
+@c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
+ small_number t; /* the type of ring |p| */
+ pointer q,r; /* link manipulation registers */
+ t=type(p)-unknown_tag; q=value(p);
+ if ( flush_p ) type(p)=mp_vacuous; else p=q;
+ do {
+ r=value(q); type(q)=t;
+ switch (t) {
+ case mp_boolean_type: value(q)=v; break;
+ case mp_string_type: value(q)=v; add_str_ref(v); break;
+ case mp_pen_type: value(q)=copy_pen(v); break;
+ case mp_path_type: value(q)=mp_copy_path(mp, v); break;
+ case mp_picture_type: value(q)=v; add_edge_ref(v); break;
+ } /* there ain't no more cases */
+ q=r;
+ } while (q!=p);
+}
+
+@ If two members of rings are equated, and if they have the same type,
+the |ring_merge| procedure is called on to make them equivalent.
+
+@c void mp_ring_merge (MP mp,pointer p, pointer q) {
+ pointer r; /* traverses one list */
+ r=value(p);
+ while ( r!=p ) {
+ if ( r==q ) {
+ @<Exclaim about a redundant equation@>;
+ return;
+ };
+ r=value(r);
+ }
+ r=value(p); value(p)=value(q); value(q)=r;
+}
+
+@ @<Exclaim about a redundant equation@>=
+{
+ print_err("Redundant equation");
+@.Redundant equation@>
+ help2("I already knew that this equation was true.")
+ ("But perhaps no harm has been done; let's continue.");
+ mp_put_get_error(mp);
+}
+
+@* \[26] Introduction to the syntactic routines.
+Let's pause a moment now and try to look at the Big Picture.
+The \MP\ program consists of three main parts: syntactic routines,
+semantic routines, and output routines. The chief purpose of the
+syntactic routines is to deliver the user's input to the semantic routines,
+while parsing expressions and locating operators and operands. The
+semantic routines act as an interpreter responding to these operators,
+which may be regarded as commands. And the output routines are
+periodically called on to produce compact font descriptions that can be
+used for typesetting or for making interim proof drawings. We have
+discussed the basic data structures and many of the details of semantic
+operations, so we are good and ready to plunge into the part of \MP\ that
+actually controls the activities.
+
+Our current goal is to come to grips with the |get_next| procedure,
+which is the keystone of \MP's input mechanism. Each call of |get_next|
+sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
+representing the next input token.
+$$\vbox{\halign{#\hfil\cr
+ \hbox{|cur_cmd| denotes a command code from the long list of codes
+ given earlier;}\cr
+ \hbox{|cur_mod| denotes a modifier of the command code;}\cr
+ \hbox{|cur_sym| is the hash address of the symbolic token that was
+ just scanned,}\cr
+ \hbox{\qquad or zero in the case of a numeric or string
+ or capsule token.}\cr}}$$
+Underlying this external behavior of |get_next| is all the machinery
+necessary to convert from character files to tokens. At a given time we
+may be only partially finished with the reading of several files (for
+which \&{input} was specified), and partially finished with the expansion
+of some user-defined macros and/or some macro parameters, and partially
+finished reading some text that the user has inserted online,
+and so on. When reading a character file, the characters must be
+converted to tokens; comments and blank spaces must
+be removed, numeric and string tokens must be evaluated.
+
+To handle these situations, which might all be present simultaneously,
+\MP\ uses various stacks that hold information about the incomplete
+activities, and there is a finite state control for each level of the
+input mechanism. These stacks record the current state of an implicitly
+recursive process, but the |get_next| procedure is not recursive.
+
+@<Glob...@>=
+eight_bits cur_cmd; /* current command set by |get_next| */
+integer cur_mod; /* operand of current command */
+halfword cur_sym; /* hash address of current symbol */
+
+@ The |print_cmd_mod| routine prints a symbolic interpretation of a
+command code and its modifier.
+It consists of a rather tedious sequence of print
+commands, and most of it is essentially an inverse to the |primitive|
+routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
+all of this procedure appears elsewhere in the program, together with the
+corresponding |primitive| calls.
+
+@<Declare the procedure called |print_cmd_mod|@>=
+void mp_print_cmd_mod (MP mp,integer c, integer m) {
+ switch (c) {
+ @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
+ default: mp_print(mp, "[unknown command code!]"); break;
+ }
+}
+
+@ Here is a procedure that displays a given command in braces, in the
+user's transcript file.
+
+@d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
+
+@c
+void mp_show_cmd_mod (MP mp,integer c, integer m) {
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
+ mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
+ mp_end_diagnostic(mp, false);
+}
+
+@* \[27] Input stacks and states.
+The state of \MP's input mechanism appears in the input stack, whose
+entries are records with five fields, called |index|, |start|, |loc|,
+|limit|, and |name|. The top element of this stack is maintained in a
+global variable for which no subscripting needs to be done; the other
+elements of the stack appear in an array. Hence the stack is declared thus:
+
+@<Types...@>=
+typedef struct {
+ quarterword index_field;
+ halfword start_field, loc_field, limit_field, name_field;
+} in_state_record;
+
+@ @<Glob...@>=
+in_state_record *input_stack;
+integer input_ptr; /* first unused location of |input_stack| */
+integer max_in_stack; /* largest value of |input_ptr| when pushing */
+in_state_record cur_input; /* the ``top'' input state */
+int stack_size; /* maximum number of simultaneous input sources */
+
+@ @<Allocate or initialize ...@>=
+mp->stack_size = 300;
+mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
+
+@ @<Dealloc variables@>=
+xfree(mp->input_stack);
+
+@ We've already defined the special variable |loc==cur_input.loc_field|
+in our discussion of basic input-output routines. The other components of
+|cur_input| are defined in the same way:
+
+@d index mp->cur_input.index_field /* reference for buffer information */
+@d start mp->cur_input.start_field /* starting position in |buffer| */
+@d limit mp->cur_input.limit_field /* end of current line in |buffer| */
+@d name mp->cur_input.name_field /* name of the current file */
+
+@ Let's look more closely now at the five control variables
+(|index|,~|start|,~|loc|,~|limit|,~|name|),
+assuming that \MP\ is reading a line of characters that have been input
+from some file or from the user's terminal. There is an array called
+|buffer| that acts as a stack of all lines of characters that are
+currently being read from files, including all lines on subsidiary
+levels of the input stack that are not yet completed. \MP\ will return to
+the other lines when it is finished with the present input file.
+
+(Incidentally, on a machine with byte-oriented addressing, it would be
+appropriate to combine |buffer| with the |str_pool| array,
+letting the buffer entries grow downward from the top of the string pool
+and checking that these two tables don't bump into each other.)
+
+The line we are currently working on begins in position |start| of the
+buffer; the next character we are about to read is |buffer[loc]|; and
+|limit| is the location of the last character present. We always have
+|loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
+that the end of a line is easily sensed.
+
+The |name| variable is a string number that designates the name of
+the current file, if we are reading an ordinary text file. Special codes
+|is_term..max_spec_src| indicate other sources of input text.
+
+@d is_term 0 /* |name| value when reading from the terminal for normal input */
+@d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
+@d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
+@d max_spec_src is_scantok
+
+@ Additional information about the current line is available via the
+|index| variable, which counts how many lines of characters are present
+in the buffer below the current level. We have |index=0| when reading
+from the terminal and prompting the user for each line; then if the user types,
+e.g., `\.{input figs}', we will have |index=1| while reading
+the file \.{figs.mp}. However, it does not follow that |index| is the
+same as the input stack pointer, since many of the levels on the input
+stack may come from token lists and some |index| values may correspond
+to \.{MPX} files that are not currently on the stack.
+
+The global variable |in_open| is equal to the highest |index| value counting
+\.{MPX} files but excluding token-list input levels. Thus, the number of
+partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
+when we are not reading a token list.
+
+If we are not currently reading from the terminal,
+we are reading from the file variable |input_file[index]|. We use
+the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
+and |cur_file| as an abbreviation for |input_file[index]|.
+
+When \MP\ is not reading from the terminal, the global variable |line| contains
+the line number in the current file, for use in error messages. More precisely,
+|line| is a macro for |line_stack[index]| and the |line_stack| array gives
+the line number for each file in the |input_file| array.
+
+When an \.{MPX} file is opened the file name is stored in the |mpx_name|
+array so that the name doesn't get lost when the file is temporarily removed
+from the input stack.
+Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
+and it contains translated \TeX\ pictures for |input_file[k-1]|.
+Since this is not an \.{MPX} file, we have
+$$ \hbox{|mpx_name[k-1]<=absent|}. $$
+This |name| field is set to |finished| when |input_file[k]| is completely
+read.
+
+If more information about the input state is needed, it can be
+included in small arrays like those shown here. For example,
+the current page or segment number in the input file might be put
+into a variable |page|, that is really a macro for the current entry
+in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
+by analogy with |line_stack|.
+@^system dependencies@>
+
+@d terminal_input (name==is_term) /* are we reading from the terminal? */
+@d cur_file mp->input_file[index] /* the current |void *| variable */
+@d line mp->line_stack[index] /* current line number in the current source file */
+@d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
+@d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
+@d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
+@d mpx_reading (mp->mpx_name[index]>absent)
+ /* when reading a file, is it an \.{MPX} file? */
+@d finished 0
+ /* |name_field| value when the corresponding \.{MPX} file is finished */
+
+@<Glob...@>=
+integer in_open; /* the number of lines in the buffer, less one */
+unsigned int open_parens; /* the number of open text files */
+void * *input_file ;
+integer *line_stack ; /* the line number for each file */
+char * *iname_stack; /* used for naming \.{MPX} files */
+char * *iarea_stack; /* used for naming \.{MPX} files */
+halfword*mpx_name ;
+
+@ @<Allocate or ...@>=
+mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
+mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
+mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
+mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
+mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
+{
+ int k;
+ for (k=0;k<=mp->max_in_open;k++) {
+ mp->iname_stack[k] =NULL;
+ mp->iarea_stack[k] =NULL;
+ }
+}
+
+@ @<Dealloc variables@>=
+{
+ int l;
+ for (l=0;l<=mp->max_in_open;l++) {
+ xfree(mp->iname_stack[l]);
+ xfree(mp->iarea_stack[l]);
+ }
+}
+xfree(mp->input_file);
+xfree(mp->line_stack);
+xfree(mp->iname_stack);
+xfree(mp->iarea_stack);
+xfree(mp->mpx_name);
+
+
+@ However, all this discussion about input state really applies only to the
+case that we are inputting from a file. There is another important case,
+namely when we are currently getting input from a token list. In this case
+|index>max_in_open|, and the conventions about the other state variables
+are different:
+
+\yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
+the node that will be read next. If |loc=null|, the token list has been
+fully read.
+
+\yskip\hang|start| points to the first node of the token list; this node
+may or may not contain a reference count, depending on the type of token
+list involved.
+
+\yskip\hang|token_type|, which takes the place of |index| in the
+discussion above, is a code number that explains what kind of token list
+is being scanned.
+
+\yskip\hang|name| points to the |eqtb| address of the control sequence
+being expanded, if the current token list is a macro not defined by
+\&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
+can be deduced by looking at their first two parameters.
+
+\yskip\hang|param_start|, which takes the place of |limit|, tells where
+the parameters of the current macro or loop text begin in the |param_stack|.
+
+\yskip\noindent The |token_type| can take several values, depending on
+where the current token list came from:
+
+\yskip
+\indent|forever_text|, if the token list being scanned is the body of
+a \&{forever} loop;
+
+\indent|loop_text|, if the token list being scanned is the body of
+a \&{for} or \&{forsuffixes} loop;
+
+\indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
+
+\indent|backed_up|, if the token list being scanned has been inserted as
+`to be read again'.
+
+\indent|inserted|, if the token list being scanned has been inserted as
+part of error recovery;
+
+\indent|macro|, if the expansion of a user-defined symbolic token is being
+scanned.
+
+\yskip\noindent
+The token list begins with a reference count if and only if |token_type=
+macro|.
+@^reference counts@>
+
+@d token_type index /* type of current token list */
+@d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
+@d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
+@d param_start limit /* base of macro parameters in |param_stack| */
+@d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
+@d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
+@d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
+@d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
+@d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
+@d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
+
+@ The |param_stack| is an auxiliary array used to hold pointers to the token
+lists for parameters at the current level and subsidiary levels of input.
+This stack grows at a different rate from the others.
+
+@<Glob...@>=
+pointer *param_stack; /* token list pointers for parameters */
+integer param_ptr; /* first unused entry in |param_stack| */
+integer max_param_stack; /* largest value of |param_ptr| */
+
+@ @<Allocate or initialize ...@>=
+mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
+
+@ @<Dealloc variables@>=
+xfree(mp->param_stack);
+
+@ Notice that the |line| isn't valid when |token_state| is true because it
+depends on |index|. If we really need to know the line number for the
+topmost file in the index stack we use the following function. If a page
+number or other information is needed, this routine should be modified to
+compute it as well.
+@^system dependencies@>
+
+@<Declare a function called |true_line|@>=
+integer mp_true_line (MP mp) {
+ int k; /* an index into the input stack */
+ if ( file_state && (name>max_spec_src) ) {
+ return line;
+ } else {
+ k=mp->input_ptr;
+ while ((k>0) &&
+ ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
+ (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
+ decr(k);
+ }
+ return (k>0 ? mp->line_stack[(k-1)] : 0 );
+ }
+}
+
+@ Thus, the ``current input state'' can be very complicated indeed; there
+can be many levels and each level can arise in a variety of ways. The
+|show_context| procedure, which is used by \MP's error-reporting routine to
+print out the current input state on all levels down to the most recent
+line of characters from an input file, illustrates most of these conventions.
+The global variable |file_ptr| contains the lowest level that was
+displayed by this procedure.
+
+@<Glob...@>=
+integer file_ptr; /* shallowest level shown by |show_context| */
+
+@ The status at each level is indicated by printing two lines, where the first
+line indicates what was read so far and the second line shows what remains
+to be read. The context is cropped, if necessary, so that the first line
+contains at most |half_error_line| characters, and the second contains
+at most |error_line|. Non-current input levels whose |token_type| is
+`|backed_up|' are shown only if they have not been fully read.
+
+@c void mp_show_context (MP mp) { /* prints where the scanner is */
+ int old_setting; /* saved |selector| setting */
+ @<Local variables for formatting calculations@>
+ mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
+ /* store current state */
+ while (1) {
+ mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
+ @<Display the current context@>;
+ if ( file_state )
+ if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
+ decr(mp->file_ptr);
+ }
+ mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
+}
+
+@ @<Display the current context@>=
+if ( (mp->file_ptr==mp->input_ptr) || file_state ||
+ (token_type!=backed_up) || (loc!=null) ) {
+ /* we omit backed-up token lists that have already been read */
+ mp->tally=0; /* get ready to count characters */
+ old_setting=mp->selector;
+ if ( file_state ) {
+ @<Print location of current line@>;
+ @<Pseudoprint the line@>;
+ } else {
+ @<Print type of token list@>;
+ @<Pseudoprint the token list@>;
+ }
+ mp->selector=old_setting; /* stop pseudoprinting */
+ @<Print two lines using the tricky pseudoprinted information@>;
+}
+
+@ This routine should be changed, if necessary, to give the best possible
+indication of where the current line resides in the input file.
+For example, on some systems it is best to print both a page and line number.
+@^system dependencies@>
+
+@<Print location of current line@>=
+if ( name>max_spec_src ) {
+ mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
+} else if ( terminal_input ) {
+ if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
+ else mp_print_nl(mp, "<insert>");
+} else if ( name==is_scantok ) {
+ mp_print_nl(mp, "<scantokens>");
+} else {
+ mp_print_nl(mp, "<read>");
+}
+mp_print_char(mp, ' ')
+
+@ Can't use case statement here because the |token_type| is not
+a constant expression.
+
+@<Print type of token list@>=
+{
+ if(token_type==forever_text) {
+ mp_print_nl(mp, "<forever> ");
+ } else if (token_type==loop_text) {
+ @<Print the current loop value@>;
+ } else if (token_type==parameter) {
+ mp_print_nl(mp, "<argument> ");
+ } else if (token_type==backed_up) {
+ if ( loc==null ) mp_print_nl(mp, "<recently read> ");
+ else mp_print_nl(mp, "<to be read again> ");
+ } else if (token_type==inserted) {
+ mp_print_nl(mp, "<inserted text> ");
+ } else if (token_type==macro) {
+ mp_print_ln(mp);
+ if ( name!=null ) mp_print_text(name);
+ else @<Print the name of a \&{vardef}'d macro@>;
+ mp_print(mp, "->");
+ } else {
+ mp_print_nl(mp, "?");/* this should never happen */
+@.?\relax@>
+ }
+}
+
+@ The parameter that corresponds to a loop text is either a token list
+(in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
+We'll discuss capsules later; for now, all we need to know is that
+the |link| field in a capsule parameter is |void| and that
+|print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
+
+@<Print the current loop value@>=
+{ mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
+ if ( p!=null ) {
+ if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
+ else mp_show_token_list(mp, p,null,20,mp->tally);
+ }
+ mp_print(mp, ")> ");
+}
+
+@ The first two parameters of a macro defined by \&{vardef} will be token
+lists representing the macro's prefix and ``at point.'' By putting these
+together, we get the macro's full name.
+
+@<Print the name of a \&{vardef}'d macro@>=
+{ p=mp->param_stack[param_start];
+ if ( p==null ) {
+ mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
+ } else {
+ q=p;
+ while ( link(q)!=null ) q=link(q);
+ link(q)=mp->param_stack[param_start+1];
+ mp_show_token_list(mp, p,null,20,mp->tally);
+ link(q)=null;
+ }
+}
+
+@ Now it is necessary to explain a little trick. We don't want to store a long
+string that corresponds to a token list, because that string might take up
+lots of memory; and we are printing during a time when an error message is
+being given, so we dare not do anything that might overflow one of \MP's
+tables. So `pseudoprinting' is the answer: We enter a mode of printing
+that stores characters into a buffer of length |error_line|, where character
+$k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
+|k<trick_count|, otherwise character |k| is dropped. Initially we set
+|tally:=0| and |trick_count:=1000000|; then when we reach the
+point where transition from line 1 to line 2 should occur, we
+set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
+tally+1+error_line-half_error_line)|. At the end of the
+pseudoprinting, the values of |first_count|, |tally|, and
+|trick_count| give us all the information we need to print the two lines,
+and all of the necessary text is in |trick_buf|.
+
+Namely, let |l| be the length of the descriptive information that appears
+on the first line. The length of the context information gathered for that
+line is |k=first_count|, and the length of the context information
+gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
+where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
+descriptive information on line~1, and set |n:=l+k|; here |n| is the
+length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
+and print `\.{...}' followed by
+$$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
+where subscripts of |trick_buf| are circular modulo |error_line|. The
+second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
+unless |n+m>error_line|; in the latter case, further cropping is done.
+This is easier to program than to explain.
+
+@<Local variables for formatting...@>=
+int i; /* index into |buffer| */
+integer l; /* length of descriptive information on line 1 */
+integer m; /* context information gathered for line 2 */
+int n; /* length of line 1 */
+integer p; /* starting or ending place in |trick_buf| */
+integer q; /* temporary index */
+
+@ The following code tells the print routines to gather
+the desired information.
+
+@d begin_pseudoprint {
+ l=mp->tally; mp->tally=0; mp->selector=pseudo;
+ mp->trick_count=1000000;
+}
+@d set_trick_count {
+ mp->first_count=mp->tally;
+ mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
+ if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
+}
+
+@ And the following code uses the information after it has been gathered.
+
+@<Print two lines using the tricky pseudoprinted information@>=
+if ( mp->trick_count==1000000 ) set_trick_count;
+ /* |set_trick_count| must be performed */
+if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
+else m=mp->trick_count-mp->first_count; /* context on line 2 */
+if ( l+mp->first_count<=mp->half_error_line ) {
+ p=0; n=l+mp->first_count;
+} else {
+ mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
+ n=mp->half_error_line;
+}
+for (q=p;q<=mp->first_count-1;q++) {
+ mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
+}
+mp_print_ln(mp);
+for (q=1;q<=n;q++) {
+ mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
+}
+if ( m+n<=mp->error_line ) p=mp->first_count+m;
+else p=mp->first_count+(mp->error_line-n-3);
+for (q=mp->first_count;q<=p-1;q++) {
+ mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
+}
+if ( m+n>mp->error_line ) mp_print(mp, "...")
+
+@ But the trick is distracting us from our current goal, which is to
+understand the input state. So let's concentrate on the data structures that
+are being pseudoprinted as we finish up the |show_context| procedure.
+
+@<Pseudoprint the line@>=
+begin_pseudoprint;
+if ( limit>0 ) {
+ for (i=start;i<=limit-1;i++) {
+ if ( i==loc ) set_trick_count;
+ mp_print_str(mp, mp->buffer[i]);
+ }
+}
+
+@ @<Pseudoprint the token list@>=
+begin_pseudoprint;
+if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
+else mp_show_macro(mp, start,loc,100000)
+
+@ Here is the missing piece of |show_token_list| that is activated when the
+token beginning line~2 is about to be shown:
+
+@<Do magic computation@>=set_trick_count
+
+@* \[28] Maintaining the input stacks.
+The following subroutines change the input status in commonly needed ways.
+
+First comes |push_input|, which stores the current state and creates a
+new level (having, initially, the same properties as the old).
+
+@d push_input { /* enter a new input level, save the old */
+ if ( mp->input_ptr>mp->max_in_stack ) {
+ mp->max_in_stack=mp->input_ptr;
+ if ( mp->input_ptr==mp->stack_size ) {
+ int l = (mp->stack_size+(mp->stack_size>>2));
+ XREALLOC(mp->input_stack, l, in_state_record);
+ mp->stack_size = l;
+ }
+ }
+ mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
+ incr(mp->input_ptr);
+}
+
+@ And of course what goes up must come down.
+
+@d pop_input { /* leave an input level, re-enter the old */
+ decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
+ }
+
+@ Here is a procedure that starts a new level of token-list input, given
+a token list |p| and its type |t|. If |t=macro|, the calling routine should
+set |name|, reset~|loc|, and increase the macro's reference count.
+
+@d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
+
+@c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
+ push_input; start=p; token_type=t;
+ param_start=mp->param_ptr; loc=p;
+}
+
+@ When a token list has been fully scanned, the following computations
+should be done as we leave that level of input.
+@^inner loop@>
+
+@c void mp_end_token_list (MP mp) { /* leave a token-list input level */
+ pointer p; /* temporary register */
+ if ( token_type>=backed_up ) { /* token list to be deleted */
+ if ( token_type<=inserted ) {
+ mp_flush_token_list(mp, start); goto DONE;
+ } else {
+ mp_delete_mac_ref(mp, start); /* update reference count */
+ }
+ }
+ while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
+ decr(mp->param_ptr);
+ p=mp->param_stack[mp->param_ptr];
+ if ( p!=null ) {
+ if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
+ mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
+ } else {
+ mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
+ }
+ }
+ }
+DONE:
+ pop_input; check_interrupt;
+}
+
+@ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
+token by the |cur_tok| routine.
+@^inner loop@>
+
+@c @<Declare the procedure called |make_exp_copy|@>
+pointer mp_cur_tok (MP mp) {
+ pointer p; /* a new token node */
+ small_number save_type; /* |cur_type| to be restored */
+ integer save_exp; /* |cur_exp| to be restored */
+ if ( mp->cur_sym==0 ) {
+ if ( mp->cur_cmd==capsule_token ) {
+ save_type=mp->cur_type; save_exp=mp->cur_exp;
+ mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
+ mp->cur_type=save_type; mp->cur_exp=save_exp;
+ } else {
+ p=mp_get_node(mp, token_node_size);
+ value(p)=mp->cur_mod; name_type(p)=mp_token;
+ if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
+ else type(p)=mp_string_type;
+ }
+ } else {
+ fast_get_avail(p); info(p)=mp->cur_sym;
+ }
+ return p;
+}
+
+@ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
+seen. The |back_input| procedure takes care of this by putting the token
+just scanned back into the input stream, ready to be read again.
+If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
+
+@<Declarations@>=
+void mp_back_input (MP mp);
+
+@ @c void mp_back_input (MP mp) {/* undoes one token of input */
+ pointer p; /* a token list of length one */
+ p=mp_cur_tok(mp);
+ while ( token_state &&(loc==null) )
+ mp_end_token_list(mp); /* conserve stack space */
+ back_list(p);
+}
+
+@ The |back_error| routine is used when we want to restore or replace an
+offending token just before issuing an error message. We disable interrupts
+during the call of |back_input| so that the help message won't be lost.
+
+@<Declarations@>=
+void mp_error (MP mp);
+void mp_back_error (MP mp);
+
+@ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
+ mp->OK_to_interrupt=false;
+ mp_back_input(mp);
+ mp->OK_to_interrupt=true; mp_error(mp);
+}
+void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
+ mp->OK_to_interrupt=false;
+ mp_back_input(mp); token_type=inserted;
+ mp->OK_to_interrupt=true; mp_error(mp);
+}
+
+@ The |begin_file_reading| procedure starts a new level of input for lines
+of characters to be read from a file, or as an insertion from the
+terminal. It does not take care of opening the file, nor does it set |loc|
+or |limit| or |line|.
+@^system dependencies@>
+
+@c void mp_begin_file_reading (MP mp) {
+ if ( mp->in_open==mp->max_in_open )
+ mp_overflow(mp, "text input levels",mp->max_in_open);
+@:MetaPost capacity exceeded text input levels}{\quad text input levels@>
+ if ( mp->first==mp->buf_size )
+ mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
+ incr(mp->in_open); push_input; index=mp->in_open;
+ mp->mpx_name[index]=absent;
+ start=mp->first;
+ name=is_term; /* |terminal_input| is now |true| */
+}
+
+@ Conversely, the variables must be downdated when such a level of input
+is finished. Any associated \.{MPX} file must also be closed and popped
+off the file stack.
+
+@c void mp_end_file_reading (MP mp) {
+ if ( mp->in_open>index ) {
+ if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
+ mp_confusion(mp, "endinput");
+@:this can't happen endinput}{\quad endinput@>
+ } else {
+ (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
+ delete_str_ref(mp->mpx_name[mp->in_open]);
+ decr(mp->in_open);
+ }
+ }
+ mp->first=start;
+ if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
+ if ( name>max_spec_src ) {
+ (mp->close_file)(mp,cur_file);
+ delete_str_ref(name);
+ xfree(in_name);
+ xfree(in_area);
+ }
+ pop_input; decr(mp->in_open);
+}
+
+@ Here is a function that tries to resume input from an \.{MPX} file already
+associated with the current input file. It returns |false| if this doesn't
+work.
+
+@c boolean mp_begin_mpx_reading (MP mp) {
+ if ( mp->in_open!=index+1 ) {
+ return false;
+ } else {
+ if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
+@:this can't happen mpx}{\quad mpx@>
+ if ( mp->first==mp->buf_size )
+ mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
+ push_input; index=mp->in_open;
+ start=mp->first;
+ name=mp->mpx_name[mp->in_open]; add_str_ref(name);
+ @<Put an empty line in the input buffer@>;
+ return true;
+ }
+}
+
+@ This procedure temporarily stops reading an \.{MPX} file.
+
+@c void mp_end_mpx_reading (MP mp) {
+ if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
+@:this can't happen mpx}{\quad mpx@>
+ if ( loc<limit ) {
+ @<Complain that we are not at the end of a line in the \.{MPX} file@>;
+ }
+ mp->first=start;
+ pop_input;
+}
+
+@ Here we enforce a restriction that simplifies the input stacks considerably.
+This should not inconvenience the user because \.{MPX} files are generated
+by an auxiliary program called \.{DVItoMP}.
+
+@ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
+{
+print_err("`mpxbreak' must be at the end of a line");
+help4("This file contains picture expressions for btex...etex")
+ ("blocks. Such files are normally generated automatically")
+ ("but this one seems to be messed up. I'm going to ignore")
+ ("the rest of this line.");
+mp_error(mp);
+}
+
+@ In order to keep the stack from overflowing during a long sequence of
+inserted `\.{show}' commands, the following routine removes completed
+error-inserted lines from memory.
+
+@c void mp_clear_for_error_prompt (MP mp) {
+ while ( file_state && terminal_input &&
+ (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
+ mp_print_ln(mp); clear_terminal;
+}
+
+@ To get \MP's whole input mechanism going, we perform the following
+actions.
+
+@<Initialize the input routines@>=
+{ mp->input_ptr=0; mp->max_in_stack=0;
+ mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
+ mp->param_ptr=0; mp->max_param_stack=0;
+ mp->first=1;
+ start=1; index=0; line=0; name=is_term;
+ mp->mpx_name[0]=absent;
+ mp->force_eof=false;
+ if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
+ limit=mp->last; mp->first=mp->last+1;
+ /* |init_terminal| has set |loc| and |last| */
+}
+
+@* \[29] Getting the next token.
+The heart of \MP's input mechanism is the |get_next| procedure, which
+we shall develop in the next few sections of the program. Perhaps we
+shouldn't actually call it the ``heart,'' however; it really acts as \MP's
+eyes and mouth, reading the source files and gobbling them up. And it also
+helps \MP\ to regurgitate stored token lists that are to be processed again.
+
+The main duty of |get_next| is to input one token and to set |cur_cmd|
+and |cur_mod| to that token's command code and modifier. Furthermore, if
+the input token is a symbolic token, that token's |hash| address
+is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
+
+Underlying this simple description is a certain amount of complexity
+because of all the cases that need to be handled.
+However, the inner loop of |get_next| is reasonably short and fast.
+
+@ Before getting into |get_next|, we need to consider a mechanism by which
+\MP\ helps keep errors from propagating too far. Whenever the program goes
+into a mode where it keeps calling |get_next| repeatedly until a certain
+condition is met, it sets |scanner_status| to some value other than |normal|.
+Then if an input file ends, or if an `\&{outer}' symbol appears,
+an appropriate error recovery will be possible.
+
+The global variable |warning_info| helps in this error recovery by providing
+additional information. For example, |warning_info| might indicate the
+name of a macro whose replacement text is being scanned.
+
+@d normal 0 /* |scanner_status| at ``quiet times'' */
+@d skipping 1 /* |scanner_status| when false conditional text is being skipped */
+@d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
+@d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
+@d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
+@d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
+@d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
+@d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
+
+@<Glob...@>=
+integer scanner_status; /* are we scanning at high speed? */
+integer warning_info; /* if so, what else do we need to know,
+ in case an error occurs? */
+
+@ @<Initialize the input routines@>=
+mp->scanner_status=normal;
+
+@ The following subroutine
+is called when an `\&{outer}' symbolic token has been scanned or
+when the end of a file has been reached. These two cases are distinguished
+by |cur_sym|, which is zero at the end of a file.
+
+@c boolean mp_check_outer_validity (MP mp) {
+ pointer p; /* points to inserted token list */
+ if ( mp->scanner_status==normal ) {
+ return true;
+ } else if ( mp->scanner_status==tex_flushing ) {
+ @<Check if the file has ended while flushing \TeX\ material and set the
+ result value for |check_outer_validity|@>;
+ } else {
+ mp->deletions_allowed=false;
+ @<Back up an outer symbolic token so that it can be reread@>;
+ if ( mp->scanner_status>skipping ) {
+ @<Tell the user what has run away and try to recover@>;
+ } else {
+ print_err("Incomplete if; all text was ignored after line ");
+@.Incomplete if...@>
+ mp_print_int(mp, mp->warning_info);
+ help3("A forbidden `outer' token occurred in skipped text.")
+ ("This kind of error happens when you say `if...' and forget")
+ ("the matching `fi'. I've inserted a `fi'; this might work.");
+ if ( mp->cur_sym==0 )
+ mp->help_line[2]="The file ended while I was skipping conditional text.";
+ mp->cur_sym=frozen_fi; mp_ins_error(mp);
+ }
+ mp->deletions_allowed=true;
+ return false;
+ }
+}
+
+@ @<Check if the file has ended while flushing \TeX\ material and set...@>=
+if ( mp->cur_sym!=0 ) {
+ return true;
+} else {
+ mp->deletions_allowed=false;
+ print_err("TeX mode didn't end; all text was ignored after line ");
+ mp_print_int(mp, mp->warning_info);
+ help2("The file ended while I was looking for the `etex' to")
+ ("finish this TeX material. I've inserted `etex' now.");
+ mp->cur_sym = frozen_etex;
+ mp_ins_error(mp);
+ mp->deletions_allowed=true;
+ return false;
+}
+
+@ @<Back up an outer symbolic token so that it can be reread@>=
+if ( mp->cur_sym!=0 ) {
+ p=mp_get_avail(mp); info(p)=mp->cur_sym;
+ back_list(p); /* prepare to read the symbolic token again */
+}
+
+@ @<Tell the user what has run away...@>=
+{
+ mp_runaway(mp); /* print the definition-so-far */
+ if ( mp->cur_sym==0 ) {
+ print_err("File ended");
+@.File ended while scanning...@>
+ } else {
+ print_err("Forbidden token found");
+@.Forbidden token found...@>
+ }
+ mp_print(mp, " while scanning ");
+ help4("I suspect you have forgotten an `enddef',")
+ ("causing me to read past where you wanted me to stop.")
+ ("I'll try to recover; but if the error is serious,")
+ ("you'd better type `E' or `X' now and fix your file.");
+ switch (mp->scanner_status) {
+ @<Complete the error message,
+ and set |cur_sym| to a token that might help recover from the error@>
+ } /* there are no other cases */
+ mp_ins_error(mp);
+}
+
+@ As we consider various kinds of errors, it is also appropriate to
+change the first line of the help message just given; |help_line[3]|
+points to the string that might be changed.
+
+@<Complete the error message,...@>=
+case flushing:
+ mp_print(mp, "to the end of the statement");
+ mp->help_line[3]="A previous error seems to have propagated,";
+ mp->cur_sym=frozen_semicolon;
+ break;
+case absorbing:
+ mp_print(mp, "a text argument");
+ mp->help_line[3]="It seems that a right delimiter was left out,";
+ if ( mp->warning_info==0 ) {
+ mp->cur_sym=frozen_end_group;
+ } else {
+ mp->cur_sym=frozen_right_delimiter;
+ equiv(frozen_right_delimiter)=mp->warning_info;
+ }
+ break;
+case var_defining:
+case op_defining:
+ mp_print(mp, "the definition of ");
+ if ( mp->scanner_status==op_defining )
+ mp_print_text(mp->warning_info);
+ else
+ mp_print_variable_name(mp, mp->warning_info);
+ mp->cur_sym=frozen_end_def;
+ break;
+case loop_defining:
+ mp_print(mp, "the text of a ");
+ mp_print_text(mp->warning_info);
+ mp_print(mp, " loop");
+ mp->help_line[3]="I suspect you have forgotten an `endfor',";
+ mp->cur_sym=frozen_end_for;
+ break;
+
+@ The |runaway| procedure displays the first part of the text that occurred
+when \MP\ began its special |scanner_status|, if that text has been saved.
+
+@<Declare the procedure called |runaway|@>=
+void mp_runaway (MP mp) {
+ if ( mp->scanner_status>flushing ) {
+ mp_print_nl(mp, "Runaway ");
+ switch (mp->scanner_status) {
+ case absorbing: mp_print(mp, "text?"); break;
+ case var_defining:
+ case op_defining: mp_print(mp,"definition?"); break;
+ case loop_defining: mp_print(mp, "loop?"); break;
+ } /* there are no other cases */
+ mp_print_ln(mp);
+ mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
+ }
+}
+
+@ We need to mention a procedure that may be called by |get_next|.
+
+@<Declarations@>=
+void mp_firm_up_the_line (MP mp);
+
+@ And now we're ready to take the plunge into |get_next| itself.
+Note that the behavior depends on the |scanner_status| because percent signs
+and double quotes need to be passed over when skipping TeX material.
+
+@c
+void mp_get_next (MP mp) {
+ /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
+@^inner loop@>
+ /*restart*/ /* go here to get the next input token */
+ /*exit*/ /* go here when the next input token has been got */
+ /*|common_ending|*/ /* go here to finish getting a symbolic token */
+ /*found*/ /* go here when the end of a symbolic token has been found */
+ /*switch*/ /* go here to branch on the class of an input character */
+ /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
+ /* go here at crucial stages when scanning a number */
+ int k; /* an index into |buffer| */
+ ASCII_code c; /* the current character in the buffer */
+ ASCII_code class; /* its class number */
+ integer n,f; /* registers for decimal-to-binary conversion */
+RESTART:
+ mp->cur_sym=0;
+ if ( file_state ) {
+ @<Input from external file; |goto restart| if no input found,
+ or |return| if a non-symbolic token is found@>;
+ } else {
+ @<Input from token list; |goto restart| if end of list or
+ if a parameter needs to be expanded,
+ or |return| if a non-symbolic token is found@>;
+ }
+COMMON_ENDING:
+ @<Finish getting the symbolic token in |cur_sym|;
+ |goto restart| if it is illegal@>;
+}
+
+@ When a symbolic token is declared to be `\&{outer}', its command code
+is increased by |outer_tag|.
+@^inner loop@>
+
+@<Finish getting the symbolic token in |cur_sym|...@>=
+mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
+if ( mp->cur_cmd>=outer_tag ) {
+ if ( mp_check_outer_validity(mp) )
+ mp->cur_cmd=mp->cur_cmd-outer_tag;
+ else
+ goto RESTART;
+}
+
+@ A percent sign appears in |buffer[limit]|; this makes it unnecessary
+to have a special test for end-of-line.
+@^inner loop@>
+
+@<Input from external file;...@>=
+{
+SWITCH:
+ c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
+ switch (class) {
+ case digit_class: goto START_NUMERIC_TOKEN; break;
+ case period_class:
+ class=mp->char_class[mp->buffer[loc]];
+ if ( class>period_class ) {
+ goto SWITCH;
+ } else if ( class<period_class ) { /* |class=digit_class| */
+ n=0; goto START_DECIMAL_TOKEN;
+ }
+@:. }{\..\ token@>
+ break;
+ case space_class: goto SWITCH; break;
+ case percent_class:
+ if ( mp->scanner_status==tex_flushing ) {
+ if ( loc<limit ) goto SWITCH;
+ }
+ @<Move to next line of file, or |goto restart| if there is no next line@>;
+ check_interrupt;
+ goto SWITCH;
+ break;
+ case string_class:
+ if ( mp->scanner_status==tex_flushing ) goto SWITCH;
+ else @<Get a string token and |return|@>;
+ break;
+ case isolated_classes:
+ k=loc-1; goto FOUND; break;
+ case invalid_class:
+ if ( mp->scanner_status==tex_flushing ) goto SWITCH;
+ else @<Decry the invalid character and |goto restart|@>;
+ break;
+ default: break; /* letters, etc. */
+ }
+ k=loc-1;
+ while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
+ goto FOUND;
+START_NUMERIC_TOKEN:
+ @<Get the integer part |n| of a numeric token;
+ set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
+START_DECIMAL_TOKEN:
+ @<Get the fraction part |f| of a numeric token@>;
+FIN_NUMERIC_TOKEN:
+ @<Pack the numeric and fraction parts of a numeric token
+ and |return|@>;
+FOUND:
+ mp->cur_sym=mp_id_lookup(mp, k,loc-k);
+}
+
+@ We go to |restart| instead of to |SWITCH|, because we might enter
+|token_state| after the error has been dealt with
+(cf.\ |clear_for_error_prompt|).
+
+@<Decry the invalid...@>=
+{
+ print_err("Text line contains an invalid character");
+@.Text line contains...@>
+ help2("A funny symbol that I can\'t read has just been input.")
+ ("Continue, and I'll forget that it ever happened.");
+ mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
+ goto RESTART;
+}
+
+@ @<Get a string token and |return|@>=
+{
+ if ( mp->buffer[loc]=='"' ) {
+ mp->cur_mod=rts("");
+ } else {
+ k=loc; mp->buffer[limit+1]='"';
+ do {
+ incr(loc);
+ } while (mp->buffer[loc]!='"');
+ if ( loc>limit ) {
+ @<Decry the missing string delimiter and |goto restart|@>;
+ }
+ if ( loc==k+1 ) {
+ mp->cur_mod=mp->buffer[k];
+ } else {
+ str_room(loc-k);
+ do {
+ append_char(mp->buffer[k]); incr(k);
+ } while (k!=loc);
+ mp->cur_mod=mp_make_string(mp);
+ }
+ }
+ incr(loc); mp->cur_cmd=string_token;
+ return;
+}
+
+@ We go to |restart| after this error message, not to |SWITCH|,
+because the |clear_for_error_prompt| routine might have reinstated
+|token_state| after |error| has finished.
+
+@<Decry the missing string delimiter and |goto restart|@>=
+{
+ loc=limit; /* the next character to be read on this line will be |"%"| */
+ print_err("Incomplete string token has been flushed");
+@.Incomplete string token...@>
+ help3("Strings should finish on the same line as they began.")
+ ("I've deleted the partial string; you might want to")
+ ("insert another by typing, e.g., `I\"new string\"'.");
+ mp->deletions_allowed=false; mp_error(mp);
+ mp->deletions_allowed=true;
+ goto RESTART;
+}
+
+@ @<Get the integer part |n| of a numeric token...@>=
+n=c-'0';
+while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
+ if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
+ incr(loc);
+}
+if ( mp->buffer[loc]=='.' )
+ if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
+ goto DONE;
+f=0;
+goto FIN_NUMERIC_TOKEN;
+DONE: incr(loc)
+
+@ @<Get the fraction part |f| of a numeric token@>=
+k=0;
+do {
+ if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
+ mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
+ }
+ incr(loc);
+} while (mp->char_class[mp->buffer[loc]]==digit_class);
+f=mp_round_decimals(mp, k);
+if ( f==unity ) {
+ incr(n); f=0;
+}
+
+@ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
+if ( n<32768 ) {
+ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
+} else if ( mp->scanner_status!=tex_flushing ) {
+ print_err("Enormous number has been reduced");
+@.Enormous number...@>
+ help2("I can\'t handle numbers bigger than 32767.99998;")
+ ("so I've changed your constant to that maximum amount.");
+ mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
+ mp->cur_mod=el_gordo;
+}
+mp->cur_cmd=numeric_token; return
+
+@ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
+{
+ mp->cur_mod=n*unity+f;
+ if ( mp->cur_mod>=fraction_one ) {
+ if ( (mp->internal[mp_warning_check]>0) &&
+ (mp->scanner_status!=tex_flushing) ) {
+ print_err("Number is too large (");
+ mp_print_scaled(mp, mp->cur_mod);
+ mp_print_char(mp, ')');
+ help3("It is at least 4096. Continue and I'll try to cope")
+ ("with that big value; but it might be dangerous.")
+ ("(Set warningcheck:=0 to suppress this message.)");
+ mp_error(mp);
+ }
+ }
+}
+
+@ Let's consider now what happens when |get_next| is looking at a token list.
+@^inner loop@>
+
+@<Input from token list;...@>=
+if ( loc>=mp->hi_mem_min ) { /* one-word token */
+ mp->cur_sym=info(loc); loc=link(loc); /* move to next */
+ if ( mp->cur_sym>=expr_base ) {
+ if ( mp->cur_sym>=suffix_base ) {
+ @<Insert a suffix or text parameter and |goto restart|@>;
+ } else {
+ mp->cur_cmd=capsule_token;
+ mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
+ mp->cur_sym=0; return;
+ }
+ }
+} else if ( loc>null ) {
+ @<Get a stored numeric or string or capsule token and |return|@>
+} else { /* we are done with this token list */
+ mp_end_token_list(mp); goto RESTART; /* resume previous level */
+}
+
+@ @<Insert a suffix or text parameter...@>=
+{
+ if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
+ /* |param_size=text_base-suffix_base| */
+ mp_begin_token_list(mp,
+ mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
+ parameter);
+ goto RESTART;
+}
+
+@ @<Get a stored numeric or string or capsule token...@>=
+{
+ if ( name_type(loc)==mp_token ) {
+ mp->cur_mod=value(loc);
+ if ( type(loc)==mp_known ) {
+ mp->cur_cmd=numeric_token;
+ } else {
+ mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
+ }
+ } else {
+ mp->cur_mod=loc; mp->cur_cmd=capsule_token;
+ };
+ loc=link(loc); return;
+}
+
+@ All of the easy branches of |get_next| have now been taken care of.
+There is one more branch.
+
+@<Move to next line of file, or |goto restart|...@>=
+if ( name>max_spec_src ) {
+ @<Read next line of file into |buffer|, or
+ |goto restart| if the file has ended@>;
+} else {
+ if ( mp->input_ptr>0 ) {
+ /* text was inserted during error recovery or by \&{scantokens} */
+ mp_end_file_reading(mp); goto RESTART; /* resume previous level */
+ }
+ if ( mp->selector<log_only || mp->selector>=write_file) mp_open_log_file(mp);
+ if ( mp->interaction>mp_nonstop_mode ) {
+ if ( limit==start ) /* previous line was empty */
+ mp_print_nl(mp, "(Please type a command or say `end')");
+@.Please type...@>
+ mp_print_ln(mp); mp->first=start;
+ prompt_input("*"); /* input on-line into |buffer| */
+@.*\relax@>
+ limit=mp->last; mp->buffer[limit]='%';
+ mp->first=limit+1; loc=start;
+ } else {
+ mp_fatal_error(mp, "*** (job aborted, no legal end found)");
+@.job aborted@>
+ /* nonstop mode, which is intended for overnight batch processing,
+ never waits for on-line input */
+ }
+}
+
+@ The global variable |force_eof| is normally |false|; it is set |true|
+by an \&{endinput} command.
+
+@<Glob...@>=
+boolean force_eof; /* should the next \&{input} be aborted early? */
+
+@ We must decrement |loc| in order to leave the buffer in a valid state
+when an error condition causes us to |goto restart| without calling
+|end_file_reading|.
+
+@<Read next line of file into |buffer|, or
+ |goto restart| if the file has ended@>=
+{
+ incr(line); mp->first=start;
+ if ( ! mp->force_eof ) {
+ if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
+ mp_firm_up_the_line(mp); /* this sets |limit| */
+ else
+ mp->force_eof=true;
+ };
+ if ( mp->force_eof ) {
+ mp->force_eof=false;
+ decr(loc);
+ if ( mpx_reading ) {
+ @<Complain that the \.{MPX} file ended unexpectly; then set
+ |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
+ } else {
+ mp_print_char(mp, ')'); decr(mp->open_parens);
+ update_terminal; /* show user that file has been read */
+ mp_end_file_reading(mp); /* resume previous level */
+ if ( mp_check_outer_validity(mp) ) goto RESTART;
+ else goto RESTART;
+ }
+ }
+ mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
+}
+
+@ We should never actually come to the end of an \.{MPX} file because such
+files should have an \&{mpxbreak} after the translation of the last
+\&{btex}$\,\ldots\,$\&{etex} block.
+
+@<Complain that the \.{MPX} file ended unexpectly; then set...@>=
+{
+ mp->mpx_name[index]=finished;
+ print_err("mpx file ended unexpectedly");
+ help4("The file had too few picture expressions for btex...etex")
+ ("blocks. Such files are normally generated automatically")
+ ("but this one got messed up. You might want to insert a")
+ ("picture expression now.");
+ mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
+ mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
+}
+
+@ Sometimes we want to make it look as though we have just read a blank line
+without really doing so.
+
+@<Put an empty line in the input buffer@>=
+mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
+mp->buffer[limit]='%'; mp->first=limit+1; loc=start
+
+@ If the user has set the |mp_pausing| parameter to some positive value,
+and if nonstop mode has not been selected, each line of input is displayed
+on the terminal and the transcript file, followed by `\.{=>}'.
+\MP\ waits for a response. If the response is null (i.e., if nothing is
+typed except perhaps a few blank spaces), the original
+line is accepted as it stands; otherwise the line typed is
+used instead of the line in the file.
+
+@c void mp_firm_up_the_line (MP mp) {
+ size_t k; /* an index into |buffer| */
+ limit=mp->last;
+ if ( mp->internal[mp_pausing]>0) if ( mp->interaction>mp_nonstop_mode ) {
+ wake_up_terminal; mp_print_ln(mp);
+ if ( start<limit ) {
+ for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
+ mp_print_str(mp, mp->buffer[k]);
+ }
+ }
+ mp->first=limit; prompt_input("=>"); /* wait for user response */
+@.=>@>
+ if ( mp->last>mp->first ) {
+ for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
+ mp->buffer[k+start-mp->first]=mp->buffer[k];
+ }
+ limit=start+mp->last-mp->first;
+ }
+ }
+}
+
+@* \[30] Dealing with \TeX\ material.
+The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
+features need to be implemented at a low level in the scanning process
+so that \MP\ can stay in synch with the a preprocessor that treats
+blocks of \TeX\ material as they occur in the input file without trying
+to expand \MP\ macros. Thus we need a special version of |get_next|
+that does not expand macros and such but does handle \&{btex},
+\&{verbatimtex}, etc.
+
+The special version of |get_next| is called |get_t_next|. It works by flushing
+\&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
+$\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
+\&{btex}, and switching back when it sees \&{mpxbreak}.
+
+@d btex_code 0
+@d verbatim_code 1
+
+@ @<Put each...@>=
+mp_primitive(mp, "btex",start_tex,btex_code);
+@:btex_}{\&{btex} primitive@>
+mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
+@:verbatimtex_}{\&{verbatimtex} primitive@>
+mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
+@:etex_}{\&{etex} primitive@>
+mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
+@:mpx_break_}{\&{mpxbreak} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
+ else mp_print(mp, "verbatimtex"); break;
+case etex_marker: mp_print(mp, "etex"); break;
+case mpx_break: mp_print(mp, "mpxbreak"); break;
+
+@ Actually, |get_t_next| is a macro that avoids procedure overhead except
+in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
+is encountered.
+
+@d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
+
+@<Declarations@>=
+void mp_start_mpx_input (MP mp);
+
+@ @c
+void mp_t_next (MP mp) {
+ int old_status; /* saves the |scanner_status| */
+ integer old_info; /* saves the |warning_info| */
+ while ( mp->cur_cmd<=max_pre_command ) {
+ if ( mp->cur_cmd==mpx_break ) {
+ if ( ! file_state || (mp->mpx_name[index]==absent) ) {
+ @<Complain about a misplaced \&{mpxbreak}@>;
+ } else {
+ mp_end_mpx_reading(mp);
+ goto TEX_FLUSH;
+ }
+ } else if ( mp->cur_cmd==start_tex ) {
+ if ( token_state || (name<=max_spec_src) ) {
+ @<Complain that we are not reading a file@>;
+ } else if ( mpx_reading ) {
+ @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
+ } else if ( (mp->cur_mod!=verbatim_code)&&
+ (mp->mpx_name[index]!=finished) ) {
+ if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
+ } else {
+ goto TEX_FLUSH;
+ }
+ } else {
+ @<Complain about a misplaced \&{etex}@>;
+ }
+ goto COMMON_ENDING;
+ TEX_FLUSH:
+ @<Flush the \TeX\ material@>;
+ COMMON_ENDING:
+ mp_get_next(mp);
+ }
+}
+
+@ We could be in the middle of an operation such as skipping false conditional
+text when \TeX\ material is encountered, so we must be careful to save the
+|scanner_status|.
+
+@<Flush the \TeX\ material@>=
+old_status=mp->scanner_status;
+old_info=mp->warning_info;
+mp->scanner_status=tex_flushing;
+mp->warning_info=line;
+do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
+mp->scanner_status=old_status;
+mp->warning_info=old_info
+
+@ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
+{ print_err("An mpx file cannot contain btex or verbatimtex blocks");
+help4("This file contains picture expressions for btex...etex")
+ ("blocks. Such files are normally generated automatically")
+ ("but this one seems to be messed up. I'll just keep going")
+ ("and hope for the best.");
+mp_error(mp);
+}
+
+@ @<Complain that we are not reading a file@>=
+{ print_err("You can only use `btex' or `verbatimtex' in a file");
+help3("I'll have to ignore this preprocessor command because it")
+ ("only works when there is a file to preprocess. You might")
+ ("want to delete everything up to the next `etex`.");
+mp_error(mp);
+}
+
+@ @<Complain about a misplaced \&{mpxbreak}@>=
+{ print_err("Misplaced mpxbreak");
+help2("I'll ignore this preprocessor command because it")
+ ("doesn't belong here");
+mp_error(mp);
+}
+
+@ @<Complain about a misplaced \&{etex}@>=
+{ print_err("Extra etex will be ignored");
+help1("There is no btex or verbatimtex for this to match");
+mp_error(mp);
+}
+
+@* \[31] Scanning macro definitions.
+\MP\ has a variety of ways to tuck tokens away into token lists for later
+use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
+repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
+All such operations are handled by the routines in this part of the program.
+
+The modifier part of each command code is zero for the ``ending delimiters''
+like \&{enddef} and \&{endfor}.
+
+@d start_def 1 /* command modifier for \&{def} */
+@d var_def 2 /* command modifier for \&{vardef} */
+@d end_def 0 /* command modifier for \&{enddef} */
+@d start_forever 1 /* command modifier for \&{forever} */
+@d end_for 0 /* command modifier for \&{endfor} */
+
+@<Put each...@>=
+mp_primitive(mp, "def",macro_def,start_def);
+@:def_}{\&{def} primitive@>
+mp_primitive(mp, "vardef",macro_def,var_def);
+@:var_def_}{\&{vardef} primitive@>
+mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
+@:primary_def_}{\&{primarydef} primitive@>
+mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
+@:secondary_def_}{\&{secondarydef} primitive@>
+mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
+@:tertiary_def_}{\&{tertiarydef} primitive@>
+mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
+@:end_def_}{\&{enddef} primitive@>
+@#
+mp_primitive(mp, "for",iteration,expr_base);
+@:for_}{\&{for} primitive@>
+mp_primitive(mp, "forsuffixes",iteration,suffix_base);
+@:for_suffixes_}{\&{forsuffixes} primitive@>
+mp_primitive(mp, "forever",iteration,start_forever);
+@:forever_}{\&{forever} primitive@>
+mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
+@:end_for_}{\&{endfor} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case macro_def:
+ if ( m<=var_def ) {
+ if ( m==start_def ) mp_print(mp, "def");
+ else if ( m<start_def ) mp_print(mp, "enddef");
+ else mp_print(mp, "vardef");
+ } else if ( m==secondary_primary_macro ) {
+ mp_print(mp, "primarydef");
+ } else if ( m==tertiary_secondary_macro ) {
+ mp_print(mp, "secondarydef");
+ } else {
+ mp_print(mp, "tertiarydef");
+ }
+ break;
+case iteration:
+ if ( m<=start_forever ) {
+ if ( m==start_forever ) mp_print(mp, "forever");
+ else mp_print(mp, "endfor");
+ } else if ( m==expr_base ) {
+ mp_print(mp, "for");
+ } else {
+ mp_print(mp, "forsuffixes");
+ }
+ break;
+
+@ Different macro-absorbing operations have different syntaxes, but they
+also have a lot in common. There is a list of special symbols that are to
+be replaced by parameter tokens; there is a special command code that
+ends the definition; the quotation conventions are identical. Therefore
+it makes sense to have most of the work done by a single subroutine. That
+subroutine is called |scan_toks|.
+
+The first parameter to |scan_toks| is the command code that will
+terminate scanning (either |macro_def| or |iteration|).
+
+The second parameter, |subst_list|, points to a (possibly empty) list
+of two-word nodes whose |info| and |value| fields specify symbol tokens
+before and after replacement. The list will be returned to free storage
+by |scan_toks|.
+
+The third parameter is simply appended to the token list that is built.
+And the final parameter tells how many of the special operations
+\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
+When such parameters are present, they are called \.{(SUFFIX0)},
+\.{(SUFFIX1)}, and \.{(SUFFIX2)}.
+
+@c pointer mp_scan_toks (MP mp,command_code terminator, pointer
+ subst_list, pointer tail_end, small_number suffix_count) {
+ pointer p; /* tail of the token list being built */
+ pointer q; /* temporary for link management */
+ integer balance; /* left delimiters minus right delimiters */
+ p=hold_head; balance=1; link(hold_head)=null;
+ while (1) {
+ get_t_next;
+ if ( mp->cur_sym>0 ) {
+ @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
+ if ( mp->cur_cmd==terminator ) {
+ @<Adjust the balance; |break| if it's zero@>;
+ } else if ( mp->cur_cmd==macro_special ) {
+ @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
+ }
+ }
+ link(p)=mp_cur_tok(mp); p=link(p);
+ }
+ link(p)=tail_end; mp_flush_node_list(mp, subst_list);
+ return link(hold_head);
+}
+
+@ @<Substitute for |cur_sym|...@>=
+{
+ q=subst_list;
+ while ( q!=null ) {
+ if ( info(q)==mp->cur_sym ) {
+ mp->cur_sym=value(q); mp->cur_cmd=relax; break;
+ }
+ q=link(q);
+ }
+}
+
+@ @<Adjust the balance; |break| if it's zero@>=
+if ( mp->cur_mod>0 ) {
+ incr(balance);
+} else {
+ decr(balance);
+ if ( balance==0 )
+ break;
+}
+
+@ Four commands are intended to be used only within macro texts: \&{quote},
+\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
+code called |macro_special|.
+
+@d quote 0 /* |macro_special| modifier for \&{quote} */
+@d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
+@d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
+@d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
+
+@<Put each...@>=
+mp_primitive(mp, "quote",macro_special,quote);
+@:quote_}{\&{quote} primitive@>
+mp_primitive(mp, "#@@",macro_special,macro_prefix);
+@:]]]\#\AT!_}{\.{\#\AT!} primitive@>
+mp_primitive(mp, "@@",macro_special,macro_at);
+@:]]]\AT!_}{\.{\AT!} primitive@>
+mp_primitive(mp, "@@#",macro_special,macro_suffix);
+@:]]]\AT!\#_}{\.{\AT!\#} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case macro_special:
+ switch (m) {
+ case macro_prefix: mp_print(mp, "#@@"); break;
+ case macro_at: mp_print_char(mp, '@@'); break;
+ case macro_suffix: mp_print(mp, "@@#"); break;
+ default: mp_print(mp, "quote"); break;
+ }
+ break;
+
+@ @<Handle quoted...@>=
+{
+ if ( mp->cur_mod==quote ) { get_t_next; }
+ else if ( mp->cur_mod<=suffix_count )
+ mp->cur_sym=suffix_base-1+mp->cur_mod;
+}
+
+@ Here is a routine that's used whenever a token will be redefined. If
+the user's token is unredefinable, the `|frozen_inaccessible|' token is
+substituted; the latter is redefinable but essentially impossible to use,
+hence \MP's tables won't get fouled up.
+
+@c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
+RESTART:
+ get_t_next;
+ if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
+ print_err("Missing symbolic token inserted");
+@.Missing symbolic token...@>
+ help3("Sorry: You can\'t redefine a number, string, or expr.")
+ ("I've inserted an inaccessible symbol so that your")
+ ("definition will be completed without mixing me up too badly.");
+ if ( mp->cur_sym>0 )
+ mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
+ else if ( mp->cur_cmd==string_token )
+ delete_str_ref(mp->cur_mod);
+ mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
+ }
+}
+
+@ Before we actually redefine a symbolic token, we need to clear away its
+former value, if it was a variable. The following stronger version of
+|get_symbol| does that.
+
+@c void mp_get_clear_symbol (MP mp) {
+ mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
+}
+
+@ Here's another little subroutine; it checks that an equals sign
+or assignment sign comes along at the proper place in a macro definition.
+
+@c void mp_check_equals (MP mp) {
+ if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
+ mp_missing_err(mp, "=");
+@.Missing `='@>
+ help5("The next thing in this `def' should have been `=',")
+ ("because I've already looked at the definition heading.")
+ ("But don't worry; I'll pretend that an equals sign")
+ ("was present. Everything from here to `enddef'")
+ ("will be the replacement text of this macro.");
+ mp_back_error(mp);
+ }
+}
+
+@ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
+handled now that we have |scan_toks|. In this case there are
+two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
+|expr_base| and |expr_base+1|).
+
+@c void mp_make_op_def (MP mp) {
+ command_code m; /* the type of definition */
+ pointer p,q,r; /* for list manipulation */
+ m=mp->cur_mod;
+ mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
+ info(q)=mp->cur_sym; value(q)=expr_base;
+ mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
+ mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
+ info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
+ get_t_next; mp_check_equals(mp);
+ mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
+ r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
+ link(r)=mp_scan_toks(mp, macro_def,p,null,0);
+ mp->scanner_status=normal; eq_type(mp->warning_info)=m;
+ equiv(mp->warning_info)=q; mp_get_x_next(mp);
+}
+
+@ Parameters to macros are introduced by the keywords \&{expr},
+\&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
+
+@<Put each...@>=
+mp_primitive(mp, "expr",param_type,expr_base);
+@:expr_}{\&{expr} primitive@>
+mp_primitive(mp, "suffix",param_type,suffix_base);
+@:suffix_}{\&{suffix} primitive@>
+mp_primitive(mp, "text",param_type,text_base);
+@:text_}{\&{text} primitive@>
+mp_primitive(mp, "primary",param_type,primary_macro);
+@:primary_}{\&{primary} primitive@>
+mp_primitive(mp, "secondary",param_type,secondary_macro);
+@:secondary_}{\&{secondary} primitive@>
+mp_primitive(mp, "tertiary",param_type,tertiary_macro);
+@:tertiary_}{\&{tertiary} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case param_type:
+ if ( m>=expr_base ) {
+ if ( m==expr_base ) mp_print(mp, "expr");
+ else if ( m==suffix_base ) mp_print(mp, "suffix");
+ else mp_print(mp, "text");
+ } else if ( m<secondary_macro ) {
+ mp_print(mp, "primary");
+ } else if ( m==secondary_macro ) {
+ mp_print(mp, "secondary");
+ } else {
+ mp_print(mp, "tertiary");
+ }
+ break;
+
+@ Let's turn next to the more complex processing associated with \&{def}
+and \&{vardef}. When the following procedure is called, |cur_mod|
+should be either |start_def| or |var_def|.
+
+@c @<Declare the procedure called |check_delimiter|@>
+@<Declare the function called |scan_declared_variable|@>
+void mp_scan_def (MP mp) {
+ int m; /* the type of definition */
+ int n; /* the number of special suffix parameters */
+ int k; /* the total number of parameters */
+ int c; /* the kind of macro we're defining */
+ pointer r; /* parameter-substitution list */
+ pointer q; /* tail of the macro token list */
+ pointer p; /* temporary storage */
+ halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
+ pointer l_delim,r_delim; /* matching delimiters */
+ m=mp->cur_mod; c=general_macro; link(hold_head)=null;
+ q=mp_get_avail(mp); ref_count(q)=null; r=null;
+ @<Scan the token or variable to be defined;
+ set |n|, |scanner_status|, and |warning_info|@>;
+ k=n;
+ if ( mp->cur_cmd==left_delimiter ) {
+ @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
+ }
+ if ( mp->cur_cmd==param_type ) {
+ @<Absorb undelimited parameters, putting them into list |r|@>;
+ }
+ mp_check_equals(mp);
+ p=mp_get_avail(mp); info(p)=c; link(q)=p;
+ @<Attach the replacement text to the tail of node |p|@>;
+ mp->scanner_status=normal; mp_get_x_next(mp);
+}
+
+@ We don't put `|frozen_end_group|' into the replacement text of
+a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
+
+@<Attach the replacement text to the tail of node |p|@>=
+if ( m==start_def ) {
+ link(p)=mp_scan_toks(mp, macro_def,r,null,n);
+} else {
+ q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
+ p=mp_get_avail(mp); info(p)=mp->eg_loc;
+ link(q)=mp_scan_toks(mp, macro_def,r,p,n);
+}
+if ( mp->warning_info==bad_vardef )
+ mp_flush_token_list(mp, value(bad_vardef))
+
+@ @<Glob...@>=
+int bg_loc;
+int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
+
+@ @<Scan the token or variable to be defined;...@>=
+if ( m==start_def ) {
+ mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
+ mp->scanner_status=op_defining; n=0;
+ eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
+} else {
+ p=mp_scan_declared_variable(mp);
+ mp_flush_variable(mp, equiv(info(p)),link(p),true);
+ mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
+ if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
+ mp->scanner_status=var_defining; n=2;
+ if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
+ n=3; get_t_next;
+ }
+ type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
+} /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
+
+@ @<Change to `\.{a bad variable}'@>=
+{
+ print_err("This variable already starts with a macro");
+@.This variable already...@>
+ help2("After `vardef a' you can\'t say `vardef a.b'.")
+ ("So I'll have to discard this definition.");
+ mp_error(mp); mp->warning_info=bad_vardef;
+}
+
+@ @<Initialize table entries...@>=
+name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
+equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
+
+@ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
+do {
+ l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
+ if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
+ base=mp->cur_mod;
+ } else {
+ print_err("Missing parameter type; `expr' will be assumed");
+@.Missing parameter type@>
+ help1("You should've had `expr' or `suffix' or `text' here.");
+ mp_back_error(mp); base=expr_base;
+ }
+ @<Absorb parameter tokens for type |base|@>;
+ mp_check_delimiter(mp, l_delim,r_delim);
+ get_t_next;
+} while (mp->cur_cmd==left_delimiter)
+
+@ @<Absorb parameter tokens for type |base|@>=
+do {
+ link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
+ mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
+ value(p)=base+k; info(p)=mp->cur_sym;
+ if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
+@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
+ incr(k); link(p)=r; r=p; get_t_next;
+} while (mp->cur_cmd==comma)
+
+@ @<Absorb undelimited parameters, putting them into list |r|@>=
+{
+ p=mp_get_node(mp, token_node_size);
+ if ( mp->cur_mod<expr_base ) {
+ c=mp->cur_mod; value(p)=expr_base+k;
+ } else {
+ value(p)=mp->cur_mod+k;
+ if ( mp->cur_mod==expr_base ) c=expr_macro;
+ else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
+ else c=text_macro;
+ }
+ if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
+ incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
+ if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
+ c=of_macro; p=mp_get_node(mp, token_node_size);
+ if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
+ value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
+ link(p)=r; r=p; get_t_next;
+ }
+}
+
+@* \[32] Expanding the next token.
+Only a few command codes |<min_command| can possibly be returned by
+|get_t_next|; in increasing order, they are
+|if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
+|exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
+
+\MP\ usually gets the next token of input by saying |get_x_next|. This is
+like |get_t_next| except that it keeps getting more tokens until
+finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
+macros and removes conditionals or iterations or input instructions that
+might be present.
+
+It follows that |get_x_next| might invoke itself recursively. In fact,
+there is massive recursion, since macro expansion can involve the
+scanning of arbitrarily complex expressions, which in turn involve
+macro expansion and conditionals, etc.
+@^recursion@>
+
+Therefore it's necessary to declare a whole bunch of |forward|
+procedures at this point, and to insert some other procedures
+that will be invoked by |get_x_next|.
+
+@<Declarations@>=
+void mp_scan_primary (MP mp);
+void mp_scan_secondary (MP mp);
+void mp_scan_tertiary (MP mp);
+void mp_scan_expression (MP mp);
+void mp_scan_suffix (MP mp);
+@<Declare the procedure called |macro_call|@>
+void mp_get_boolean (MP mp);
+void mp_pass_text (MP mp);
+void mp_conditional (MP mp);
+void mp_start_input (MP mp);
+void mp_begin_iteration (MP mp);
+void mp_resume_iteration (MP mp);
+void mp_stop_iteration (MP mp);
+
+@ An auxiliary subroutine called |expand| is used by |get_x_next|
+when it has to do exotic expansion commands.
+
+@c void mp_expand (MP mp) {
+ pointer p; /* for list manipulation */
+ size_t k; /* something that we hope is |<=buf_size| */
+ pool_pointer j; /* index into |str_pool| */
+ if ( mp->internal[mp_tracing_commands]>unity )
+ if ( mp->cur_cmd!=defined_macro )
+ show_cur_cmd_mod;
+ switch (mp->cur_cmd) {
+ case if_test:
+ mp_conditional(mp); /* this procedure is discussed in Part 36 below */
+ break;
+ case fi_or_else:
+ @<Terminate the current conditional and skip to \&{fi}@>;
+ break;
+ case input:
+ @<Initiate or terminate input from a file@>;
+ break;
+ case iteration:
+ if ( mp->cur_mod==end_for ) {
+ @<Scold the user for having an extra \&{endfor}@>;
+ } else {
+ mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
+ }
+ break;
+ case repeat_loop:
+ @<Repeat a loop@>;
+ break;
+ case exit_test:
+ @<Exit a loop if the proper time has come@>;
+ break;
+ case relax:
+ break;
+ case expand_after:
+ @<Expand the token after the next token@>;
+ break;
+ case scan_tokens:
+ @<Put a string into the input buffer@>;
+ break;
+ case defined_macro:
+ mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
+ break;
+ }; /* there are no other cases */
+}
+
+@ @<Scold the user...@>=
+{
+ print_err("Extra `endfor'");
+@.Extra `endfor'@>
+ help2("I'm not currently working on a for loop,")
+ ("so I had better not try to end anything.");
+ mp_error(mp);
+}
+
+@ The processing of \&{input} involves the |start_input| subroutine,
+which will be declared later; the processing of \&{endinput} is trivial.
+
+@<Put each...@>=
+mp_primitive(mp, "input",input,0);
+@:input_}{\&{input} primitive@>
+mp_primitive(mp, "endinput",input,1);
+@:end_input_}{\&{endinput} primitive@>
+
+@ @<Cases of |print_cmd_mod|...@>=
+case input:
+ if ( m==0 ) mp_print(mp, "input");
+ else mp_print(mp, "endinput");
+ break;
+
+@ @<Initiate or terminate input...@>=
+if ( mp->cur_mod>0 ) mp->force_eof=true;
+else mp_start_input(mp)
+
+@ We'll discuss the complicated parts of loop operations later. For now
+it suffices to know that there's a global variable called |loop_ptr|
+that will be |null| if no loop is in progress.
+
+@<Repeat a loop@>=
+{ while ( token_state &&(loc==null) )
+ mp_end_token_list(mp); /* conserve stack space */
+ if ( mp->loop_ptr==null ) {
+ print_err("Lost loop");
+@.Lost loop@>
+ help2("I'm confused; after exiting from a loop, I still seem")
+ ("to want to repeat it. I'll try to forget the problem.");
+ mp_error(mp);
+ } else {
+ mp_resume_iteration(mp); /* this procedure is in Part 37 below */
+ }
+}
+
+@ @<Exit a loop if the proper time has come@>=
+{ mp_get_boolean(mp);
+ if ( mp->internal[mp_tracing_commands]>unity )
+ mp_show_cmd_mod(mp, nullary,mp->cur_exp);
+ if ( mp->cur_exp==true_code ) {
+ if ( mp->loop_ptr==null ) {
+ print_err("No loop is in progress");
+@.No loop is in progress@>
+ help1("Why say `exitif' when there's nothing to exit from?");
+ if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
+ } else {
+ @<Exit prematurely from an iteration@>;
+ }
+ } else if ( mp->cur_cmd!=semicolon ) {
+ mp_missing_err(mp, ";");
+@.Missing `;'@>
+ help2("After `exitif <boolean exp>' I expect to see a semicolon.")
+ ("I shall pretend that one was there."); mp_back_error(mp);
+ }
+}
+
+@ Here we use the fact that |forever_text| is the only |token_type| that
+is less than |loop_text|.
+
+@<Exit prematurely...@>=
+{ p=null;
+ do {
+ if ( file_state ) {
+ mp_end_file_reading(mp);
+ } else {
+ if ( token_type<=loop_text ) p=start;
+ mp_end_token_list(mp);
+ }
+ } while (p==null);
+ if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
+@.loop confusion@>
+ mp_stop_iteration(mp); /* this procedure is in Part 34 below */
+}
+
+@ @<Expand the token after the next token@>=
+{ get_t_next;
+ p=mp_cur_tok(mp); get_t_next;
+ if ( mp->cur_cmd<min_command ) mp_expand(mp);
+ else mp_back_input(mp);
+ back_list(p);
+}
+
+@ @<Put a string into the input buffer@>=
+{ mp_get_x_next(mp); mp_scan_primary(mp);
+ if ( mp->cur_type!=mp_string_type ) {
+ mp_disp_err(mp, null,"Not a string");
+@.Not a string@>
+ help2("I'm going to flush this expression, since")
+ ("scantokens should be followed by a known string.");
+ mp_put_get_flush_error(mp, 0);
+ } else {
+ mp_back_input(mp);
+ if ( length(mp->cur_exp)>0 )
+ @<Pretend we're reading a new one-line file@>;
+ }
+}
+
+@ @<Pretend we're reading a new one-line file@>=
+{ mp_begin_file_reading(mp); name=is_scantok;
+ k=mp->first+length(mp->cur_exp);
+ if ( k>=mp->max_buf_stack ) {
+ while ( k>=mp->buf_size ) {
+ mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
+ }
+ mp->max_buf_stack=k+1;
+ }
+ j=mp->str_start[mp->cur_exp]; limit=k;
+ while ( mp->first<(size_t)limit ) {
+ mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
+ }
+ mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
+ mp_flush_cur_exp(mp, 0);
+}
+
+@ Here finally is |get_x_next|.
+
+The expression scanning routines to be considered later
+communicate via the global quantities |cur_type| and |cur_exp|;
+we must be very careful to save and restore these quantities while
+macros are being expanded.
+@^inner loop@>
+
+@<Declarations@>=
+void mp_get_x_next (MP mp);
+
+@ @c void mp_get_x_next (MP mp) {
+ pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
+ get_t_next;
+ if ( mp->cur_cmd<min_command ) {
+ save_exp=mp_stash_cur_exp(mp);
+ do {
+ if ( mp->cur_cmd==defined_macro )
+ mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
+ else
+ mp_expand(mp);
+ get_t_next;
+ } while (mp->cur_cmd<min_command);
+ mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
+ }
+}
+
+@ Now let's consider the |macro_call| procedure, which is used to start up
+all user-defined macros. Since the arguments to a macro might be expressions,
+|macro_call| is recursive.
+@^recursion@>
+
+The first parameter to |macro_call| points to the reference count of the
+token list that defines the macro. The second parameter contains any
+arguments that have already been parsed (see below). The third parameter
+points to the symbolic token that names the macro. If the third parameter
+is |null|, the macro was defined by \&{vardef}, so its name can be
+reconstructed from the prefix and ``at'' arguments found within the
+second parameter.
+
+What is this second parameter? It's simply a linked list of one-word items,
+whose |info| fields point to the arguments. In other words, if |arg_list=null|,
+no arguments have been scanned yet; otherwise |info(arg_list)| points to
+the first scanned argument, and |link(arg_list)| points to the list of
+further arguments (if any).
+
+Arguments of type \&{expr} are so-called capsules, which we will
+discuss later when we concentrate on expressions; they can be
+recognized easily because their |link| field is |void|. Arguments of type
+\&{suffix} and \&{text} are token lists without reference counts.
+
+@ After argument scanning is complete, the arguments are moved to the
+|param_stack|. (They can't be put on that stack any sooner, because
+the stack is growing and shrinking in unpredictable ways as more arguments
+are being acquired.) Then the macro body is fed to the scanner; i.e.,
+the replacement text of the macro is placed at the top of the \MP's
+input stack, so that |get_t_next| will proceed to read it next.
+
+@<Declare the procedure called |macro_call|@>=
+@<Declare the procedure called |print_macro_name|@>
+@<Declare the procedure called |print_arg|@>
+@<Declare the procedure called |scan_text_arg|@>
+void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
+ pointer macro_name) ;
+
+@ @c
+void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
+ pointer macro_name) {
+ /* invokes a user-defined control sequence */
+ pointer r; /* current node in the macro's token list */
+ pointer p,q; /* for list manipulation */
+ integer n; /* the number of arguments */
+ pointer tail = 0; /* tail of the argument list */
+ pointer l_delim=0,r_delim=0; /* a delimiter pair */
+ r=link(def_ref); add_mac_ref(def_ref);
+ if ( arg_list==null ) {
+ n=0;
+ } else {
+ @<Determine the number |n| of arguments already supplied,
+ and set |tail| to the tail of |arg_list|@>;
+ }
+ if ( mp->internal[mp_tracing_macros]>0 ) {
+ @<Show the text of the macro being expanded, and the existing arguments@>;
+ }
+ @<Scan the remaining arguments, if any; set |r| to the first token
+ of the replacement text@>;
+ @<Feed the arguments and replacement text to the scanner@>;
+}
+
+@ @<Show the text of the macro...@>=
+mp_begin_diagnostic(mp); mp_print_ln(mp);
+mp_print_macro_name(mp, arg_list,macro_name);
+if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
+mp_show_macro(mp, def_ref,null,100000);
+if ( arg_list!=null ) {
+ n=0; p=arg_list;
+ do {
+ q=info(p);
+ mp_print_arg(mp, q,n,0);
+ incr(n); p=link(p);
+ } while (p!=null);
+}
+mp_end_diagnostic(mp, false)
+
+
+@ @<Declare the procedure called |print_macro_name|@>=
+void mp_print_macro_name (MP mp,pointer a, pointer n);
+
+@ @c
+void mp_print_macro_name (MP mp,pointer a, pointer n) {
+ pointer p,q; /* they traverse the first part of |a| */
+ if ( n!=null ) {
+ mp_print_text(n);
+ } else {
+ p=info(a);
+ if ( p==null ) {
+ mp_print_text(info(info(link(a))));
+ } else {
+ q=p;
+ while ( link(q)!=null ) q=link(q);
+ link(q)=info(link(a));
+ mp_show_token_list(mp, p,null,1000,0);
+ link(q)=null;
+ }
+ }
+}
+
+@ @<Declare the procedure called |print_arg|@>=
+void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
+
+@ @c
+void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
+ if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
+ else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
+ else mp_print_nl(mp, "(TEXT");
+ mp_print_int(mp, n); mp_print(mp, ")<-");
+ if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
+ else mp_show_token_list(mp, q,null,1000,0);
+}
+
+@ @<Determine the number |n| of arguments already supplied...@>=
+{
+ n=1; tail=arg_list;
+ while ( link(tail)!=null ) {
+ incr(n); tail=link(tail);
+ }
+}
+
+@ @<Scan the remaining arguments, if any; set |r|...@>=
+mp->cur_cmd=comma+1; /* anything |<>comma| will do */
+while ( info(r)>=expr_base ) {
+ @<Scan the delimited argument represented by |info(r)|@>;
+ r=link(r);
+}
+if ( mp->cur_cmd==comma ) {
+ print_err("Too many arguments to ");
+@.Too many arguments...@>
+ mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
+ mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
+@.Missing `)'...@>
+ mp_print(mp, "' has been inserted");
+ help3("I'm going to assume that the comma I just read was a")
+ ("right delimiter, and then I'll begin expanding the macro.")
+ ("You might want to delete some tokens before continuing.");
+ mp_error(mp);
+}
+if ( info(r)!=general_macro ) {
+ @<Scan undelimited argument(s)@>;
+}
+r=link(r)
+
+@ At this point, the reader will find it advisable to review the explanation
+of token list format that was presented earlier, paying special attention to
+the conventions that apply only at the beginning of a macro's token list.
+
+On the other hand, the reader will have to take the expression-parsing
+aspects of the following program on faith; we will explain |cur_type|
+and |cur_exp| later. (Several things in this program depend on each other,
+and it's necessary to jump into the circle somewhere.)
+
+@<Scan the delimited argument represented by |info(r)|@>=
+if ( mp->cur_cmd!=comma ) {
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd!=left_delimiter ) {
+ print_err("Missing argument to ");
+@.Missing argument...@>
+ mp_print_macro_name(mp, arg_list,macro_name);
+ help3("That macro has more parameters than you thought.")
+ ("I'll continue by pretending that each missing argument")
+ ("is either zero or null.");
+ if ( info(r)>=suffix_base ) {
+ mp->cur_exp=null; mp->cur_type=mp_token_list;
+ } else {
+ mp->cur_exp=0; mp->cur_type=mp_known;
+ }
+ mp_back_error(mp); mp->cur_cmd=right_delimiter;
+ goto FOUND;
+ }
+ l_delim=mp->cur_sym; r_delim=mp->cur_mod;
+}
+@<Scan the argument represented by |info(r)|@>;
+if ( mp->cur_cmd!=comma )
+ @<Check that the proper right delimiter was present@>;
+FOUND:
+@<Append the current expression to |arg_list|@>
+
+@ @<Check that the proper right delim...@>=
+if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
+ if ( info(link(r))>=expr_base ) {
+ mp_missing_err(mp, ",");
+@.Missing `,'@>
+ help3("I've finished reading a macro argument and am about to")
+ ("read another; the arguments weren't delimited correctly.")
+ ("You might want to delete some tokens before continuing.");
+ mp_back_error(mp); mp->cur_cmd=comma;
+ } else {
+ mp_missing_err(mp, str(text(r_delim)));
+@.Missing `)'@>
+ help2("I've gotten to the end of the macro parameter list.")
+ ("You might want to delete some tokens before continuing.");
+ mp_back_error(mp);
+ }
+}
+
+@ A \&{suffix} or \&{text} parameter will have been scanned as
+a token list pointed to by |cur_exp|, in which case we will have
+|cur_type=token_list|.
+
+@<Append the current expression to |arg_list|@>=
+{
+ p=mp_get_avail(mp);
+ if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
+ else info(p)=mp_stash_cur_exp(mp);
+ if ( mp->internal[mp_tracing_macros]>0 ) {
+ mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
+ mp_end_diagnostic(mp, false);
+ }
+ if ( arg_list==null ) arg_list=p;
+ else link(tail)=p;
+ tail=p; incr(n);
+}
+
+@ @<Scan the argument represented by |info(r)|@>=
+if ( info(r)>=text_base ) {
+ mp_scan_text_arg(mp, l_delim,r_delim);
+} else {
+ mp_get_x_next(mp);
+ if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
+ else mp_scan_expression(mp);
+}
+
+@ The parameters to |scan_text_arg| are either a pair of delimiters
+or zero; the latter case is for undelimited text arguments, which
+end with the first semicolon or \&{endgroup} or \&{end} that is not
+contained in a group.
+
+@<Declare the procedure called |scan_text_arg|@>=
+void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
+
+@ @c
+void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
+ integer balance; /* excess of |l_delim| over |r_delim| */
+ pointer p; /* list tail */
+ mp->warning_info=l_delim; mp->scanner_status=absorbing;
+ p=hold_head; balance=1; link(hold_head)=null;
+ while (1) {
+ get_t_next;
+ if ( l_delim==0 ) {
+ @<Adjust the balance for an undelimited argument; |break| if done@>;
+ } else {
+ @<Adjust the balance for a delimited argument; |break| if done@>;
+ }
+ link(p)=mp_cur_tok(mp); p=link(p);
+ }
+ mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
+ mp->scanner_status=normal;
+}
+
+@ @<Adjust the balance for a delimited argument...@>=
+if ( mp->cur_cmd==right_delimiter ) {
+ if ( mp->cur_mod==l_delim ) {
+ decr(balance);
+ if ( balance==0 ) break;
+ }
+} else if ( mp->cur_cmd==left_delimiter ) {
+ if ( mp->cur_mod==r_delim ) incr(balance);
+}
+
+@ @<Adjust the balance for an undelimited...@>=
+if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
+ if ( balance==1 ) { break; }
+ else { if ( mp->cur_cmd==end_group ) decr(balance); }
+} else if ( mp->cur_cmd==begin_group ) {
+ incr(balance);
+}
+
+@ @<Scan undelimited argument(s)@>=
+{
+ if ( info(r)<text_macro ) {
+ mp_get_x_next(mp);
+ if ( info(r)!=suffix_macro ) {
+ if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
+ }
+ }
+ switch (info(r)) {
+ case primary_macro:mp_scan_primary(mp); break;
+ case secondary_macro:mp_scan_secondary(mp); break;
+ case tertiary_macro:mp_scan_tertiary(mp); break;
+ case expr_macro:mp_scan_expression(mp); break;
+ case of_macro:
+ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
+ break;
+ case suffix_macro:
+ @<Scan a suffix with optional delimiters@>;
+ break;
+ case text_macro:mp_scan_text_arg(mp, 0,0); break;
+ } /* there are no other cases */
+ mp_back_input(mp);
+ @<Append the current expression to |arg_list|@>;
+}
+
+@ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
+{
+ mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
+ if ( mp->internal[mp_tracing_macros]>0 ) {
+ mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
+ mp_end_diagnostic(mp, false);
+ }
+ if ( arg_list==null ) arg_list=p; else link(tail)=p;
+ tail=p;incr(n);
+ if ( mp->cur_cmd!=of_token ) {
+ mp_missing_err(mp, "of"); mp_print(mp, " for ");
+@.Missing `of'@>
+ mp_print_macro_name(mp, arg_list,macro_name);
+ help1("I've got the first argument; will look now for the other.");
+ mp_back_error(mp);
+ }
+ mp_get_x_next(mp); mp_scan_primary(mp);
+}
+
+@ @<Scan a suffix with optional delimiters@>=
+{
+ if ( mp->cur_cmd!=left_delimiter ) {
+ l_delim=null;
+ } else {
+ l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
+ };
+ mp_scan_suffix(mp);
+ if ( l_delim!=null ) {
+ if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
+ mp_missing_err(mp, str(text(r_delim)));
+@.Missing `)'@>
+ help2("I've gotten to the end of the macro parameter list.")
+ ("You might want to delete some tokens before continuing.");
+ mp_back_error(mp);
+ }
+ mp_get_x_next(mp);
+ }
+}
+
+@ Before we put a new token list on the input stack, it is wise to clean off
+all token lists that have recently been depleted. Then a user macro that ends
+with a call to itself will not require unbounded stack space.
+
+@<Feed the arguments and replacement text to the scanner@>=
+while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
+if ( mp->param_ptr+n>mp->max_param_stack ) {
+ mp->max_param_stack=mp->param_ptr+n;
+ if ( mp->max_param_stack>mp->param_size )
+ mp_overflow(mp, "parameter stack size",mp->param_size);
+@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
+}
+mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
+if ( n>0 ) {
+ p=arg_list;
+ do {
+ mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
+ } while (p!=null);
+ mp_flush_list(mp, arg_list);
+}
+
+@ It's sometimes necessary to put a single argument onto |param_stack|.
+The |stack_argument| subroutine does this.
+
+@c void mp_stack_argument (MP mp,pointer p) {
+ if ( mp->param_ptr==mp->max_param_stack ) {
+ incr(mp->max_param_stack);
+ if ( mp->max_param_stack>mp->param_size )
+ mp_overflow(mp, "parameter stack size",mp->param_size);
+@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
+ }
+ mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
+}
+
+@* \[33] Conditional processing.
+Let's consider now the way \&{if} commands are handled.
+
+Conditions can be inside conditions, and this nesting has a stack
+that is independent of other stacks.
+Four global variables represent the top of the condition stack:
+|cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
+we are processing \&{if} or \&{elseif}; |if_limit| specifies
+the largest code of a |fi_or_else| command that is syntactically legal;
+and |if_line| is the line number at which the current conditional began.
+
+If no conditions are currently in progress, the condition stack has the
+special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
+Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
+|link| fields of the first word contain |if_limit|, |cur_if|, and
+|cond_ptr| at the next level, and the second word contains the
+corresponding |if_line|.
+
+@d if_node_size 2 /* number of words in stack entry for conditionals */
+@d if_line_field(A) mp->mem[(A)+1].cint
+@d if_code 1 /* code for \&{if} being evaluated */
+@d fi_code 2 /* code for \&{fi} */
+@d else_code 3 /* code for \&{else} */
+@d else_if_code 4 /* code for \&{elseif} */
+
+@<Glob...@>=
+pointer cond_ptr; /* top of the condition stack */
+integer if_limit; /* upper bound on |fi_or_else| codes */
+small_number cur_if; /* type of conditional being worked on */
+integer if_line; /* line where that conditional began */
+
+@ @<Set init...@>=
+mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
+
+@ @<Put each...@>=
+mp_primitive(mp, "if",if_test,if_code);
+@:if_}{\&{if} primitive@>
+mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
+@:fi_}{\&{fi} primitive@>
+mp_primitive(mp, "else",fi_or_else,else_code);
+@:else_}{\&{else} primitive@>
+mp_primitive(mp, "elseif",fi_or_else,else_if_code);
+@:else_if_}{\&{elseif} primitive@>
+
+@ @<Cases of |print_cmd_mod|...@>=
+case if_test:
+case fi_or_else:
+ switch (m) {
+ case if_code:mp_print(mp, "if"); break;
+ case fi_code:mp_print(mp, "fi"); break;
+ case else_code:mp_print(mp, "else"); break;
+ default: mp_print(mp, "elseif"); break;
+ }
+ break;
+
+@ Here is a procedure that ignores text until coming to an \&{elseif},
+\&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
+nesting. After it has acted, |cur_mod| will indicate the token that
+was found.
+
+\MP's smallest two command codes are |if_test| and |fi_or_else|; this
+makes the skipping process a bit simpler.
+
+@c
+void mp_pass_text (MP mp) {
+ integer l = 0;
+ mp->scanner_status=skipping;
+ mp->warning_info=mp_true_line(mp);
+ while (1) {
+ get_t_next;
+ if ( mp->cur_cmd<=fi_or_else ) {
+ if ( mp->cur_cmd<fi_or_else ) {
+ incr(l);
+ } else {
+ if ( l==0 ) break;
+ if ( mp->cur_mod==fi_code ) decr(l);
+ }
+ } else {
+ @<Decrease the string reference count,
+ if the current token is a string@>;
+ }
+ }
+ mp->scanner_status=normal;
+}
+
+@ @<Decrease the string reference count...@>=
+if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
+
+@ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
+if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
+condition has been evaluated, a colon will be inserted.
+A construction like `\.{if fi}' would otherwise get \MP\ confused.
+
+@<Push the condition stack@>=
+{ p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
+ name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
+ mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
+ mp->cur_if=if_code;
+}
+
+@ @<Pop the condition stack@>=
+{ p=mp->cond_ptr; mp->if_line=if_line_field(p);
+ mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
+ mp_free_node(mp, p,if_node_size);
+}
+
+@ Here's a procedure that changes the |if_limit| code corresponding to
+a given value of |cond_ptr|.
+
+@c void mp_change_if_limit (MP mp,small_number l, pointer p) {
+ pointer q;
+ if ( p==mp->cond_ptr ) {
+ mp->if_limit=l; /* that's the easy case */
+ } else {
+ q=mp->cond_ptr;
+ while (1) {
+ if ( q==null ) mp_confusion(mp, "if");
+@:this can't happen if}{\quad if@>
+ if ( link(q)==p ) {
+ type(q)=l; return;
+ }
+ q=link(q);
+ }
+ }
+}
+
+@ The user is supposed to put colons into the proper parts of conditional
+statements. Therefore, \MP\ has to check for their presence.
+
+@c
+void mp_check_colon (MP mp) {
+ if ( mp->cur_cmd!=colon ) {
+ mp_missing_err(mp, ":");
+@.Missing `:'@>
+ help2("There should've been a colon after the condition.")
+ ("I shall pretend that one was there.");;
+ mp_back_error(mp);
+ }
+}
+
+@ A condition is started when the |get_x_next| procedure encounters
+an |if_test| command; in that case |get_x_next| calls |conditional|,
+which is a recursive procedure.
+@^recursion@>
+
+@c void mp_conditional (MP mp) {
+ pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
+ int new_if_limit; /* future value of |if_limit| */
+ pointer p; /* temporary register */
+ @<Push the condition stack@>;
+ save_cond_ptr=mp->cond_ptr;
+RESWITCH:
+ mp_get_boolean(mp); new_if_limit=else_if_code;
+ if ( mp->internal[mp_tracing_commands]>unity ) {
+ @<Display the boolean value of |cur_exp|@>;
+ }
+FOUND:
+ mp_check_colon(mp);
+ if ( mp->cur_exp==true_code ) {
+ mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
+ return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
+ };
+ @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
+DONE:
+ mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
+ if ( mp->cur_mod==fi_code ) {
+ @<Pop the condition stack@>
+ } else if ( mp->cur_mod==else_if_code ) {
+ goto RESWITCH;
+ } else {
+ mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
+ goto FOUND;
+ }
+}
+
+@ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
+\&{else}: \\{bar} \&{fi}', the first \&{else}
+that we come to after learning that the \&{if} is false is not the
+\&{else} we're looking for. Hence the following curious logic is needed.
+
+@<Skip to \&{elseif}...@>=
+while (1) {
+ mp_pass_text(mp);
+ if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
+ else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
+}
+
+
+@ @<Display the boolean value...@>=
+{ mp_begin_diagnostic(mp);
+ if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
+ else mp_print(mp, "{false}");
+ mp_end_diagnostic(mp, false);
+}
+
+@ The processing of conditionals is complete except for the following
+code, which is actually part of |get_x_next|. It comes into play when
+\&{elseif}, \&{else}, or \&{fi} is scanned.
+
+@<Terminate the current conditional and skip to \&{fi}@>=
+if ( mp->cur_mod>mp->if_limit ) {
+ if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
+ mp_missing_err(mp, ":");
+@.Missing `:'@>
+ mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
+ } else {
+ print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
+@.Extra else@>
+@.Extra elseif@>
+@.Extra fi@>
+ help1("I'm ignoring this; it doesn't match any if.");
+ mp_error(mp);
+ }
+} else {
+ while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
+ @<Pop the condition stack@>;
+}
+
+@* \[34] Iterations.
+To bring our treatment of |get_x_next| to a close, we need to consider what
+\MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
+
+There's a global variable |loop_ptr| that keeps track of the \&{for} loops
+that are currently active. If |loop_ptr=null|, no loops are in progress;
+otherwise |info(loop_ptr)| points to the iterative text of the current
+(innermost) loop, and |link(loop_ptr)| points to the data for any other
+loops that enclose the current one.
+
+A loop-control node also has two other fields, called |loop_type| and
+|loop_list|, whose contents depend on the type of loop:
+
+\yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
+points to a list of one-word nodes whose |info| fields point to the
+remaining argument values of a suffix list and expression list.
+
+\yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
+`\&{forever}'.
+
+\yskip\indent|loop_type(loop_ptr)=progression_flag| means that
+|p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
+|step_size(p)|, and |final_value(p)| contain the data for an arithmetic
+progression.
+
+\yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
+header and |loop_list(loop_ptr)| points into the graphical object list for
+that edge header.
+
+\yskip\noindent In the case of a progression node, the first word is not used
+because the link field of words in the dynamic memory area cannot be arbitrary.
+
+@d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
+@d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
+@d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
+@d loop_node_size 2 /* the number of words in a loop control node */
+@d progression_node_size 4 /* the number of words in a progression node */
+@d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
+@d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
+@d progression_flag (null+2)
+ /* |loop_type| value when |loop_list| points to a progression node */
+
+@<Glob...@>=
+pointer loop_ptr; /* top of the loop-control-node stack */
+
+@ @<Set init...@>=
+mp->loop_ptr=null;
+
+@ If the expressions that define an arithmetic progression in
+a \&{for} loop don't have known numeric values, the |bad_for|
+subroutine screams at the user.
+
+@c void mp_bad_for (MP mp, const char * s) {
+ mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
+@.Improper...replaced by 0@>
+ mp_print(mp, s); mp_print(mp, " has been replaced by 0");
+ help4("When you say `for x=a step b until c',")
+ ("the initial value `a' and the step size `b'")
+ ("and the final value `c' must have known numeric values.")
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_put_get_flush_error(mp, 0);
+}
+
+@ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
+has just been scanned. (This code requires slight familiarity with
+expression-parsing routines that we have not yet discussed; but it seems
+to belong in the present part of the program, even though the original author
+didn't write it until later. The reader may wish to come back to it.)
+
+@c void mp_begin_iteration (MP mp) {
+ halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
+ halfword n; /* hash address of the current symbol */
+ pointer s; /* the new loop-control node */
+ pointer p; /* substitution list for |scan_toks| */
+ pointer q; /* link manipulation register */
+ pointer pp; /* a new progression node */
+ m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
+ if ( m==start_forever ){
+ loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
+ } else {
+ mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
+ info(p)=mp->cur_sym; value(p)=m;
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd==within_token ) {
+ @<Set up a picture iteration@>;
+ } else {
+ @<Check for the |"="| or |":="| in a loop header@>;
+ @<Scan the values to be used in the loop@>;
+ }
+ }
+ @<Check for the presence of a colon@>;
+ @<Scan the loop text and put it on the loop control stack@>;
+ mp_resume_iteration(mp);
+}
+
+@ @<Check for the |"="| or |":="| in a loop header@>=
+if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
+ mp_missing_err(mp, "=");
+@.Missing `='@>
+ help3("The next thing in this loop should have been `=' or `:='.")
+ ("But don't worry; I'll pretend that an equals sign")
+ ("was present, and I'll look for the values next.");
+ mp_back_error(mp);
+}
+
+@ @<Check for the presence of a colon@>=
+if ( mp->cur_cmd!=colon ) {
+ mp_missing_err(mp, ":");
+@.Missing `:'@>
+ help3("The next thing in this loop should have been a `:'.")
+ ("So I'll pretend that a colon was present;")
+ ("everything from here to `endfor' will be iterated.");
+ mp_back_error(mp);
+}
+
+@ We append a special |frozen_repeat_loop| token in place of the
+`\&{endfor}' at the end of the loop. This will come through \MP's scanner
+at the proper time to cause the loop to be repeated.
+
+(If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
+he will be foiled by the |get_symbol| routine, which keeps frozen
+tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
+token, so it won't be lost accidentally.)
+
+@ @<Scan the loop text...@>=
+q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
+mp->scanner_status=loop_defining; mp->warning_info=n;
+info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
+link(s)=mp->loop_ptr; mp->loop_ptr=s
+
+@ @<Initialize table...@>=
+eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
+text(frozen_repeat_loop)=intern(" ENDFOR");
+
+@ The loop text is inserted into \MP's scanning apparatus by the
+|resume_iteration| routine.
+
+@c void mp_resume_iteration (MP mp) {
+ pointer p,q; /* link registers */
+ p=loop_type(mp->loop_ptr);
+ if ( p==progression_flag ) {
+ p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
+ mp->cur_exp=value(p);
+ if ( @<The arithmetic progression has ended@> ) {
+ mp_stop_iteration(mp);
+ return;
+ }
+ mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
+ value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
+ } else if ( p==null ) {
+ p=loop_list(mp->loop_ptr);
+ if ( p==null ) {
+ mp_stop_iteration(mp);
+ return;
+ }
+ loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
+ } else if ( p==mp_void ) {
+ mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
+ } else {
+ @<Make |q| a capsule containing the next picture component from
+ |loop_list(loop_ptr)| or |goto not_found|@>;
+ }
+ mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
+ mp_stack_argument(mp, q);
+ if ( mp->internal[mp_tracing_commands]>unity ) {
+ @<Trace the start of a loop@>;
+ }
+ return;
+NOT_FOUND:
+ mp_stop_iteration(mp);
+}
+
+@ @<The arithmetic progression has ended@>=
+((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
+ ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
+
+@ @<Trace the start of a loop@>=
+{
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
+@.loop value=n@>
+ if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
+ else mp_show_token_list(mp, q,null,50,0);
+ mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
+}
+
+@ @<Make |q| a capsule containing the next picture component from...@>=
+{ q=loop_list(mp->loop_ptr);
+ if ( q==null ) goto NOT_FOUND;
+ skip_component(q) goto NOT_FOUND;
+ mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
+ mp_init_bbox(mp, mp->cur_exp);
+ mp->cur_type=mp_picture_type;
+ loop_list(mp->loop_ptr)=q;
+ q=mp_stash_cur_exp(mp);
+}
+
+@ A level of loop control disappears when |resume_iteration| has decided
+not to resume, or when an \&{exitif} construction has removed the loop text
+from the input stack.
+
+@c void mp_stop_iteration (MP mp) {
+ pointer p,q; /* the usual */
+ p=loop_type(mp->loop_ptr);
+ if ( p==progression_flag ) {
+ mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
+ } else if ( p==null ){
+ q=loop_list(mp->loop_ptr);
+ while ( q!=null ) {
+ p=info(q);
+ if ( p!=null ) {
+ if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
+ mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
+ } else {
+ mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
+ }
+ }
+ p=q; q=link(q); free_avail(p);
+ }
+ } else if ( p>progression_flag ) {
+ delete_edge_ref(p);
+ }
+ p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
+ mp_free_node(mp, p,loop_node_size);
+}
+
+@ Now that we know all about loop control, we can finish up
+the missing portion of |begin_iteration| and we'll be done.
+
+The following code is performed after the `\.=' has been scanned in
+a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
+(if |m=suffix_base|).
+
+@<Scan the values to be used in the loop@>=
+loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
+do {
+ mp_get_x_next(mp);
+ if ( m!=expr_base ) {
+ mp_scan_suffix(mp);
+ } else {
+ if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
+ goto CONTINUE;
+ mp_scan_expression(mp);
+ if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
+ @<Prepare for step-until construction and |break|@>;
+ }
+ mp->cur_exp=mp_stash_cur_exp(mp);
+ }
+ link(q)=mp_get_avail(mp); q=link(q);
+ info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
+CONTINUE:
+ ;
+} while (mp->cur_cmd==comma)
+
+@ @<Prepare for step-until construction and |break|@>=
+{
+ if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
+ pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
+ step_size(pp)=mp->cur_exp;
+ if ( mp->cur_cmd!=until_token ) {
+ mp_missing_err(mp, "until");
+@.Missing `until'@>
+ help2("I assume you meant to say `until' after `step'.")
+ ("So I'll look for the final value and colon next.");
+ mp_back_error(mp);
+ }
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
+ final_value(pp)=mp->cur_exp; loop_list(s)=pp;
+ loop_type(s)=progression_flag;
+ break;
+}
+
+@ The last case is when we have just seen ``\&{within}'', and we need to
+parse a picture expression and prepare to iterate over it.
+
+@<Set up a picture iteration@>=
+{ mp_get_x_next(mp);
+ mp_scan_expression(mp);
+ @<Make sure the current expression is a known picture@>;
+ loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
+ q=link(dummy_loc(mp->cur_exp));
+ if ( q!= null )
+ if ( is_start_or_stop(q) )
+ if ( mp_skip_1component(mp, q)==null ) q=link(q);
+ loop_list(s)=q;
+}
+
+@ @<Make sure the current expression is a known picture@>=
+if ( mp->cur_type!=mp_picture_type ) {
+ mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
+ help1("When you say `for x in p', p must be a known picture.");
+ mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
+ mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
+}
+
+@* \[35] File names.
+It's time now to fret about file names. Besides the fact that different
+operating systems treat files in different ways, we must cope with the
+fact that completely different naming conventions are used by different
+groups of people. The following programs show what is required for one
+particular operating system; similar routines for other systems are not
+difficult to devise.
+@^system dependencies@>
+
+\MP\ assumes that a file name has three parts: the name proper; its
+``extension''; and a ``file area'' where it is found in an external file
+system. The extension of an input file is assumed to be
+`\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
+transcript file that records each run of \MP; it is `\.{.tfm}' on the font
+metric files that describe characters in any fonts created by \MP; it is
+`\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
+and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
+The file area can be arbitrary on input files, but files are usually
+output to the user's current area. If an input file cannot be
+found on the specified area, \MP\ will look for it on a special system
+area; this special area is intended for commonly used input files.
+
+Simple uses of \MP\ refer only to file names that have no explicit
+extension or area. For example, a person usually says `\.{input} \.{cmr10}'
+instead of `\.{input} \.{cmr10.new}'. Simple file
+names are best, because they make the \MP\ source files portable;
+whenever a file name consists entirely of letters and digits, it should be
+treated in the same way by all implementations of \MP. However, users
+need the ability to refer to other files in their environment, especially
+when responding to error messages concerning unopenable files; therefore
+we want to let them use the syntax that appears in their favorite
+operating system.
+
+@ \MP\ uses the same conventions that have proved to be satisfactory for
+\TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
+@^system dependencies@>
+the system-independent parts of \MP\ are expressed in terms
+of three system-dependent
+procedures called |begin_name|, |more_name|, and |end_name|. In
+essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
+the system-independent driver program does the operations
+$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
+\,|end_name|.$$
+These three procedures communicate with each other via global variables.
+Afterwards the file name will appear in the string pool as three strings
+called |cur_name|\penalty10000\hskip-.05em,
+|cur_area|, and |cur_ext|; the latter two are null (i.e.,
+|""|), unless they were explicitly specified by the user.
+
+Actually the situation is slightly more complicated, because \MP\ needs
+to know when the file name ends. The |more_name| routine is a function
+(with side effects) that returns |true| on the calls |more_name|$(c_1)$,
+\dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
+returns |false|; or, it returns |true| and $c_n$ is the last character
+on the current input line. In other words,
+|more_name| is supposed to return |true| unless it is sure that the
+file name has been completely scanned; and |end_name| is supposed to be able
+to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
+whether $|more_name|(c_n)$ returned |true| or |false|.
+
+@<Glob...@>=
+char * cur_name; /* name of file just scanned */
+char * cur_area; /* file area just scanned, or \.{""} */
+char * cur_ext; /* file extension just scanned, or \.{""} */
+
+@ It is easier to maintain reference counts if we assign initial values.
+
+@<Set init...@>=
+mp->cur_name=xstrdup("");
+mp->cur_area=xstrdup("");
+mp->cur_ext=xstrdup("");
+
+@ @<Dealloc variables@>=
+xfree(mp->cur_area);
+xfree(mp->cur_name);
+xfree(mp->cur_ext);
+
+@ The file names we shall deal with for illustrative purposes have the
+following structure: If the name contains `\.>' or `\.:', the file area
+consists of all characters up to and including the final such character;
+otherwise the file area is null. If the remaining file name contains
+`\..', the file extension consists of all such characters from the first
+remaining `\..' to the end, otherwise the file extension is null.
+@^system dependencies@>
+
+We can scan such file names easily by using two global variables that keep track
+of the occurrences of area and extension delimiters. Note that these variables
+cannot be of type |pool_pointer| because a string pool compaction could occur
+while scanning a file name.
+
+@<Glob...@>=
+integer area_delimiter;
+ /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
+integer ext_delimiter; /* the relevant `\..', if any */
+
+@ Here now is the first of the system-dependent routines for file name scanning.
+@^system dependencies@>
+
+@<Declare subroutines for parsing file names@>=
+void mp_begin_name (MP mp) {
+ xfree(mp->cur_name);
+ xfree(mp->cur_area);
+ xfree(mp->cur_ext);
+ mp->area_delimiter=-1;
+ mp->ext_delimiter=-1;
+}
+
+@ And here's the second.
+@^system dependencies@>
+
+@<Declare subroutines for parsing file names@>=
+boolean mp_more_name (MP mp, ASCII_code c) {
+ if (c==' ') {
+ return false;
+ } else {
+ if ( (c=='>')||(c==':') ) {
+ mp->area_delimiter=mp->pool_ptr;
+ mp->ext_delimiter=-1;
+ } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
+ mp->ext_delimiter=mp->pool_ptr;
+ }
+ str_room(1); append_char(c); /* contribute |c| to the current string */
+ return true;
+ }
+}
+
+@ The third.
+@^system dependencies@>
+
+@d copy_pool_segment(A,B,C) {
+ A = xmalloc(C+1,sizeof(char));
+ strncpy(A,(char *)(mp->str_pool+B),C);
+ A[C] = 0;}
+
+@<Declare subroutines for parsing file names@>=
+void mp_end_name (MP mp) {
+ pool_pointer s; /* length of area, name, and extension */
+ unsigned int len;
+ /* "my/w.mp" */
+ s = mp->str_start[mp->str_ptr];
+ if ( mp->area_delimiter<0 ) {
+ mp->cur_area=xstrdup("");
+ } else {
+ len = mp->area_delimiter-s;
+ copy_pool_segment(mp->cur_area,s,len);
+ s += len+1;
+ }
+ if ( mp->ext_delimiter<0 ) {
+ mp->cur_ext=xstrdup("");
+ len = mp->pool_ptr-s;
+ } else {
+ copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
+ len = mp->ext_delimiter-s;
+ }
+ copy_pool_segment(mp->cur_name,s,len);
+ mp->pool_ptr=s; /* don't need this partial string */
+}
+
+@ Conversely, here is a routine that takes three strings and prints a file
+name that might have produced them. (The routine is system dependent, because
+some operating systems put the file area last instead of first.)
+@^system dependencies@>
+
+@<Basic printing...@>=
+void mp_print_file_name (MP mp, char * n, char * a, char * e) {
+ mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
+}
+
+@ Another system-dependent routine is needed to convert three internal
+\MP\ strings
+to the |name_of_file| value that is used to open files. The present code
+allows both lowercase and uppercase letters in the file name.
+@^system dependencies@>
+
+@d append_to_name(A) { c=(A);
+ if ( k<file_name_size ) {
+ mp->name_of_file[k]=xchr(c);
+ incr(k);
+ }
+}
+
+@<Declare subroutines for parsing file names@>=
+void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
+ integer k; /* number of positions filled in |name_of_file| */
+ ASCII_code c; /* character being packed */
+ const char *j; /* a character index */
+ k=0;
+ assert(n);
+ if (a!=NULL) {
+ for (j=a;*j;j++) { append_to_name(*j); }
+ }
+ for (j=n;*j;j++) { append_to_name(*j); }
+ if (e!=NULL) {
+ for (j=e;*j;j++) { append_to_name(*j); }
+ }
+ mp->name_of_file[k]=0;
+ mp->name_length=k;
+}
+
+@ @<Internal library declarations@>=
+void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
+
+@ A messier routine is also needed, since mem file names must be scanned
+before \MP's string mechanism has been initialized. We shall use the
+global variable |MP_mem_default| to supply the text for default system areas
+and extensions related to mem files.
+@^system dependencies@>
+
+@d mem_default_length 9 /* length of the |MP_mem_default| string */
+@d mem_ext_length 4 /* length of its `\.{.mem}' part */
+@d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
+
+@<Glob...@>=
+char *MP_mem_default;
+
+@ @<Option variables@>=
+char *mem_name; /* for commandline */
+
+@ @<Allocate or initialize ...@>=
+mp->MP_mem_default = xstrdup("plain.mem");
+mp->mem_name = xstrdup(opt->mem_name);
+@.plain@>
+@^system dependencies@>
+
+@ @<Dealloc variables@>=
+xfree(mp->MP_mem_default);
+xfree(mp->mem_name);
+
+@ @<Check the ``constant'' values for consistency@>=
+if ( mem_default_length>file_name_size ) mp->bad=20;
+
+@ Here is the messy routine that was just mentioned. It sets |name_of_file|
+from the first |n| characters of |MP_mem_default|, followed by
+|buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
+|MP_mem_default|.
+
+We dare not give error messages here, since \MP\ calls this routine before
+the |error| routine is ready to roll. Instead, we simply drop excess characters,
+since the error will be detected in another way when a strange file name
+isn't found.
+@^system dependencies@>
+
+@c void mp_pack_buffered_name (MP mp,small_number n, integer a,
+ integer b) {
+ integer k; /* number of positions filled in |name_of_file| */
+ ASCII_code c; /* character being packed */
+ integer j; /* index into |buffer| or |MP_mem_default| */
+ if ( n+b-a+1+mem_ext_length>file_name_size )
+ b=a+file_name_size-n-1-mem_ext_length;
+ k=0;
+ for (j=0;j<n;j++) {
+ append_to_name(xord((int)mp->MP_mem_default[j]));
+ }
+ for (j=a;j<b;j++) {
+ append_to_name(mp->buffer[j]);
+ }
+ for (j=mem_default_length-mem_ext_length;
+ j<mem_default_length;j++) {
+ append_to_name(xord((int)mp->MP_mem_default[j]));
+ }
+ mp->name_of_file[k]=0;
+ mp->name_length=k;
+}
+
+@ Here is the only place we use |pack_buffered_name|. This part of the program
+becomes active when a ``virgin'' \MP\ is trying to get going, just after
+the preliminary initialization, or when the user is substituting another
+mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
+contains the first line of input in |buffer[loc..(last-1)]|, where
+|loc<last| and |buffer[loc]<>" "|.
+
+@<Declarations@>=
+boolean mp_open_mem_file (MP mp) ;
+
+@ @c
+boolean mp_open_mem_file (MP mp) {
+ int j; /* the first space after the file name */
+ if (mp->mem_name!=NULL) {
+ mp->mem_file = (mp->open_file)(mp,mp->mem_name, "r", mp_filetype_memfile);
+ if ( mp->mem_file ) return true;
+ }
+ j=loc;
+ if ( mp->buffer[loc]=='&' ) {
+ incr(loc); j=loc; mp->buffer[mp->last]=' ';
+ while ( mp->buffer[j]!=' ' ) incr(j);
+ mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
+ if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
+ wake_up_terminal;
+ wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
+@.Sorry, I can't find...@>
+ update_terminal;
+ }
+ /* now pull out all the stops: try for the system \.{plain} file */
+ mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
+ if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
+ wake_up_terminal;
+ wterm_ln("I can\'t find the PLAIN mem file!\n");
+@.I can't find PLAIN...@>
+@.plain@>
+ return false;
+ }
+FOUND:
+ loc=j; return true;
+}
+
+@ Operating systems often make it possible to determine the exact name (and
+possible version number) of a file that has been opened. The following routine,
+which simply makes a \MP\ string from the value of |name_of_file|, should
+ideally be changed to deduce the full name of file~|f|, which is the file
+most recently opened, if it is possible to do this.
+@^system dependencies@>
+
+@<Declarations@>=
+#define mp_a_make_name_string(A,B) mp_make_name_string(A)
+#define mp_b_make_name_string(A,B) mp_make_name_string(A)
+#define mp_w_make_name_string(A,B) mp_make_name_string(A)
+
+@ @c
+str_number mp_make_name_string (MP mp) {
+ int k; /* index into |name_of_file| */
+ str_room(mp->name_length);
+ for (k=0;k<mp->name_length;k++) {
+ append_char(xord((int)mp->name_of_file[k]));
+ }
+ return mp_make_string(mp);
+}
+
+@ Now let's consider the ``driver''
+routines by which \MP\ deals with file names
+in a system-independent manner. First comes a procedure that looks for a
+file name in the input by taking the information from the input buffer.
+(We can't use |get_next|, because the conversion to tokens would
+destroy necessary information.)
+
+This procedure doesn't allow semicolons or percent signs to be part of
+file names, because of other conventions of \MP.
+{\sl The {\logos METAFONT\/}book} doesn't
+use semicolons or percents immediately after file names, but some users
+no doubt will find it natural to do so; therefore system-dependent
+changes to allow such characters in file names should probably
+be made with reluctance, and only when an entire file name that
+includes special characters is ``quoted'' somehow.
+@^system dependencies@>
+
+@c void mp_scan_file_name (MP mp) {
+ mp_begin_name(mp);
+ while ( mp->buffer[loc]==' ' ) incr(loc);
+ while (1) {
+ if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
+ if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
+ incr(loc);
+ }
+ mp_end_name(mp);
+}
+
+@ Here is another version that takes its input from a string.
+
+@<Declare subroutines for parsing file names@>=
+void mp_str_scan_file (MP mp, str_number s) {
+ pool_pointer p,q; /* current position and stopping point */
+ mp_begin_name(mp);
+ p=mp->str_start[s]; q=str_stop(s);
+ while ( p<q ){
+ if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
+ incr(p);
+ }
+ mp_end_name(mp);
+}
+
+@ And one that reads from a |char*|.
+
+@<Declare subroutines for parsing file names@>=
+void mp_ptr_scan_file (MP mp, char *s) {
+ char *p, *q; /* current position and stopping point */
+ mp_begin_name(mp);
+ p=s; q=p+strlen(s);
+ while ( p<q ){
+ if ( ! mp_more_name(mp, *p)) break;
+ p++;
+ }
+ mp_end_name(mp);
+}
+
+
+@ The global variable |job_name| contains the file name that was first
+\&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
+`\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
+
+@<Glob...@>=
+boolean log_opened; /* has the transcript file been opened? */
+char *log_name; /* full name of the log file */
+
+@ @<Option variables@>=
+char *job_name; /* principal file name */
+
+@ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
+We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
+except of course for a short time just after |job_name| has become nonzero.
+
+@<Allocate or ...@>=
+mp->job_name=mp_xstrdup(mp, opt->job_name);
+mp->log_opened=false;
+
+@ @<Dealloc variables@>=
+xfree(mp->job_name);
+
+@ Here is a routine that manufactures the output file names, assuming that
+|job_name<>0|. It ignores and changes the current settings of |cur_area|
+and |cur_ext|.
+
+@d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
+
+@<Declarations@>=
+void mp_pack_job_name (MP mp, const char *s) ;
+
+@ @c
+void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
+ xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
+ xfree(mp->cur_area); mp->cur_area=xstrdup("");
+ xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
+ pack_cur_name;
+}
+
+@ If some trouble arises when \MP\ tries to open a file, the following
+routine calls upon the user to supply another file name. Parameter~|s|
+is used in the error message to identify the type of file; parameter~|e|
+is the default extension if none is given. Upon exit from the routine,
+variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
+ready for another attempt at file opening.
+
+@<Declarations@>=
+void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
+
+@ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
+ size_t k; /* index into |buffer| */
+ char * saved_cur_name;
+ if ( mp->interaction==mp_scroll_mode )
+ wake_up_terminal;
+ if (strcmp(s,"input file name")==0) {
+ print_err("I can\'t find file `");
+@.I can't find file x@>
+ } else {
+ print_err("I can\'t write on file `");
+ }
+@.I can't write on file x@>
+ mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
+ mp_print(mp, "'.");
+ if (strcmp(e,"")==0)
+ mp_show_context(mp);
+ mp_print_nl(mp, "Please type another "); mp_print(mp, s);
+@.Please type...@>
+ if ( mp->interaction<mp_scroll_mode )
+ mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
+@.job aborted, file error...@>
+ saved_cur_name = xstrdup(mp->cur_name);
+ clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
+ if (strcmp(mp->cur_ext,"")==0)
+ mp->cur_ext=xstrdup(e);
+ if (strlen(mp->cur_name)==0) {
+ mp->cur_name=saved_cur_name;
+ } else {
+ xfree(saved_cur_name);
+ }
+ pack_cur_name;
+}
+
+@ @<Scan file name in the buffer@>=
+{
+ mp_begin_name(mp); k=mp->first;
+ while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
+ while (1) {
+ if ( k==mp->last ) break;
+ if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
+ incr(k);
+ }
+ mp_end_name(mp);
+}
+
+@ The |open_log_file| routine is used to open the transcript file and to help
+it catch up to what has previously been printed on the terminal.
+
+@c void mp_open_log_file (MP mp) {
+ int old_setting; /* previous |selector| setting */
+ int k; /* index into |months| and |buffer| */
+ int l; /* end of first input line */
+ integer m; /* the current month */
+ const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
+ /* abbreviations of month names */
+ old_setting=mp->selector;
+ if ( mp->job_name==NULL ) {
+ mp->job_name=xstrdup("mpout");
+ }
+ mp_pack_job_name(mp,".log");
+ while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
+ @<Try to get a different log file name@>;
+ }
+ mp->log_name=xstrdup(mp->name_of_file);
+ mp->selector=log_only; mp->log_opened=true;
+ @<Print the banner line, including the date and time@>;
+ mp->input_stack[mp->input_ptr]=mp->cur_input;
+ /* make sure bottom level is in memory */
+@.**@>
+ if (!mp->noninteractive) {
+ mp_print_nl(mp, "**");
+ l=mp->input_stack[0].limit_field-1; /* last position of first line */
+ for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
+ mp_print_ln(mp); /* now the transcript file contains the first line of input */
+ }
+ mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
+}
+
+@ @<Dealloc variables@>=
+xfree(mp->log_name);
+
+@ Sometimes |open_log_file| is called at awkward moments when \MP\ is
+unable to print error messages or even to |show_context|.
+The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
+routine will not be invoked because |log_opened| will be false.
+
+The normal idea of |mp_batch_mode| is that nothing at all should be written
+on the terminal. However, in the unusual case that
+no log file could be opened, we make an exception and allow
+an explanatory message to be seen.
+
+Incidentally, the program always refers to the log file as a `\.{transcript
+file}', because some systems cannot use the extension `\.{.log}' for
+this file.
+
+@<Try to get a different log file name@>=
+{
+ mp->selector=term_only;
+ mp_prompt_file_name(mp, "transcript file name",".log");
+}
+
+@ @<Print the banner...@>=
+{
+ wlog(banner);
+ mp_print(mp, mp->mem_ident); mp_print(mp, " ");
+ mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
+ mp_print_char(mp, ' ');
+ m=mp_round_unscaled(mp, mp->internal[mp_month]);
+ for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
+ mp_print_char(mp, ' ');
+ mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
+ mp_print_char(mp, ' ');
+ m=mp_round_unscaled(mp, mp->internal[mp_time]);
+ mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
+}
+
+@ The |try_extension| function tries to open an input file determined by
+|cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
+can't find the file in |cur_area| or the appropriate system area.
+
+@c boolean mp_try_extension (MP mp, const char *ext) {
+ mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
+ in_name=xstrdup(mp->cur_name);
+ in_area=xstrdup(mp->cur_area);
+ if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
+ return true;
+ } else {
+ mp_pack_file_name(mp, mp->cur_name,NULL,ext);
+ return mp_a_open_in(mp, &cur_file, mp_filetype_program);
+ }
+}
+
+@ Let's turn now to the procedure that is used to initiate file reading
+when an `\.{input}' command is being processed.
+
+@c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
+ char *fname = NULL;
+ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
+ while (1) {
+ mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
+ if ( strlen(mp->cur_ext)==0 ) {
+ if ( mp_try_extension(mp, ".mp") ) break;
+ else if ( mp_try_extension(mp, "") ) break;
+ else if ( mp_try_extension(mp, ".mf") ) break;
+ /* |else do_nothing; | */
+ } else if ( mp_try_extension(mp, mp->cur_ext) ) {
+ break;
+ }
+ mp_end_file_reading(mp); /* remove the level that didn't work */
+ mp_prompt_file_name(mp, "input file name","");
+ }
+ name=mp_a_make_name_string(mp, cur_file);
+ fname = xstrdup(mp->name_of_file);
+ if ( mp->job_name==NULL ) {
+ mp->job_name=xstrdup(mp->cur_name);
+ mp_open_log_file(mp);
+ } /* |open_log_file| doesn't |show_context|, so |limit|
+ and |loc| needn't be set to meaningful values yet */
+ if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
+ else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
+ mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
+ xfree(fname);
+ update_terminal;
+ @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
+ @<Read the first line of the new file@>;
+}
+
+@ This code should be omitted if |a_make_name_string| returns something other
+than just a copy of its argument and the full file name is needed for opening
+\.{MPX} files or implementing the switch-to-editor option.
+@^system dependencies@>
+
+@<Flush |name| and replace it with |cur_name| if it won't be needed@>=
+mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
+
+@ If the file is empty, it is considered to contain a single blank line,
+so there is no need to test the return value.
+
+@<Read the first line...@>=
+{
+ line=1;
+ (void)mp_input_ln(mp, cur_file );
+ mp_firm_up_the_line(mp);
+ mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
+}
+
+@ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
+while ( token_state &&(loc==null) ) mp_end_token_list(mp);
+if ( token_state ) {
+ print_err("File names can't appear within macros");
+@.File names can't...@>
+ help3("Sorry...I've converted what follows to tokens,")
+ ("possibly garbaging the name you gave.")
+ ("Please delete the tokens and insert the name again.");
+ mp_error(mp);
+}
+if ( file_state ) {
+ mp_scan_file_name(mp);
+} else {
+ xfree(mp->cur_name); mp->cur_name=xstrdup("");
+ xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
+ xfree(mp->cur_area); mp->cur_area=xstrdup("");
+}
+
+@ The following simple routine starts reading the \.{MPX} file associated
+with the current input file.
+
+@c void mp_start_mpx_input (MP mp) {
+ char *origname = NULL; /* a copy of nameoffile */
+ mp_pack_file_name(mp, in_name, in_area, ".mpx");
+ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
+ |goto not_found| if there is a problem@>;
+ mp_begin_file_reading(mp);
+ if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
+ mp_end_file_reading(mp);
+ goto NOT_FOUND;
+ }
+ name=mp_a_make_name_string(mp, cur_file);
+ mp->mpx_name[index]=name; add_str_ref(name);
+ @<Read the first line of the new file@>;
+ return;
+NOT_FOUND:
+ @<Explain that the \.{MPX} file can't be read and |succumb|@>;
+ xfree(origname);
+}
+
+@ This should ideally be changed to do whatever is necessary to create the
+\.{MPX} file given by |name_of_file| if it does not exist or if it is out
+of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
+the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
+completely different typesetting program if suitable postprocessor is
+available to perform the function of \.{DVItoMP}.)
+@^system dependencies@>
+
+@ @<Exported types@>=
+typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
+
+@ @<Option variables@>=
+mp_run_make_mpx_command run_make_mpx;
+
+@ @<Allocate or initialize ...@>=
+set_callback_option(run_make_mpx);
+
+@ @<Internal library declarations@>=
+int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
+
+@ The default does nothing.
+@c
+int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
+ (void)mp;
+ (void)origname;
+ (void)mtxname;
+ return false;
+}
+
+@ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
+ |goto not_found| if there is a problem@>=
+origname = mp_xstrdup(mp,mp->name_of_file);
+*(origname+strlen(origname)-1)=0; /* drop the x */
+if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
+ goto NOT_FOUND
+
+@ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
+if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
+mp_print_nl(mp, ">> ");
+mp_print(mp, origname);
+mp_print_nl(mp, ">> ");
+mp_print(mp, mp->name_of_file);
+mp_print_nl(mp, "! Unable to make mpx file");
+help4("The two files given above are one of your source files")
+ ("and an auxiliary file I need to read to find out what your")
+ ("btex..etex blocks mean. If you don't know why I had trouble,")
+ ("try running it manually through MPtoTeX, TeX, and DVItoMP");
+succumb;
+
+@ The last file-opening commands are for files accessed via the \&{readfrom}
+@:read_from_}{\&{readfrom} primitive@>
+operator and the \&{write} command. Such files are stored in separate arrays.
+@:write_}{\&{write} primitive@>
+
+@<Types in the outer block@>=
+typedef unsigned int readf_index; /* |0..max_read_files| */
+typedef unsigned int write_index; /* |0..max_write_files| */
+
+@ @<Glob...@>=
+readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
+void ** rd_file; /* \&{readfrom} files */
+char ** rd_fname; /* corresponding file name or 0 if file not open */
+readf_index read_files; /* number of valid entries in the above arrays */
+write_index max_write_files; /* maximum number of simultaneously open \&{write} */
+void ** wr_file; /* \&{write} files */
+char ** wr_fname; /* corresponding file name or 0 if file not open */
+write_index write_files; /* number of valid entries in the above arrays */
+
+@ @<Allocate or initialize ...@>=
+mp->max_read_files=8;
+mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
+mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
+memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
+mp->read_files=0;
+mp->max_write_files=8;
+mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
+mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
+memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
+mp->write_files=0;
+
+
+@ This routine starts reading the file named by string~|s| without setting
+|loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
+be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
+
+@c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
+ mp_ptr_scan_file(mp, s);
+ pack_cur_name;
+ mp_begin_file_reading(mp);
+ if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
+ goto NOT_FOUND;
+ if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
+ (mp->close_file)(mp,mp->rd_file[n]);
+ goto NOT_FOUND;
+ }
+ mp->rd_fname[n]=xstrdup(mp->name_of_file);
+ return true;
+NOT_FOUND:
+ mp_end_file_reading(mp);
+ return false;
+}
+
+@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
+
+@<Declarations@>=
+void mp_open_write_file (MP mp, char *s, readf_index n) ;
+
+@ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
+ mp_ptr_scan_file(mp, s);
+ pack_cur_name;
+ while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
+ mp_prompt_file_name(mp, "file name for write output","");
+ mp->wr_fname[n]=xstrdup(mp->name_of_file);
+}
+
+
+@* \[36] Introduction to the parsing routines.
+We come now to the central nervous system that sparks many of \MP's activities.
+By evaluating expressions, from their primary constituents to ever larger
+subexpressions, \MP\ builds the structures that ultimately define complete
+pictures or fonts of type.
+
+Four mutually recursive subroutines are involved in this process: We call them
+$$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
+and |scan_expression|.}$$
+@^recursion@>
+Each of them is parameterless and begins with the first token to be scanned
+already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
+the value of the primary or secondary or tertiary or expression that was
+found will appear in the global variables |cur_type| and |cur_exp|. The
+token following the expression will be represented in |cur_cmd|, |cur_mod|,
+and |cur_sym|.
+
+Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
+backup mechanisms have been added in order to provide reasonable error
+recovery.
+
+@<Glob...@>=
+small_number cur_type; /* the type of the expression just found */
+integer cur_exp; /* the value of the expression just found */
+
+@ @<Set init...@>=
+mp->cur_exp=0;
+
+@ Many different kinds of expressions are possible, so it is wise to have
+precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
+
+\smallskip\hang
+|cur_type=mp_vacuous| means that this expression didn't turn out to have a
+value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
+construction in which there was no expression before the \&{endgroup}.
+In this case |cur_exp| has some irrelevant value.
+
+\smallskip\hang
+|cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
+or |false_code|.
+
+\smallskip\hang
+|cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent booleans whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
+integer in the range |0<=cur_exp<str_ptr|). That string's reference count
+includes this particular reference.
+
+\smallskip\hang
+|cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent strings whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
+else points to any of the nodes in this pen. The pen may be polygonal or
+elliptical.
+
+\smallskip\hang
+|cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent pens whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_path_type| means that |cur_exp| points to a the first node of
+a path; nobody else points to this particular path. The control points of
+the path will have been chosen.
+
+\smallskip\hang
+|cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent paths whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
+There may be other pointers to this particular set of edges. The header node
+contains a reference count that includes this particular reference.
+
+\smallskip\hang
+|cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent pictures whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
+capsule node. The |value| part of this capsule
+points to a transform node that contains six numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
+capsule node. The |value| part of this capsule
+points to a color node that contains three numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
+capsule node. The |value| part of this capsule
+points to a color node that contains four numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_pair_type| means that |cur_exp| points to a capsule
+node whose type is |mp_pair_type|. The |value| part of this capsule
+points to a pair node that contains two numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_known| means that |cur_exp| is a |scaled| value.
+
+\smallskip\hang
+|cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
+is |dependent|. The |dep_list| field in this capsule points to the associated
+dependency list.
+
+\smallskip\hang
+|cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
+capsule node. The |dep_list| field in this capsule
+points to the associated dependency list.
+
+\smallskip\hang
+|cur_type=independent| means that |cur_exp| points to a capsule node
+whose type is |independent|. This somewhat unusual case can arise, for
+example, in the expression
+`$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
+
+\smallskip\hang
+|cur_type=mp_token_list| means that |cur_exp| points to a linked list of
+tokens.
+
+\smallskip\noindent
+The possible settings of |cur_type| have been listed here in increasing
+numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
+|suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
+are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
+|token_list|.
+
+@ Capsules are two-word nodes that have a similar meaning
+to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
+and their |type| field is one of the possibilities for |cur_type| listed above.
+Also |link<=void| in capsules that aren't part of a token list.
+
+The |value| field of a capsule is, in most cases, the value that
+corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
+However, when |cur_exp| would point to a capsule,
+no extra layer of indirection is present; the |value|
+field is what would have been called |value(cur_exp)| if it had not been
+encapsulated. Furthermore, if the type is |dependent| or
+|mp_proto_dependent|, the |value| field of a capsule is replaced by
+|dep_list| and |prev_dep| fields, since dependency lists in capsules are
+always part of the general |dep_list| structure.
+
+The |get_x_next| routine is careful not to change the values of |cur_type|
+and |cur_exp| when it gets an expanded token. However, |get_x_next| might
+call a macro, which might parse an expression, which might execute lots of
+commands in a group; hence it's possible that |cur_type| might change
+from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
+|known| or |independent|, during the time |get_x_next| is called. The
+programs below are careful to stash sensitive intermediate results in
+capsules, so that \MP's generality doesn't cause trouble.
+
+Here's a procedure that illustrates these conventions. It takes
+the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
+and stashes them away in a
+capsule. It is not used when |cur_type=mp_token_list|.
+After the operation, |cur_type=mp_vacuous|; hence there is no need to
+copy path lists or to update reference counts, etc.
+
+The special link |mp_void| is put on the capsule returned by
+|stash_cur_exp|, because this procedure is used to store macro parameters
+that must be easily distinguishable from token lists.
+
+@<Declare the stashing/unstashing routines@>=
+pointer mp_stash_cur_exp (MP mp) {
+ pointer p; /* the capsule that will be returned */
+ switch (mp->cur_type) {
+ case unknown_types:
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_pair_type:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ case mp_cmykcolor_type:
+ p=mp->cur_exp;
+ break;
+ default:
+ p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
+ type(p)=mp->cur_type; value(p)=mp->cur_exp;
+ break;
+ }
+ mp->cur_type=mp_vacuous; link(p)=mp_void;
+ return p;
+}
+
+@ The inverse of |stash_cur_exp| is the following procedure, which
+deletes an unnecessary capsule and puts its contents into |cur_type|
+and |cur_exp|.
+
+The program steps of \MP\ can be divided into two categories: those in
+which |cur_type| and |cur_exp| are ``alive'' and those in which they are
+``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
+information or not. It's important not to ignore them when they're alive,
+and it's important not to pay attention to them when they're dead.
+
+There's also an intermediate category: If |cur_type=mp_vacuous|, then
+|cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
+and |cur_exp| are alive or dead. In such cases we say that |cur_type|
+and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
+only when they are alive or dormant.
+
+The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
+are alive or dormant. The \\{unstash} procedure assumes that they are
+dead or dormant; it resuscitates them.
+
+@<Declare the stashing/unstashing...@>=
+void mp_unstash_cur_exp (MP mp,pointer p) ;
+
+@ @c
+void mp_unstash_cur_exp (MP mp,pointer p) {
+ mp->cur_type=type(p);
+ switch (mp->cur_type) {
+ case unknown_types:
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_pair_type:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ case mp_cmykcolor_type:
+ mp->cur_exp=p;
+ break;
+ default:
+ mp->cur_exp=value(p);
+ mp_free_node(mp, p,value_node_size);
+ break;
+ }
+}
+
+@ The following procedure prints the values of expressions in an
+abbreviated format. If its first parameter |p| is null, the value of
+|(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
+containing the desired value. The second parameter controls the amount of
+output. If it is~0, dependency lists will be abbreviated to
+`\.{linearform}' unless they consist of a single term. If it is greater
+than~1, complicated structures (pens, pictures, and paths) will be displayed
+in full.
+@.linearform@>
+
+@<Declare subroutines for printing expressions@>=
+@<Declare the procedure called |print_dp|@>
+@<Declare the stashing/unstashing routines@>
+void mp_print_exp (MP mp,pointer p, small_number verbosity) {
+ boolean restore_cur_exp; /* should |cur_exp| be restored? */
+ small_number t; /* the type of the expression */
+ pointer q; /* a big node being displayed */
+ integer v=0; /* the value of the expression */
+ if ( p!=null ) {
+ restore_cur_exp=false;
+ } else {
+ p=mp_stash_cur_exp(mp); restore_cur_exp=true;
+ }
+ t=type(p);
+ if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
+ @<Print an abbreviated value of |v| with format depending on |t|@>;
+ if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
+}
+
+@ @<Print an abbreviated value of |v| with format depending on |t|@>=
+switch (t) {
+case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
+case mp_boolean_type:
+ if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
+ break;
+case unknown_types: case mp_numeric_type:
+ @<Display a variable that's been declared but not defined@>;
+ break;
+case mp_string_type:
+ mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
+ break;
+case mp_pen_type: case mp_path_type: case mp_picture_type:
+ @<Display a complex type@>;
+ break;
+case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
+ if ( v==null ) mp_print_type(mp, t);
+ else @<Display a big node@>;
+ break;
+case mp_known:mp_print_scaled(mp, v); break;
+case mp_dependent: case mp_proto_dependent:
+ mp_print_dp(mp, t,v,verbosity);
+ break;
+case mp_independent:mp_print_variable_name(mp, p); break;
+default: mp_confusion(mp, "exp"); break;
+@:this can't happen exp}{\quad exp@>
+}
+
+@ @<Display a big node@>=
+{
+ mp_print_char(mp, '('); q=v+mp->big_node_size[t];
+ do {
+ if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
+ else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
+ else mp_print_dp(mp, type(v),dep_list(v),verbosity);
+ v=v+2;
+ if ( v!=q ) mp_print_char(mp, ',');
+ } while (v!=q);
+ mp_print_char(mp, ')');
+}
+
+@ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
+in the log file only, unless the user has given a positive value to
+\\{tracingonline}.
+
+@<Display a complex type@>=
+if ( verbosity<=1 ) {
+ mp_print_type(mp, t);
+} else {
+ if ( mp->selector==term_and_log )
+ if ( mp->internal[mp_tracing_online]<=0 ) {
+ mp->selector=term_only;
+ mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
+ mp->selector=term_and_log;
+ };
+ switch (t) {
+ case mp_pen_type:mp_print_pen(mp, v,"",false); break;
+ case mp_path_type:mp_print_path(mp, v,"",false); break;
+ case mp_picture_type:mp_print_edges(mp, v,"",false); break;
+ } /* there are no other cases */
+}
+
+@ @<Declare the procedure called |print_dp|@>=
+void mp_print_dp (MP mp,small_number t, pointer p,
+ small_number verbosity) {
+ pointer q; /* the node following |p| */
+ q=link(p);
+ if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
+ else mp_print(mp, "linearform");
+}
+
+@ The displayed name of a variable in a ring will not be a capsule unless
+the ring consists entirely of capsules.
+
+@<Display a variable that's been declared but not defined@>=
+{ mp_print_type(mp, t);
+if ( v!=null )
+ { mp_print_char(mp, ' ');
+ while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
+ mp_print_variable_name(mp, v);
+ };
+}
+
+@ When errors are detected during parsing, it is often helpful to
+display an expression just above the error message, using |exp_err|
+or |disp_err| instead of |print_err|.
+
+@d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
+
+@<Declare subroutines for printing expressions@>=
+void mp_disp_err (MP mp,pointer p, const char *s) {
+ if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
+ mp_print_nl(mp, ">> ");
+@.>>@>
+ mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
+ if (strlen(s)) {
+ mp_print_nl(mp, "! "); mp_print(mp, s);
+@.!\relax@>
+ }
+}
+
+@ If |cur_type| and |cur_exp| contain relevant information that should
+be recycled, we will use the following procedure, which changes |cur_type|
+to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
+and |cur_exp| as either alive or dormant after this has been done,
+because |cur_exp| will not contain a pointer value.
+
+@ @c void mp_flush_cur_exp (MP mp,scaled v) {
+ switch (mp->cur_type) {
+ case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
+ case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
+ mp_recycle_value(mp, mp->cur_exp);
+ mp_free_node(mp, mp->cur_exp,value_node_size);
+ break;
+ case mp_string_type:
+ delete_str_ref(mp->cur_exp); break;
+ case mp_pen_type: case mp_path_type:
+ mp_toss_knot_list(mp, mp->cur_exp); break;
+ case mp_picture_type:
+ delete_edge_ref(mp->cur_exp); break;
+ default:
+ break;
+ }
+ mp->cur_type=mp_known; mp->cur_exp=v;
+}
+
+@ There's a much more general procedure that is capable of releasing
+the storage associated with any two-word value packet.
+
+@<Declare the recycling subroutines@>=
+void mp_recycle_value (MP mp,pointer p) ;
+
+@ @c void mp_recycle_value (MP mp,pointer p) {
+ small_number t; /* a type code */
+ integer vv; /* another value */
+ pointer q,r,s,pp; /* link manipulation registers */
+ integer v=0; /* a value */
+ t=type(p);
+ if ( t<mp_dependent ) v=value(p);
+ switch (t) {
+ case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
+ case mp_numeric_type:
+ break;
+ case unknown_types:
+ mp_ring_delete(mp, p); break;
+ case mp_string_type:
+ delete_str_ref(v); break;
+ case mp_path_type: case mp_pen_type:
+ mp_toss_knot_list(mp, v); break;
+ case mp_picture_type:
+ delete_edge_ref(v); break;
+ case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
+ case mp_transform_type:
+ @<Recycle a big node@>; break;
+ case mp_dependent: case mp_proto_dependent:
+ @<Recycle a dependency list@>; break;
+ case mp_independent:
+ @<Recycle an independent variable@>; break;
+ case mp_token_list: case mp_structured:
+ mp_confusion(mp, "recycle"); break;
+@:this can't happen recycle}{\quad recycle@>
+ case mp_unsuffixed_macro: case mp_suffixed_macro:
+ mp_delete_mac_ref(mp, value(p)); break;
+ } /* there are no other cases */
+ type(p)=undefined;
+}
+
+@ @<Recycle a big node@>=
+if ( v!=null ){
+ q=v+mp->big_node_size[t];
+ do {
+ q=q-2; mp_recycle_value(mp, q);
+ } while (q!=v);
+ mp_free_node(mp, v,mp->big_node_size[t]);
+}
+
+@ @<Recycle a dependency list@>=
+{
+ q=dep_list(p);
+ while ( info(q)!=null ) q=link(q);
+ link(prev_dep(p))=link(q);
+ prev_dep(link(q))=prev_dep(p);
+ link(q)=null; mp_flush_node_list(mp, dep_list(p));
+}
+
+@ When an independent variable disappears, it simply fades away, unless
+something depends on it. In the latter case, a dependent variable whose
+coefficient of dependence is maximal will take its place.
+The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
+as part of his Ph.D. thesis (Stanford University, December 1982).
+@^Zabala Salelles, Ignacio Andr\'es@>
+
+For example, suppose that variable $x$ is being recycled, and that the
+only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
+we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
+will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
+we will print `\.{\#\#\# -2x=-y+a}'.
+
+There's a slight complication, however: An independent variable $x$
+can occur both in dependency lists and in proto-dependency lists.
+This makes it necessary to be careful when deciding which coefficient
+is maximal.
+
+Furthermore, this complication is not so slight when
+a proto-dependent variable is chosen to become independent. For example,
+suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
+then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
+large coefficient `50'.
+
+In order to deal with these complications without wasting too much time,
+we shall link together the occurrences of~$x$ among all the linear
+dependencies, maintaining separate lists for the dependent and
+proto-dependent cases.
+
+@<Recycle an independent variable@>=
+{
+ mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
+ mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
+ q=link(dep_head);
+ while ( q!=dep_head ) {
+ s=value_loc(q); /* now |link(s)=dep_list(q)| */
+ while (1) {
+ r=link(s);
+ if ( info(r)==null ) break;
+ if ( info(r)!=p ) {
+ s=r;
+ } else {
+ t=type(q); link(s)=link(r); info(r)=q;
+ if ( abs(value(r))>mp->max_c[t] ) {
+ @<Record a new maximum coefficient of type |t|@>;
+ } else {
+ link(r)=mp->max_link[t]; mp->max_link[t]=r;
+ }
+ }
+ }
+ q=link(r);
+ }
+ if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
+ @<Choose a dependent variable to take the place of the disappearing
+ independent variable, and change all remaining dependencies
+ accordingly@>;
+ }
+}
+
+@ The code for independency removal makes use of three two-word arrays.
+
+@<Glob...@>=
+integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
+pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
+pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
+
+@ @<Record a new maximum coefficient...@>=
+{
+ if ( mp->max_c[t]>0 ) {
+ link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
+ }
+ mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
+}
+
+@ @<Choose a dependent...@>=
+{
+ if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
+ t=mp_dependent;
+ else
+ t=mp_proto_dependent;
+ @<Determine the dependency list |s| to substitute for the independent
+ variable~|p|@>;
+ t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
+ if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
+ link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
+ }
+ if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
+ else { @<Substitute new proto-dependencies in place of |p|@>;}
+ mp_flush_node_list(mp, s);
+ if ( mp->fix_needed ) mp_fix_dependencies(mp);
+ check_arith;
+}
+
+@ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
+and |info(s)| points to the dependent variable~|pp| of type~|t| from
+whose dependency list we have removed node~|s|. We must reinsert
+node~|s| into the dependency list, with coefficient $-1.0$, and with
+|pp| as the new independent variable. Since |pp| will have a larger serial
+number than any other variable, we can put node |s| at the head of the
+list.
+
+@<Determine the dep...@>=
+s=mp->max_ptr[t]; pp=info(s); v=value(s);
+if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
+r=dep_list(pp); link(s)=r;
+while ( info(r)!=null ) r=link(r);
+q=link(r); link(r)=null;
+prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
+new_indep(pp);
+if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
+if ( mp->internal[mp_tracing_equations]>0 ) {
+ @<Show the transformed dependency@>;
+}
+
+@ Now $(-v)$ times the formerly independent variable~|p| is being replaced
+by the dependency list~|s|.
+
+@<Show the transformed...@>=
+if ( mp_interesting(mp, p) ) {
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
+@:]]]\#\#\#_}{\.{\#\#\#}@>
+ if ( v>0 ) mp_print_char(mp, '-');
+ if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
+ else vv=mp->max_c[mp_proto_dependent];
+ if ( vv!=unity ) mp_print_scaled(mp, vv);
+ mp_print_variable_name(mp, p);
+ while ( value(p) % s_scale>0 ) {
+ mp_print(mp, "*4"); value(p)=value(p)-2;
+ }
+ if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
+ mp_print_dependency(mp, s,t);
+ mp_end_diagnostic(mp, false);
+}
+
+@ Finally, there are dependent and proto-dependent variables whose
+dependency lists must be brought up to date.
+
+@<Substitute new dependencies...@>=
+for (t=mp_dependent;t<=mp_proto_dependent;t++){
+ r=mp->max_link[t];
+ while ( r!=null ) {
+ q=info(r);
+ dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
+ mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
+ if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
+ q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
+ }
+}
+
+@ @<Substitute new proto...@>=
+for (t=mp_dependent;t<=mp_proto_dependent;t++) {
+ r=mp->max_link[t];
+ while ( r!=null ) {
+ q=info(r);
+ if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
+ if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
+ mp->cur_type=mp_proto_dependent;
+ dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
+ mp_dependent,mp_proto_dependent);
+ type(q)=mp_proto_dependent;
+ value(r)=mp_round_fraction(mp, value(r));
+ }
+ dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
+ mp_make_scaled(mp, value(r),-v),s,
+ mp_proto_dependent,mp_proto_dependent);
+ if ( dep_list(q)==mp->dep_final )
+ mp_make_known(mp, q,mp->dep_final);
+ q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
+ }
+}
+
+@ Here are some routines that provide handy combinations of actions
+that are often needed during error recovery. For example,
+`|flush_error|' flushes the current expression, replaces it by
+a given value, and calls |error|.
+
+Errors often are detected after an extra token has already been scanned.
+The `\\{put\_get}' routines put that token back before calling |error|;
+then they get it back again. (Or perhaps they get another token, if
+the user has changed things.)
+
+@<Declarations@>=
+void mp_flush_error (MP mp,scaled v);
+void mp_put_get_error (MP mp);
+void mp_put_get_flush_error (MP mp,scaled v) ;
+
+@ @c
+void mp_flush_error (MP mp,scaled v) {
+ mp_error(mp); mp_flush_cur_exp(mp, v);
+}
+void mp_put_get_error (MP mp) {
+ mp_back_error(mp); mp_get_x_next(mp);
+}
+void mp_put_get_flush_error (MP mp,scaled v) {
+ mp_put_get_error(mp);
+ mp_flush_cur_exp(mp, v);
+}
+
+@ A global variable |var_flag| is set to a special command code
+just before \MP\ calls |scan_expression|, if the expression should be
+treated as a variable when this command code immediately follows. For
+example, |var_flag| is set to |assignment| at the beginning of a
+statement, because we want to know the {\sl location\/} of a variable at
+the left of `\.{:=}', not the {\sl value\/} of that variable.
+
+The |scan_expression| subroutine calls |scan_tertiary|,
+which calls |scan_secondary|, which calls |scan_primary|, which sets
+|var_flag:=0|. In this way each of the scanning routines ``knows''
+when it has been called with a special |var_flag|, but |var_flag| is
+usually zero.
+
+A variable preceding a command that equals |var_flag| is converted to a
+token list rather than a value. Furthermore, an `\.{=}' sign following an
+expression with |var_flag=assignment| is not considered to be a relation
+that produces boolean expressions.
+
+
+@<Glob...@>=
+int var_flag; /* command that wants a variable */
+
+@ @<Set init...@>=
+mp->var_flag=0;
+
+@* \[37] Parsing primary expressions.
+The first parsing routine, |scan_primary|, is also the most complicated one,
+since it involves so many different cases. But each case---with one
+exception---is fairly simple by itself.
+
+When |scan_primary| begins, the first token of the primary to be scanned
+should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
+of |cur_type| and |cur_exp| should be either dead or dormant, as explained
+earlier. If |cur_cmd| is not between |min_primary_command| and
+|max_primary_command|, inclusive, a syntax error will be signaled.
+
+@<Declare the basic parsing subroutines@>=
+void mp_scan_primary (MP mp) {
+ pointer p,q,r; /* for list manipulation */
+ quarterword c; /* a primitive operation code */
+ int my_var_flag; /* initial value of |my_var_flag| */
+ pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
+ @<Other local variables for |scan_primary|@>;
+ my_var_flag=mp->var_flag; mp->var_flag=0;
+RESTART:
+ check_arith;
+ @<Supply diagnostic information, if requested@>;
+ switch (mp->cur_cmd) {
+ case left_delimiter:
+ @<Scan a delimited primary@>; break;
+ case begin_group:
+ @<Scan a grouped primary@>; break;
+ case string_token:
+ @<Scan a string constant@>; break;
+ case numeric_token:
+ @<Scan a primary that starts with a numeric token@>; break;
+ case nullary:
+ @<Scan a nullary operation@>; break;
+ case unary: case type_name: case cycle: case plus_or_minus:
+ @<Scan a unary operation@>; break;
+ case primary_binary:
+ @<Scan a binary operation with `\&{of}' between its operands@>; break;
+ case str_op:
+ @<Convert a suffix to a string@>; break;
+ case internal_quantity:
+ @<Scan an internal numeric quantity@>; break;
+ case capsule_token:
+ mp_make_exp_copy(mp, mp->cur_mod); break;
+ case tag_token:
+ @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
+ default:
+ mp_bad_exp(mp, "A primary"); goto RESTART; break;
+@.A primary expression...@>
+ }
+ mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
+DONE:
+ if ( mp->cur_cmd==left_bracket ) {
+ if ( mp->cur_type>=mp_known ) {
+ @<Scan a mediation construction@>;
+ }
+ }
+}
+
+
+
+@ Errors at the beginning of expressions are flagged by |bad_exp|.
+
+@c void mp_bad_exp (MP mp, const char * s) {
+ int save_flag;
+ print_err(s); mp_print(mp, " expression can't begin with `");
+ mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
+ mp_print_char(mp, '\'');
+ help4("I'm afraid I need some sort of value in order to continue,")
+ ("so I've tentatively inserted `0'. You may want to")
+ ("delete this zero and insert something else;")
+ ("see Chapter 27 of The METAFONTbook for an example.");
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+ mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
+ mp->cur_mod=0; mp_ins_error(mp);
+ save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
+ mp->var_flag=save_flag;
+}
+
+@ @<Supply diagnostic information, if requested@>=
+#ifdef DEBUG
+if ( mp->panicking ) mp_check_mem(mp, false);
+#endif
+if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
+ mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
+}
+
+@ @<Scan a delimited primary@>=
+{
+ l_delim=mp->cur_sym; r_delim=mp->cur_mod;
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
+ @<Scan the rest of a delimited set of numerics@>;
+ } else {
+ mp_check_delimiter(mp, l_delim,r_delim);
+ }
+}
+
+@ The |stash_in| subroutine puts the current (numeric) expression into a field
+within a ``big node.''
+
+@c void mp_stash_in (MP mp,pointer p) {
+ pointer q; /* temporary register */
+ type(p)=mp->cur_type;
+ if ( mp->cur_type==mp_known ) {
+ value(p)=mp->cur_exp;
+ } else {
+ if ( mp->cur_type==mp_independent ) {
+ @<Stash an independent |cur_exp| into a big node@>;
+ } else {
+ mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
+ /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
+ link(prev_dep(p))=p;
+ }
+ mp_free_node(mp, mp->cur_exp,value_node_size);
+ }
+ mp->cur_type=mp_vacuous;
+}
+
+@ In rare cases the current expression can become |independent|. There
+may be many dependency lists pointing to such an independent capsule,
+so we can't simply move it into place within a big node. Instead,
+we copy it, then recycle it.
+
+@ @<Stash an independent |cur_exp|...@>=
+{
+ q=mp_single_dependency(mp, mp->cur_exp);
+ if ( q==mp->dep_final ){
+ type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
+ } else {
+ type(p)=mp_dependent; mp_new_dep(mp, p,q);
+ }
+ mp_recycle_value(mp, mp->cur_exp);
+}
+
+@ This code uses the fact that |red_part_loc| and |green_part_loc|
+are synonymous with |x_part_loc| and |y_part_loc|.
+
+@<Scan the rest of a delimited set of numerics@>=
+{
+p=mp_stash_cur_exp(mp);
+mp_get_x_next(mp); mp_scan_expression(mp);
+@<Make sure the second part of a pair or color has a numeric type@>;
+q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
+if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
+else type(q)=mp_pair_type;
+mp_init_big_node(mp, q); r=value(q);
+mp_stash_in(mp, y_part_loc(r));
+mp_unstash_cur_exp(mp, p);
+mp_stash_in(mp, x_part_loc(r));
+if ( mp->cur_cmd==comma ) {
+ @<Scan the last of a triplet of numerics@>;
+}
+if ( mp->cur_cmd==comma ) {
+ type(q)=mp_cmykcolor_type;
+ mp_init_big_node(mp, q); t=value(q);
+ mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
+ value(cyan_part_loc(t))=value(red_part_loc(r));
+ mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
+ value(magenta_part_loc(t))=value(green_part_loc(r));
+ mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
+ value(yellow_part_loc(t))=value(blue_part_loc(r));
+ mp_recycle_value(mp, r);
+ r=t;
+ @<Scan the last of a quartet of numerics@>;
+}
+mp_check_delimiter(mp, l_delim,r_delim);
+mp->cur_type=type(q);
+mp->cur_exp=q;
+}
+
+@ @<Make sure the second part of a pair or color has a numeric type@>=
+if ( mp->cur_type<mp_known ) {
+ exp_err("Nonnumeric ypart has been replaced by 0");
+@.Nonnumeric...replaced by 0@>
+ help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
+ ("but after finding a nice `a' I found a `b' that isn't")
+ ("of numeric type. So I've changed that part to zero.")
+ ("(The b that I didn't like appears above the error message.)");
+ mp_put_get_flush_error(mp, 0);
+}
+
+@ @<Scan the last of a triplet of numerics@>=
+{
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type<mp_known ) {
+ exp_err("Nonnumeric third part has been replaced by 0");
+@.Nonnumeric...replaced by 0@>
+ help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
+ ("isn't of numeric type. So I've changed that part to zero.")
+ ("(The c that I didn't like appears above the error message.)");
+ mp_put_get_flush_error(mp, 0);
+ }
+ mp_stash_in(mp, blue_part_loc(r));
+}
+
+@ @<Scan the last of a quartet of numerics@>=
+{
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type<mp_known ) {
+ exp_err("Nonnumeric blackpart has been replaced by 0");
+@.Nonnumeric...replaced by 0@>
+ help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
+ ("of numeric type. So I've changed that part to zero.")
+ ("(The k that I didn't like appears above the error message.)");
+ mp_put_get_flush_error(mp, 0);
+ }
+ mp_stash_in(mp, black_part_loc(r));
+}
+
+@ The local variable |group_line| keeps track of the line
+where a \&{begingroup} command occurred; this will be useful
+in an error message if the group doesn't actually end.
+
+@<Other local variables for |scan_primary|@>=
+integer group_line; /* where a group began */
+
+@ @<Scan a grouped primary@>=
+{
+ group_line=mp_true_line(mp);
+ if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
+ save_boundary_item(p);
+ do {
+ mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
+ } while (mp->cur_cmd==semicolon);
+ if ( mp->cur_cmd!=end_group ) {
+ print_err("A group begun on line ");
+@.A group...never ended@>
+ mp_print_int(mp, group_line);
+ mp_print(mp, " never ended");
+ help2("I saw a `begingroup' back there that hasn't been matched")
+ ("by `endgroup'. So I've inserted `endgroup' now.");
+ mp_back_error(mp); mp->cur_cmd=end_group;
+ }
+ mp_unsave(mp);
+ /* this might change |cur_type|, if independent variables are recycled */
+ if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
+}
+
+@ @<Scan a string constant@>=
+{
+ mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
+}
+
+@ Later we'll come to procedures that perform actual operations like
+addition, square root, and so on; our purpose now is to do the parsing.
+But we might as well mention those future procedures now, so that the
+suspense won't be too bad:
+
+\smallskip
+|do_nullary(c)| does primitive operations that have no operands (e.g.,
+`\&{true}' or `\&{pencircle}');
+
+\smallskip
+|do_unary(c)| applies a primitive operation to the current expression;
+
+\smallskip
+|do_binary(p,c)| applies a primitive operation to the capsule~|p|
+and the current expression.
+
+@<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
+
+@ @<Scan a unary operation@>=
+{
+ c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
+ mp_do_unary(mp, c); goto DONE;
+}
+
+@ A numeric token might be a primary by itself, or it might be the
+numerator of a fraction composed solely of numeric tokens, or it might
+multiply the primary that follows (provided that the primary doesn't begin
+with a plus sign or a minus sign). The code here uses the facts that
+|max_primary_command=plus_or_minus| and
+|max_primary_command-1=numeric_token|. If a fraction is found that is less
+than unity, we try to retain higher precision when we use it in scalar
+multiplication.
+
+@<Other local variables for |scan_primary|@>=
+scaled num,denom; /* for primaries that are fractions, like `1/2' */
+
+@ @<Scan a primary that starts with a numeric token@>=
+{
+ mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
+ if ( mp->cur_cmd!=slash ) {
+ num=0; denom=0;
+ } else {
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd!=numeric_token ) {
+ mp_back_input(mp);
+ mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
+ goto DONE;
+ }
+ num=mp->cur_exp; denom=mp->cur_mod;
+ if ( denom==0 ) { @<Protest division by zero@>; }
+ else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
+ check_arith; mp_get_x_next(mp);
+ }
+ if ( mp->cur_cmd>=min_primary_command ) {
+ if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
+ p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
+ if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
+ mp_do_binary(mp, p,times);
+ } else {
+ mp_frac_mult(mp, num,denom);
+ mp_free_node(mp, p,value_node_size);
+ }
+ }
+ }
+ goto DONE;
+}
+
+@ @<Protest division...@>=
+{
+ print_err("Division by zero");
+@.Division by zero@>
+ help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
+}
+
+@ @<Scan a binary operation with `\&{of}' between its operands@>=
+{
+ c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_cmd!=of_token ) {
+ mp_missing_err(mp, "of"); mp_print(mp, " for ");
+ mp_print_cmd_mod(mp, primary_binary,c);
+@.Missing `of'@>
+ help1("I've got the first argument; will look now for the other.");
+ mp_back_error(mp);
+ }
+ p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
+ mp_do_binary(mp, p,c); goto DONE;
+}
+
+@ @<Convert a suffix to a string@>=
+{
+ mp_get_x_next(mp); mp_scan_suffix(mp);
+ mp->old_setting=mp->selector; mp->selector=new_string;
+ mp_show_token_list(mp, mp->cur_exp,null,100000,0);
+ mp_flush_token_list(mp, mp->cur_exp);
+ mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
+ mp->cur_type=mp_string_type;
+ goto DONE;
+}
+
+@ If an internal quantity appears all by itself on the left of an
+assignment, we return a token list of length one, containing the address
+of the internal quantity plus |hash_end|. (This accords with the conventions
+of the save stack, as described earlier.)
+
+@<Scan an internal...@>=
+{
+ q=mp->cur_mod;
+ if ( my_var_flag==assignment ) {
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd==assignment ) {
+ mp->cur_exp=mp_get_avail(mp);
+ info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
+ goto DONE;
+ }
+ mp_back_input(mp);
+ }
+ mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
+}
+
+@ The most difficult part of |scan_primary| has been saved for last, since
+it was necessary to build up some confidence first. We can now face the task
+of scanning a variable.
+
+As we scan a variable, we build a token list containing the relevant
+names and subscript values, simultaneously following along in the
+``collective'' structure to see if we are actually dealing with a macro
+instead of a value.
+
+The local variables |pre_head| and |post_head| will point to the beginning
+of the prefix and suffix lists; |tail| will point to the end of the list
+that is currently growing.
+
+Another local variable, |tt|, contains partial information about the
+declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
+relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
+doesn't bother to update its information about type. And if
+|undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
+
+@ @<Other local variables for |scan_primary|@>=
+pointer pre_head,post_head,tail;
+ /* prefix and suffix list variables */
+small_number tt; /* approximation to the type of the variable-so-far */
+pointer t; /* a token */
+pointer macro_ref = 0; /* reference count for a suffixed macro */
+
+@ @<Scan a variable primary...@>=
+{
+ fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
+ while (1) {
+ t=mp_cur_tok(mp); link(tail)=t;
+ if ( tt!=undefined ) {
+ @<Find the approximate type |tt| and corresponding~|q|@>;
+ if ( tt>=mp_unsuffixed_macro ) {
+ @<Either begin an unsuffixed macro call or
+ prepare for a suffixed one@>;
+ }
+ }
+ mp_get_x_next(mp); tail=t;
+ if ( mp->cur_cmd==left_bracket ) {
+ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
+ }
+ if ( mp->cur_cmd>max_suffix_token ) break;
+ if ( mp->cur_cmd<min_suffix_token ) break;
+ } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
+ @<Handle unusual cases that masquerade as variables, and |goto restart|
+ or |goto done| if appropriate;
+ otherwise make a copy of the variable and |goto done|@>;
+}
+
+@ @<Either begin an unsuffixed macro call or...@>=
+{
+ link(tail)=null;
+ if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
+ post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
+ tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
+ } else {
+ @<Set up unsuffixed macro call and |goto restart|@>;
+ }
+}
+
+@ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
+{
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_cmd!=right_bracket ) {
+ @<Put the left bracket and the expression back to be rescanned@>;
+ } else {
+ if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
+ mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
+ }
+}
+
+@ The left bracket that we thought was introducing a subscript might have
+actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
+So we don't issue an error message at this point; but we do want to back up
+so as to avoid any embarrassment about our incorrect assumption.
+
+@<Put the left bracket and the expression back to be rescanned@>=
+{
+ mp_back_input(mp); /* that was the token following the current expression */
+ mp_back_expr(mp); mp->cur_cmd=left_bracket;
+ mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
+}
+
+@ Here's a routine that puts the current expression back to be read again.
+
+@c void mp_back_expr (MP mp) {
+ pointer p; /* capsule token */
+ p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
+}
+
+@ Unknown subscripts lead to the following error message.
+
+@c void mp_bad_subscript (MP mp) {
+ exp_err("Improper subscript has been replaced by zero");
+@.Improper subscript...@>
+ help3("A bracketed subscript must have a known numeric value;")
+ ("unfortunately, what I found was the value that appears just")
+ ("above this error message. So I'll try a zero subscript.");
+ mp_flush_error(mp, 0);
+}
+
+@ Every time we call |get_x_next|, there's a chance that the variable we've
+been looking at will disappear. Thus, we cannot safely keep |q| pointing
+into the variable structure; we need to start searching from the root each time.
+
+@<Find the approximate type |tt| and corresponding~|q|@>=
+@^inner loop@>
+{
+ p=link(pre_head); q=info(p); tt=undefined;
+ if ( eq_type(q) % outer_tag==tag_token ) {
+ q=equiv(q);
+ if ( q==null ) goto DONE2;
+ while (1) {
+ p=link(p);
+ if ( p==null ) {
+ tt=type(q); goto DONE2;
+ };
+ if ( type(q)!=mp_structured ) goto DONE2;
+ q=link(attr_head(q)); /* the |collective_subscript| attribute */
+ if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
+ do { q=link(q); } while (! (attr_loc(q)>=info(p)));
+ if ( attr_loc(q)>info(p) ) goto DONE2;
+ }
+ }
+ }
+DONE2:
+ ;
+}
+
+@ How do things stand now? Well, we have scanned an entire variable name,
+including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
+|cur_sym| represent the token that follows. If |post_head=null|, a
+token list for this variable name starts at |link(pre_head)|, with all
+subscripts evaluated. But if |post_head<>null|, the variable turned out
+to be a suffixed macro; |pre_head| is the head of the prefix list, while
+|post_head| is the head of a token list containing both `\.{\AT!}' and
+the suffix.
+
+Our immediate problem is to see if this variable still exists. (Variable
+structures can change drastically whenever we call |get_x_next|; users
+aren't supposed to do this, but the fact that it is possible means that
+we must be cautious.)
+
+The following procedure prints an error message when a variable
+unexpectedly disappears. Its help message isn't quite right for
+our present purposes, but we'll be able to fix that up.
+
+@c
+void mp_obliterated (MP mp,pointer q) {
+ print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
+ mp_print(mp, " has been obliterated");
+@.Variable...obliterated@>
+ help5("It seems you did a nasty thing---probably by accident,")
+ ("but nevertheless you nearly hornswoggled me...")
+ ("While I was evaluating the right-hand side of this")
+ ("command, something happened, and the left-hand side")
+ ("is no longer a variable! So I won't change anything.");
+}
+
+@ If the variable does exist, we also need to check
+for a few other special cases before deciding that a plain old ordinary
+variable has, indeed, been scanned.
+
+@<Handle unusual cases that masquerade as variables...@>=
+if ( post_head!=null ) {
+ @<Set up suffixed macro call and |goto restart|@>;
+}
+q=link(pre_head); free_avail(pre_head);
+if ( mp->cur_cmd==my_var_flag ) {
+ mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
+}
+p=mp_find_variable(mp, q);
+if ( p!=null ) {
+ mp_make_exp_copy(mp, p);
+} else {
+ mp_obliterated(mp, q);
+ mp->help_line[2]="While I was evaluating the suffix of this variable,";
+ mp->help_line[1]="something was redefined, and it's no longer a variable!";
+ mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
+ mp_put_get_flush_error(mp, 0);
+}
+mp_flush_node_list(mp, q);
+goto DONE
+
+@ The only complication associated with macro calling is that the prefix
+and ``at'' parameters must be packaged in an appropriate list of lists.
+
+@<Set up unsuffixed macro call and |goto restart|@>=
+{
+ p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
+ info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
+ mp_get_x_next(mp);
+ goto RESTART;
+}
+
+@ If the ``variable'' that turned out to be a suffixed macro no longer exists,
+we don't care, because we have reserved a pointer (|macro_ref|) to its
+token list.
+
+@<Set up suffixed macro call and |goto restart|@>=
+{
+ mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
+ info(pre_head)=link(pre_head); link(pre_head)=post_head;
+ info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
+ mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
+ mp_get_x_next(mp); goto RESTART;
+}
+
+@ Our remaining job is simply to make a copy of the value that has been
+found. Some cases are harder than others, but complexity arises solely
+because of the multiplicity of possible cases.
+
+@<Declare the procedure called |make_exp_copy|@>=
+@<Declare subroutines needed by |make_exp_copy|@>
+void mp_make_exp_copy (MP mp,pointer p) {
+ pointer q,r,t; /* registers for list manipulation */
+RESTART:
+ mp->cur_type=type(p);
+ switch (mp->cur_type) {
+ case mp_vacuous: case mp_boolean_type: case mp_known:
+ mp->cur_exp=value(p); break;
+ case unknown_types:
+ mp->cur_exp=mp_new_ring_entry(mp, p);
+ break;
+ case mp_string_type:
+ mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
+ break;
+ case mp_picture_type:
+ mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
+ break;
+ case mp_pen_type:
+ mp->cur_exp=copy_pen(value(p));
+ break;
+ case mp_path_type:
+ mp->cur_exp=mp_copy_path(mp, value(p));
+ break;
+ case mp_transform_type: case mp_color_type:
+ case mp_cmykcolor_type: case mp_pair_type:
+ @<Copy the big node |p|@>;
+ break;
+ case mp_dependent: case mp_proto_dependent:
+ mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
+ break;
+ case mp_numeric_type:
+ new_indep(p); goto RESTART;
+ break;
+ case mp_independent:
+ q=mp_single_dependency(mp, p);
+ if ( q==mp->dep_final ){
+ mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
+ } else {
+ mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
+ }
+ break;
+ default:
+ mp_confusion(mp, "copy");
+@:this can't happen copy}{\quad copy@>
+ break;
+ }
+}
+
+@ The |encapsulate| subroutine assumes that |dep_final| is the
+tail of dependency list~|p|.
+
+@<Declare subroutines needed by |make_exp_copy|@>=
+void mp_encapsulate (MP mp,pointer p) {
+ mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
+ name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
+}
+
+@ The most tedious case arises when the user refers to a
+\&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
+each of which can be |independent|, |dependent|, |mp_proto_dependent|,
+or |known|.
+
+@<Copy the big node |p|@>=
+{
+ if ( value(p)==null )
+ mp_init_big_node(mp, p);
+ t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
+ mp_init_big_node(mp, t);
+ q=value(p)+mp->big_node_size[mp->cur_type];
+ r=value(t)+mp->big_node_size[mp->cur_type];
+ do {
+ q=q-2; r=r-2; mp_install(mp, r,q);
+ } while (q!=value(p));
+ mp->cur_exp=t;
+}
+
+@ The |install| procedure copies a numeric field~|q| into field~|r| of
+a big node that will be part of a capsule.
+
+@<Declare subroutines needed by |make_exp_copy|@>=
+void mp_install (MP mp,pointer r, pointer q) {
+ pointer p; /* temporary register */
+ if ( type(q)==mp_known ){
+ value(r)=value(q); type(r)=mp_known;
+ } else if ( type(q)==mp_independent ) {
+ p=mp_single_dependency(mp, q);
+ if ( p==mp->dep_final ) {
+ type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
+ } else {
+ type(r)=mp_dependent; mp_new_dep(mp, r,p);
+ }
+ } else {
+ type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
+ }
+}
+
+@ Expressions of the form `\.{a[b,c]}' are converted into
+`\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
+provided that \.a is numeric.
+
+@<Scan a mediation...@>=
+{
+ p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_cmd!=comma ) {
+ @<Put the left bracket and the expression back...@>;
+ mp_unstash_cur_exp(mp, p);
+ } else {
+ q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_cmd!=right_bracket ) {
+ mp_missing_err(mp, "]");
+@.Missing `]'@>
+ help3("I've scanned an expression of the form `a[b,c',")
+ ("so a right bracket should have come next.")
+ ("I shall pretend that one was there.");
+ mp_back_error(mp);
+ }
+ r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
+ mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
+ mp_do_binary(mp, q,plus); mp_get_x_next(mp);
+ }
+}
+
+@ Here is a comparatively simple routine that is used to scan the
+\&{suffix} parameters of a macro.
+
+@<Declare the basic parsing subroutines@>=
+void mp_scan_suffix (MP mp) {
+ pointer h,t; /* head and tail of the list being built */
+ pointer p; /* temporary register */
+ h=mp_get_avail(mp); t=h;
+ while (1) {
+ if ( mp->cur_cmd==left_bracket ) {
+ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
+ }
+ if ( mp->cur_cmd==numeric_token ) {
+ p=mp_new_num_tok(mp, mp->cur_mod);
+ } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
+ p=mp_get_avail(mp); info(p)=mp->cur_sym;
+ } else {
+ break;
+ }
+ link(t)=p; t=p; mp_get_x_next(mp);
+ }
+ mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
+}
+
+@ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
+{
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
+ if ( mp->cur_cmd!=right_bracket ) {
+ mp_missing_err(mp, "]");
+@.Missing `]'@>
+ help3("I've seen a `[' and a subscript value, in a suffix,")
+ ("so a right bracket should have come next.")
+ ("I shall pretend that one was there.");
+ mp_back_error(mp);
+ }
+ mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
+}
+
+@* \[38] Parsing secondary and higher expressions.
+
+After the intricacies of |scan_primary|\kern-1pt,
+the |scan_secondary| routine is
+refreshingly simple. It's not trivial, but the operations are relatively
+straightforward; the main difficulty is, again, that expressions and data
+structures might change drastically every time we call |get_x_next|, so a
+cautious approach is mandatory. For example, a macro defined by
+\&{primarydef} might have disappeared by the time its second argument has
+been scanned; we solve this by increasing the reference count of its token
+list, so that the macro can be called even after it has been clobbered.
+
+@<Declare the basic parsing subroutines@>=
+void mp_scan_secondary (MP mp) {
+ pointer p; /* for list manipulation */
+ halfword c,d; /* operation codes or modifiers */
+ pointer mac_name; /* token defined with \&{primarydef} */
+RESTART:
+ if ((mp->cur_cmd<min_primary_command)||
+ (mp->cur_cmd>max_primary_command) )
+ mp_bad_exp(mp, "A secondary");
+@.A secondary expression...@>
+ mp_scan_primary(mp);
+CONTINUE:
+ if ( mp->cur_cmd<=max_secondary_command &&
+ mp->cur_cmd>=min_secondary_command ) {
+ p=mp_stash_cur_exp(mp);
+ c=mp->cur_mod; d=mp->cur_cmd;
+ if ( d==secondary_primary_macro ) {
+ mac_name=mp->cur_sym;
+ add_mac_ref(c);
+ }
+ mp_get_x_next(mp);
+ mp_scan_primary(mp);
+ if ( d!=secondary_primary_macro ) {
+ mp_do_binary(mp, p,c);
+ } else {
+ mp_back_input(mp);
+ mp_binary_mac(mp, p,c,mac_name);
+ decr(ref_count(c));
+ mp_get_x_next(mp);
+ goto RESTART;
+ }
+ goto CONTINUE;
+ }
+}
+
+@ The following procedure calls a macro that has two parameters,
+|p| and |cur_exp|.
+
+@c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
+ pointer q,r; /* nodes in the parameter list */
+ q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
+ info(q)=p; info(r)=mp_stash_cur_exp(mp);
+ mp_macro_call(mp, c,q,n);
+}
+
+@ The next procedure, |scan_tertiary|, is pretty much the same deal.
+
+@<Declare the basic parsing subroutines@>=
+void mp_scan_tertiary (MP mp) {
+ pointer p; /* for list manipulation */
+ halfword c,d; /* operation codes or modifiers */
+ pointer mac_name; /* token defined with \&{secondarydef} */
+RESTART:
+ if ((mp->cur_cmd<min_primary_command)||
+ (mp->cur_cmd>max_primary_command) )
+ mp_bad_exp(mp, "A tertiary");
+@.A tertiary expression...@>
+ mp_scan_secondary(mp);
+CONTINUE:
+ if ( mp->cur_cmd<=max_tertiary_command ) {
+ if ( mp->cur_cmd>=min_tertiary_command ) {
+ p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
+ if ( d==tertiary_secondary_macro ) {
+ mac_name=mp->cur_sym; add_mac_ref(c);
+ };
+ mp_get_x_next(mp); mp_scan_secondary(mp);
+ if ( d!=tertiary_secondary_macro ) {
+ mp_do_binary(mp, p,c);
+ } else {
+ mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
+ decr(ref_count(c)); mp_get_x_next(mp);
+ goto RESTART;
+ }
+ goto CONTINUE;
+ }
+ }
+}
+
+@ Finally we reach the deepest level in our quartet of parsing routines.
+This one is much like the others; but it has an extra complication from
+paths, which materialize here.
+
+@d continue_path 25 /* a label inside of |scan_expression| */
+@d finish_path 26 /* another */
+
+@<Declare the basic parsing subroutines@>=
+void mp_scan_expression (MP mp) {
+ pointer p,q,r,pp,qq; /* for list manipulation */
+ halfword c,d; /* operation codes or modifiers */
+ int my_var_flag; /* initial value of |var_flag| */
+ pointer mac_name; /* token defined with \&{tertiarydef} */
+ boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
+ scaled x,y; /* explicit coordinates or tension at a path join */
+ int t; /* knot type following a path join */
+ t=0; y=0; x=0;
+ my_var_flag=mp->var_flag; mac_name=null;
+RESTART:
+ if ((mp->cur_cmd<min_primary_command)||
+ (mp->cur_cmd>max_primary_command) )
+ mp_bad_exp(mp, "An");
+@.An expression...@>
+ mp_scan_tertiary(mp);
+CONTINUE:
+ if ( mp->cur_cmd<=max_expression_command )
+ if ( mp->cur_cmd>=min_expression_command ) {
+ if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
+ p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
+ if ( d==expression_tertiary_macro ) {
+ mac_name=mp->cur_sym; add_mac_ref(c);
+ }
+ if ( (d<ampersand)||((d==ampersand)&&
+ ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
+ @<Scan a path construction operation;
+ but |return| if |p| has the wrong type@>;
+ } else {
+ mp_get_x_next(mp); mp_scan_tertiary(mp);
+ if ( d!=expression_tertiary_macro ) {
+ mp_do_binary(mp, p,c);
+ } else {
+ mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
+ decr(ref_count(c)); mp_get_x_next(mp);
+ goto RESTART;
+ }
+ }
+ goto CONTINUE;
+ }
+ }
+}
+
+@ The reader should review the data structure conventions for paths before
+hoping to understand the next part of this code.
+
+@<Scan a path construction operation...@>=
+{
+ cycle_hit=false;
+ @<Convert the left operand, |p|, into a partial path ending at~|q|;
+ but |return| if |p| doesn't have a suitable type@>;
+CONTINUE_PATH:
+ @<Determine the path join parameters;
+ but |goto finish_path| if there's only a direction specifier@>;
+ if ( mp->cur_cmd==cycle ) {
+ @<Get ready to close a cycle@>;
+ } else {
+ mp_scan_tertiary(mp);
+ @<Convert the right operand, |cur_exp|,
+ into a partial path from |pp| to~|qq|@>;
+ }
+ @<Join the partial paths and reset |p| and |q| to the head and tail
+ of the result@>;
+ if ( mp->cur_cmd>=min_expression_command )
+ if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
+FINISH_PATH:
+ @<Choose control points for the path and put the result into |cur_exp|@>;
+}
+
+@ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
+{
+ mp_unstash_cur_exp(mp, p);
+ if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
+ else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
+ else return;
+ q=p;
+ while ( link(q)!=p ) q=link(q);
+ if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
+ r=mp_copy_knot(mp, p); link(q)=r; q=r;
+ }
+ left_type(p)=mp_open; right_type(q)=mp_open;
+}
+
+@ A pair of numeric values is changed into a knot node for a one-point path
+when \MP\ discovers that the pair is part of a path.
+
+@c @<Declare the procedure called |known_pair|@>
+pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
+ pointer q; /* the new node */
+ q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
+ right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
+ mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
+ return q;
+}
+
+@ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
+of the current expression, assuming that the current expression is a
+pair of known numerics. Unknown components are zeroed, and the
+current expression is flushed.
+
+@<Declare the procedure called |known_pair|@>=
+void mp_known_pair (MP mp) {
+ pointer p; /* the pair node */
+ if ( mp->cur_type!=mp_pair_type ) {
+ exp_err("Undefined coordinates have been replaced by (0,0)");
+@.Undefined coordinates...@>
+ help5("I need x and y numbers for this part of the path.")
+ ("The value I found (see above) was no good;")
+ ("so I'll try to keep going by using zero instead.")
+ ("(Chapter 27 of The METAFONTbook explains that")
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+ ("you might want to type `I ??" "?' now.)");
+ mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
+ } else {
+ p=value(mp->cur_exp);
+ @<Make sure that both |x| and |y| parts of |p| are known;
+ copy them into |cur_x| and |cur_y|@>;
+ mp_flush_cur_exp(mp, 0);
+ }
+}
+
+@ @<Make sure that both |x| and |y| parts of |p| are known...@>=
+if ( type(x_part_loc(p))==mp_known ) {
+ mp->cur_x=value(x_part_loc(p));
+} else {
+ mp_disp_err(mp, x_part_loc(p),
+ "Undefined x coordinate has been replaced by 0");
+@.Undefined coordinates...@>
+ help5("I need a `known' x value for this part of the path.")
+ ("The value I found (see above) was no good;")
+ ("so I'll try to keep going by using zero instead.")
+ ("(Chapter 27 of The METAFONTbook explains that")
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+ ("you might want to type `I ??" "?' now.)");
+ mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
+}
+if ( type(y_part_loc(p))==mp_known ) {
+ mp->cur_y=value(y_part_loc(p));
+} else {
+ mp_disp_err(mp, y_part_loc(p),
+ "Undefined y coordinate has been replaced by 0");
+ help5("I need a `known' y value for this part of the path.")
+ ("The value I found (see above) was no good;")
+ ("so I'll try to keep going by using zero instead.")
+ ("(Chapter 27 of The METAFONTbook explains that")
+ ("you might want to type `I ??" "?' now.)");
+ mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
+}
+
+@ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
+
+@<Determine the path join parameters...@>=
+if ( mp->cur_cmd==left_brace ) {
+ @<Put the pre-join direction information into node |q|@>;
+}
+d=mp->cur_cmd;
+if ( d==path_join ) {
+ @<Determine the tension and/or control points@>;
+} else if ( d!=ampersand ) {
+ goto FINISH_PATH;
+}
+mp_get_x_next(mp);
+if ( mp->cur_cmd==left_brace ) {
+ @<Put the post-join direction information into |x| and |t|@>;
+} else if ( right_type(q)!=mp_explicit ) {
+ t=mp_open; x=0;
+}
+
+@ The |scan_direction| subroutine looks at the directional information
+that is enclosed in braces, and also scans ahead to the following character.
+A type code is returned, either |open| (if the direction was $(0,0)$),
+or |curl| (if the direction was a curl of known value |cur_exp|), or
+|given| (if the direction is given by the |angle| value that now
+appears in |cur_exp|).
+
+There's nothing difficult about this subroutine, but the program is rather
+lengthy because a variety of potential errors need to be nipped in the bud.
+
+@c small_number mp_scan_direction (MP mp) {
+ int t; /* the type of information found */
+ scaled x; /* an |x| coordinate */
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd==curl_command ) {
+ @<Scan a curl specification@>;
+ } else {
+ @<Scan a given direction@>;
+ }
+ if ( mp->cur_cmd!=right_brace ) {
+ mp_missing_err(mp, "}");
+@.Missing `\char`\}'@>
+ help3("I've scanned a direction spec for part of a path,")
+ ("so a right brace should have come next.")
+ ("I shall pretend that one was there.");
+ mp_back_error(mp);
+ }
+ mp_get_x_next(mp);
+ return t;
+}
+
+@ @<Scan a curl specification@>=
+{ mp_get_x_next(mp); mp_scan_expression(mp);
+if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
+ exp_err("Improper curl has been replaced by 1");
+@.Improper curl@>
+ help1("A curl must be a known, nonnegative number.");
+ mp_put_get_flush_error(mp, unity);
+}
+t=mp_curl;
+}
+
+@ @<Scan a given direction@>=
+{ mp_scan_expression(mp);
+ if ( mp->cur_type>mp_pair_type ) {
+ @<Get given directions separated by commas@>;
+ } else {
+ mp_known_pair(mp);
+ }
+ if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
+ else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
+}
+
+@ @<Get given directions separated by commas@>=
+{
+ if ( mp->cur_type!=mp_known ) {
+ exp_err("Undefined x coordinate has been replaced by 0");
+@.Undefined coordinates...@>
+ help5("I need a `known' x value for this part of the path.")
+ ("The value I found (see above) was no good;")
+ ("so I'll try to keep going by using zero instead.")
+ ("(Chapter 27 of The METAFONTbook explains that")
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+ ("you might want to type `I ??" "?' now.)");
+ mp_put_get_flush_error(mp, 0);
+ }
+ x=mp->cur_exp;
+ if ( mp->cur_cmd!=comma ) {
+ mp_missing_err(mp, ",");
+@.Missing `,'@>
+ help2("I've got the x coordinate of a path direction;")
+ ("will look for the y coordinate next.");
+ mp_back_error(mp);
+ }
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ) {
+ exp_err("Undefined y coordinate has been replaced by 0");
+ help5("I need a `known' y value for this part of the path.")
+ ("The value I found (see above) was no good;")
+ ("so I'll try to keep going by using zero instead.")
+ ("(Chapter 27 of The METAFONTbook explains that")
+ ("you might want to type `I ??" "?' now.)");
+ mp_put_get_flush_error(mp, 0);
+ }
+ mp->cur_y=mp->cur_exp; mp->cur_x=x;
+}
+
+@ At this point |right_type(q)| is usually |open|, but it may have been
+set to some other value by a previous operation. We must maintain
+the value of |right_type(q)| in cases such as
+`\.{..\{curl2\}z\{0,0\}..}'.
+
+@<Put the pre-join...@>=
+{
+ t=mp_scan_direction(mp);
+ if ( t!=mp_open ) {
+ right_type(q)=t; right_given(q)=mp->cur_exp;
+ if ( left_type(q)==mp_open ) {
+ left_type(q)=t; left_given(q)=mp->cur_exp;
+ } /* note that |left_given(q)=left_curl(q)| */
+ }
+}
+
+@ Since |left_tension| and |left_y| share the same position in knot nodes,
+and since |left_given| is similarly equivalent to |left_x|, we use
+|x| and |y| to hold the given direction and tension information when
+there are no explicit control points.
+
+@<Put the post-join...@>=
+{
+ t=mp_scan_direction(mp);
+ if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
+ else t=mp_explicit; /* the direction information is superfluous */
+}
+
+@ @<Determine the tension and/or...@>=
+{
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd==tension ) {
+ @<Set explicit tensions@>;
+ } else if ( mp->cur_cmd==controls ) {
+ @<Set explicit control points@>;
+ } else {
+ right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
+ goto DONE;
+ };
+ if ( mp->cur_cmd!=path_join ) {
+ mp_missing_err(mp, "..");
+@.Missing `..'@>
+ help1("A path join command should end with two dots.");
+ mp_back_error(mp);
+ }
+DONE:
+ ;
+}
+
+@ @<Set explicit tensions@>=
+{
+ mp_get_x_next(mp); y=mp->cur_cmd;
+ if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
+ mp_scan_primary(mp);
+ @<Make sure that the current expression is a valid tension setting@>;
+ if ( y==at_least ) negate(mp->cur_exp);
+ right_tension(q)=mp->cur_exp;
+ if ( mp->cur_cmd==and_command ) {
+ mp_get_x_next(mp); y=mp->cur_cmd;
+ if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
+ mp_scan_primary(mp);
+ @<Make sure that the current expression is a valid tension setting@>;
+ if ( y==at_least ) negate(mp->cur_exp);
+ }
+ y=mp->cur_exp;
+}
+
+@ @d min_tension three_quarter_unit
+
+@<Make sure that the current expression is a valid tension setting@>=
+if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
+ exp_err("Improper tension has been set to 1");
+@.Improper tension@>
+ help1("The expression above should have been a number >=3/4.");
+ mp_put_get_flush_error(mp, unity);
+}
+
+@ @<Set explicit control points@>=
+{
+ right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
+ mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
+ if ( mp->cur_cmd!=and_command ) {
+ x=right_x(q); y=right_y(q);
+ } else {
+ mp_get_x_next(mp); mp_scan_primary(mp);
+ mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
+ }
+}
+
+@ @<Convert the right operand, |cur_exp|, into a partial path...@>=
+{
+ if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
+ else pp=mp->cur_exp;
+ qq=pp;
+ while ( link(qq)!=pp ) qq=link(qq);
+ if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
+ r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
+ }
+ left_type(pp)=mp_open; right_type(qq)=mp_open;
+}
+
+@ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
+we silently change the specification to `\.{(x,y)..cycle}', since a cycle
+shouldn't have length zero.
+
+@<Get ready to close a cycle@>=
+{
+ cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
+ if ( d==ampersand ) if ( p==q ) {
+ d=path_join; right_tension(q)=unity; y=unity;
+ }
+}
+
+@ @<Join the partial paths and reset |p| and |q|...@>=
+{
+if ( d==ampersand ) {
+ if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
+ print_err("Paths don't touch; `&' will be changed to `..'");
+@.Paths don't touch@>
+ help3("When you join paths `p&q', the ending point of p")
+ ("must be exactly equal to the starting point of q.")
+ ("So I'm going to pretend that you said `p..q' instead.");
+ mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
+ }
+}
+@<Plug an opening in |right_type(pp)|, if possible@>;
+if ( d==ampersand ) {
+ @<Splice independent paths together@>;
+} else {
+ @<Plug an opening in |right_type(q)|, if possible@>;
+ link(q)=pp; left_y(pp)=y;
+ if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
+}
+q=qq;
+}
+
+@ @<Plug an opening in |right_type(q)|...@>=
+if ( right_type(q)==mp_open ) {
+ if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
+ right_type(q)=left_type(q); right_given(q)=left_given(q);
+ }
+}
+
+@ @<Plug an opening in |right_type(pp)|...@>=
+if ( right_type(pp)==mp_open ) {
+ if ( (t==mp_curl)||(t==mp_given) ) {
+ right_type(pp)=t; right_given(pp)=x;
+ }
+}
+
+@ @<Splice independent paths together@>=
+{
+ if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
+ left_type(q)=mp_curl; left_curl(q)=unity;
+ }
+ if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
+ right_type(pp)=mp_curl; right_curl(pp)=unity;
+ }
+ right_type(q)=right_type(pp); link(q)=link(pp);
+ right_x(q)=right_x(pp); right_y(q)=right_y(pp);
+ mp_free_node(mp, pp,knot_node_size);
+ if ( qq==pp ) qq=q;
+}
+
+@ @<Choose control points for the path...@>=
+if ( cycle_hit ) {
+ if ( d==ampersand ) p=q;
+} else {
+ left_type(p)=mp_endpoint;
+ if ( right_type(p)==mp_open ) {
+ right_type(p)=mp_curl; right_curl(p)=unity;
+ }
+ right_type(q)=mp_endpoint;
+ if ( left_type(q)==mp_open ) {
+ left_type(q)=mp_curl; left_curl(q)=unity;
+ }
+ link(q)=p;
+}
+mp_make_choices(mp, p);
+mp->cur_type=mp_path_type; mp->cur_exp=p
+
+@ Finally, we sometimes need to scan an expression whose value is
+supposed to be either |true_code| or |false_code|.
+
+@<Declare the basic parsing subroutines@>=
+void mp_get_boolean (MP mp) {
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_boolean_type ) {
+ exp_err("Undefined condition will be treated as `false'");
+@.Undefined condition...@>
+ help2("The expression shown above should have had a definite")
+ ("true-or-false value. I'm changing it to `false'.");
+ mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
+ }
+}
+
+@* \[39] Doing the operations.
+The purpose of parsing is primarily to permit people to avoid piles of
+parentheses. But the real work is done after the structure of an expression
+has been recognized; that's when new expressions are generated. We
+turn now to the guts of \MP, which handles individual operators that
+have come through the parsing mechanism.
+
+We'll start with the easy ones that take no operands, then work our way
+up to operators with one and ultimately two arguments. In other words,
+we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
+that are invoked periodically by the expression scanners.
+
+First let's make sure that all of the primitive operators are in the
+hash table. Although |scan_primary| and its relatives made use of the
+\\{cmd} code for these operators, the \\{do} routines base everything
+on the \\{mod} code. For example, |do_binary| doesn't care whether the
+operation it performs is a |primary_binary| or |secondary_binary|, etc.
+
+@<Put each...@>=
+mp_primitive(mp, "true",nullary,true_code);
+@:true_}{\&{true} primitive@>
+mp_primitive(mp, "false",nullary,false_code);
+@:false_}{\&{false} primitive@>
+mp_primitive(mp, "nullpicture",nullary,null_picture_code);
+@:null_picture_}{\&{nullpicture} primitive@>
+mp_primitive(mp, "nullpen",nullary,null_pen_code);
+@:null_pen_}{\&{nullpen} primitive@>
+mp_primitive(mp, "jobname",nullary,job_name_op);
+@:job_name_}{\&{jobname} primitive@>
+mp_primitive(mp, "readstring",nullary,read_string_op);
+@:read_string_}{\&{readstring} primitive@>
+mp_primitive(mp, "pencircle",nullary,pen_circle);
+@:pen_circle_}{\&{pencircle} primitive@>
+mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
+@:normal_deviate_}{\&{normaldeviate} primitive@>
+mp_primitive(mp, "readfrom",unary,read_from_op);
+@:read_from_}{\&{readfrom} primitive@>
+mp_primitive(mp, "closefrom",unary,close_from_op);
+@:close_from_}{\&{closefrom} primitive@>
+mp_primitive(mp, "odd",unary,odd_op);
+@:odd_}{\&{odd} primitive@>
+mp_primitive(mp, "known",unary,known_op);
+@:known_}{\&{known} primitive@>
+mp_primitive(mp, "unknown",unary,unknown_op);
+@:unknown_}{\&{unknown} primitive@>
+mp_primitive(mp, "not",unary,not_op);
+@:not_}{\&{not} primitive@>
+mp_primitive(mp, "decimal",unary,decimal);
+@:decimal_}{\&{decimal} primitive@>
+mp_primitive(mp, "reverse",unary,reverse);
+@:reverse_}{\&{reverse} primitive@>
+mp_primitive(mp, "makepath",unary,make_path_op);
+@:make_path_}{\&{makepath} primitive@>
+mp_primitive(mp, "makepen",unary,make_pen_op);
+@:make_pen_}{\&{makepen} primitive@>
+mp_primitive(mp, "oct",unary,oct_op);
+@:oct_}{\&{oct} primitive@>
+mp_primitive(mp, "hex",unary,hex_op);
+@:hex_}{\&{hex} primitive@>
+mp_primitive(mp, "ASCII",unary,ASCII_op);
+@:ASCII_}{\&{ASCII} primitive@>
+mp_primitive(mp, "char",unary,char_op);
+@:char_}{\&{char} primitive@>
+mp_primitive(mp, "length",unary,length_op);
+@:length_}{\&{length} primitive@>
+mp_primitive(mp, "turningnumber",unary,turning_op);
+@:turning_number_}{\&{turningnumber} primitive@>
+mp_primitive(mp, "xpart",unary,x_part);
+@:x_part_}{\&{xpart} primitive@>
+mp_primitive(mp, "ypart",unary,y_part);
+@:y_part_}{\&{ypart} primitive@>
+mp_primitive(mp, "xxpart",unary,xx_part);
+@:xx_part_}{\&{xxpart} primitive@>
+mp_primitive(mp, "xypart",unary,xy_part);
+@:xy_part_}{\&{xypart} primitive@>
+mp_primitive(mp, "yxpart",unary,yx_part);
+@:yx_part_}{\&{yxpart} primitive@>
+mp_primitive(mp, "yypart",unary,yy_part);
+@:yy_part_}{\&{yypart} primitive@>
+mp_primitive(mp, "redpart",unary,red_part);
+@:red_part_}{\&{redpart} primitive@>
+mp_primitive(mp, "greenpart",unary,green_part);
+@:green_part_}{\&{greenpart} primitive@>
+mp_primitive(mp, "bluepart",unary,blue_part);
+@:blue_part_}{\&{bluepart} primitive@>
+mp_primitive(mp, "cyanpart",unary,cyan_part);
+@:cyan_part_}{\&{cyanpart} primitive@>
+mp_primitive(mp, "magentapart",unary,magenta_part);
+@:magenta_part_}{\&{magentapart} primitive@>
+mp_primitive(mp, "yellowpart",unary,yellow_part);
+@:yellow_part_}{\&{yellowpart} primitive@>
+mp_primitive(mp, "blackpart",unary,black_part);
+@:black_part_}{\&{blackpart} primitive@>
+mp_primitive(mp, "greypart",unary,grey_part);
+@:grey_part_}{\&{greypart} primitive@>
+mp_primitive(mp, "colormodel",unary,color_model_part);
+@:color_model_part_}{\&{colormodel} primitive@>
+mp_primitive(mp, "fontpart",unary,font_part);
+@:font_part_}{\&{fontpart} primitive@>
+mp_primitive(mp, "textpart",unary,text_part);
+@:text_part_}{\&{textpart} primitive@>
+mp_primitive(mp, "pathpart",unary,path_part);
+@:path_part_}{\&{pathpart} primitive@>
+mp_primitive(mp, "penpart",unary,pen_part);
+@:pen_part_}{\&{penpart} primitive@>
+mp_primitive(mp, "dashpart",unary,dash_part);
+@:dash_part_}{\&{dashpart} primitive@>
+mp_primitive(mp, "sqrt",unary,sqrt_op);
+@:sqrt_}{\&{sqrt} primitive@>
+mp_primitive(mp, "mexp",unary,m_exp_op);
+@:m_exp_}{\&{mexp} primitive@>
+mp_primitive(mp, "mlog",unary,m_log_op);
+@:m_log_}{\&{mlog} primitive@>
+mp_primitive(mp, "sind",unary,sin_d_op);
+@:sin_d_}{\&{sind} primitive@>
+mp_primitive(mp, "cosd",unary,cos_d_op);
+@:cos_d_}{\&{cosd} primitive@>
+mp_primitive(mp, "floor",unary,floor_op);
+@:floor_}{\&{floor} primitive@>
+mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
+@:uniform_deviate_}{\&{uniformdeviate} primitive@>
+mp_primitive(mp, "charexists",unary,char_exists_op);
+@:char_exists_}{\&{charexists} primitive@>
+mp_primitive(mp, "fontsize",unary,font_size);
+@:font_size_}{\&{fontsize} primitive@>
+mp_primitive(mp, "llcorner",unary,ll_corner_op);
+@:ll_corner_}{\&{llcorner} primitive@>
+mp_primitive(mp, "lrcorner",unary,lr_corner_op);
+@:lr_corner_}{\&{lrcorner} primitive@>
+mp_primitive(mp, "ulcorner",unary,ul_corner_op);
+@:ul_corner_}{\&{ulcorner} primitive@>
+mp_primitive(mp, "urcorner",unary,ur_corner_op);
+@:ur_corner_}{\&{urcorner} primitive@>
+mp_primitive(mp, "arclength",unary,arc_length);
+@:arc_length_}{\&{arclength} primitive@>
+mp_primitive(mp, "angle",unary,angle_op);
+@:angle_}{\&{angle} primitive@>
+mp_primitive(mp, "cycle",cycle,cycle_op);
+@:cycle_}{\&{cycle} primitive@>
+mp_primitive(mp, "stroked",unary,stroked_op);
+@:stroked_}{\&{stroked} primitive@>
+mp_primitive(mp, "filled",unary,filled_op);
+@:filled_}{\&{filled} primitive@>
+mp_primitive(mp, "textual",unary,textual_op);
+@:textual_}{\&{textual} primitive@>
+mp_primitive(mp, "clipped",unary,clipped_op);
+@:clipped_}{\&{clipped} primitive@>
+mp_primitive(mp, "bounded",unary,bounded_op);
+@:bounded_}{\&{bounded} primitive@>
+mp_primitive(mp, "+",plus_or_minus,plus);
+@:+ }{\.{+} primitive@>
+mp_primitive(mp, "-",plus_or_minus,minus);
+@:- }{\.{-} primitive@>
+mp_primitive(mp, "*",secondary_binary,times);
+@:* }{\.{*} primitive@>
+mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
+@:/ }{\.{/} primitive@>
+mp_primitive(mp, "++",tertiary_binary,pythag_add);
+@:++_}{\.{++} primitive@>
+mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
+@:+-+_}{\.{+-+} primitive@>
+mp_primitive(mp, "or",tertiary_binary,or_op);
+@:or_}{\&{or} primitive@>
+mp_primitive(mp, "and",and_command,and_op);
+@:and_}{\&{and} primitive@>
+mp_primitive(mp, "<",expression_binary,less_than);
+@:< }{\.{<} primitive@>
+mp_primitive(mp, "<=",expression_binary,less_or_equal);
+@:<=_}{\.{<=} primitive@>
+mp_primitive(mp, ">",expression_binary,greater_than);
+@:> }{\.{>} primitive@>
+mp_primitive(mp, ">=",expression_binary,greater_or_equal);
+@:>=_}{\.{>=} primitive@>
+mp_primitive(mp, "=",equals,equal_to);
+@:= }{\.{=} primitive@>
+mp_primitive(mp, "<>",expression_binary,unequal_to);
+@:<>_}{\.{<>} primitive@>
+mp_primitive(mp, "substring",primary_binary,substring_of);
+@:substring_}{\&{substring} primitive@>
+mp_primitive(mp, "subpath",primary_binary,subpath_of);
+@:subpath_}{\&{subpath} primitive@>
+mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
+@:direction_time_}{\&{directiontime} primitive@>
+mp_primitive(mp, "point",primary_binary,point_of);
+@:point_}{\&{point} primitive@>
+mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
+@:precontrol_}{\&{precontrol} primitive@>
+mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
+@:postcontrol_}{\&{postcontrol} primitive@>
+mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
+@:pen_offset_}{\&{penoffset} primitive@>
+mp_primitive(mp, "arctime",primary_binary,arc_time_of);
+@:arc_time_of_}{\&{arctime} primitive@>
+mp_primitive(mp, "mpversion",nullary,mp_version);
+@:mp_verison_}{\&{mpversion} primitive@>
+mp_primitive(mp, "&",ampersand,concatenate);
+@:!!!}{\.{\&} primitive@>
+mp_primitive(mp, "rotated",secondary_binary,rotated_by);
+@:rotated_}{\&{rotated} primitive@>
+mp_primitive(mp, "slanted",secondary_binary,slanted_by);
+@:slanted_}{\&{slanted} primitive@>
+mp_primitive(mp, "scaled",secondary_binary,scaled_by);
+@:scaled_}{\&{scaled} primitive@>
+mp_primitive(mp, "shifted",secondary_binary,shifted_by);
+@:shifted_}{\&{shifted} primitive@>
+mp_primitive(mp, "transformed",secondary_binary,transformed_by);
+@:transformed_}{\&{transformed} primitive@>
+mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
+@:x_scaled_}{\&{xscaled} primitive@>
+mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
+@:y_scaled_}{\&{yscaled} primitive@>
+mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
+@:z_scaled_}{\&{zscaled} primitive@>
+mp_primitive(mp, "infont",secondary_binary,in_font);
+@:in_font_}{\&{infont} primitive@>
+mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
+@:intersection_times_}{\&{intersectiontimes} primitive@>
+mp_primitive(mp, "envelope",primary_binary,envelope_of);
+@:envelope_}{\&{envelope} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case nullary:
+case unary:
+case primary_binary:
+case secondary_binary:
+case tertiary_binary:
+case expression_binary:
+case cycle:
+case plus_or_minus:
+case slash:
+case ampersand:
+case equals:
+case and_command:
+ mp_print_op(mp, m);
+ break;
+
+@ OK, let's look at the simplest \\{do} procedure first.
+
+@c @<Declare nullary action procedure@>
+void mp_do_nullary (MP mp,quarterword c) {
+ check_arith;
+ if ( mp->internal[mp_tracing_commands]>two )
+ mp_show_cmd_mod(mp, nullary,c);
+ switch (c) {
+ case true_code: case false_code:
+ mp->cur_type=mp_boolean_type; mp->cur_exp=c;
+ break;
+ case null_picture_code:
+ mp->cur_type=mp_picture_type;
+ mp->cur_exp=mp_get_node(mp, edge_header_size);
+ mp_init_edges(mp, mp->cur_exp);
+ break;
+ case null_pen_code:
+ mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
+ break;
+ case normal_deviate:
+ mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
+ break;
+ case pen_circle:
+ mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
+ break;
+ case job_name_op:
+ if ( mp->job_name==NULL ) mp_open_log_file(mp);
+ mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
+ break;
+ case mp_version:
+ mp->cur_type=mp_string_type;
+ mp->cur_exp=intern(metapost_version) ;
+ break;
+ case read_string_op:
+ @<Read a string from the terminal@>;
+ break;
+ } /* there are no other cases */
+ check_arith;
+}
+
+@ @<Read a string...@>=
+{
+ if ( mp->interaction<=mp_nonstop_mode )
+ mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
+ mp_begin_file_reading(mp); name=is_read;
+ limit=start; prompt_input("");
+ mp_finish_read(mp);
+}
+
+@ @<Declare nullary action procedure@>=
+void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
+ size_t k;
+ str_room((int)mp->last-start);
+ for (k=start;k<=mp->last-1;k++) {
+ append_char(mp->buffer[k]);
+ }
+ mp_end_file_reading(mp); mp->cur_type=mp_string_type;
+ mp->cur_exp=mp_make_string(mp);
+}
+
+@ Things get a bit more interesting when there's an operand. The
+operand to |do_unary| appears in |cur_type| and |cur_exp|.
+
+@c @<Declare unary action procedures@>
+void mp_do_unary (MP mp,quarterword c) {
+ pointer p,q,r; /* for list manipulation */
+ integer x; /* a temporary register */
+ check_arith;
+ if ( mp->internal[mp_tracing_commands]>two )
+ @<Trace the current unary operation@>;
+ switch (c) {
+ case plus:
+ if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
+ break;
+ case minus:
+ @<Negate the current expression@>;
+ break;
+ @<Additional cases of unary operators@>;
+ } /* there are no other cases */
+ check_arith;
+}
+
+@ The |nice_pair| function returns |true| if both components of a pair
+are known.
+
+@<Declare unary action procedures@>=
+boolean mp_nice_pair (MP mp,integer p, quarterword t) {
+ if ( t==mp_pair_type ) {
+ p=value(p);
+ if ( type(x_part_loc(p))==mp_known )
+ if ( type(y_part_loc(p))==mp_known )
+ return true;
+ }
+ return false;
+}
+
+@ The |nice_color_or_pair| function is analogous except that it also accepts
+fully known colors.
+
+@<Declare unary action procedures@>=
+boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
+ pointer q,r; /* for scanning the big node */
+ if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
+ return false;
+ } else {
+ q=value(p);
+ r=q+mp->big_node_size[type(p)];
+ do {
+ r=r-2;
+ if ( type(r)!=mp_known )
+ return false;
+ } while (r!=q);
+ return true;
+ }
+}
+
+@ @<Declare unary action...@>=
+void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
+ mp_print_char(mp, '(');
+ if ( t>mp_known ) mp_print(mp, "unknown numeric");
+ else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
+ if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
+ mp_print_type(mp, t);
+ }
+ mp_print_char(mp, ')');
+}
+
+@ @<Declare unary action...@>=
+void mp_bad_unary (MP mp,quarterword c) {
+ exp_err("Not implemented: "); mp_print_op(mp, c);
+@.Not implemented...@>
+ mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
+ help3("I'm afraid I don't know how to apply that operation to that")
+ ("particular type. Continue, and I'll simply return the")
+ ("argument (shown above) as the result of the operation.");
+ mp_put_get_error(mp);
+}
+
+@ @<Trace the current unary operation@>=
+{
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
+ mp_print_op(mp, c); mp_print_char(mp, '(');
+ mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
+ mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
+}
+
+@ Negation is easy except when the current expression
+is of type |independent|, or when it is a pair with one or more
+|independent| components.
+
+It is tempting to argue that the negative of an independent variable
+is an independent variable, hence we don't have to do anything when
+negating it. The fallacy is that other dependent variables pointing
+to the current expression must change the sign of their
+coefficients if we make no change to the current expression.
+
+Instead, we work around the problem by copying the current expression
+and recycling it afterwards (cf.~the |stash_in| routine).
+
+@<Negate the current expression@>=
+switch (mp->cur_type) {
+case mp_color_type:
+case mp_cmykcolor_type:
+case mp_pair_type:
+case mp_independent:
+ q=mp->cur_exp; mp_make_exp_copy(mp, q);
+ if ( mp->cur_type==mp_dependent ) {
+ mp_negate_dep_list(mp, dep_list(mp->cur_exp));
+ } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
+ p=value(mp->cur_exp);
+ r=p+mp->big_node_size[mp->cur_type];
+ do {
+ r=r-2;
+ if ( type(r)==mp_known ) negate(value(r));
+ else mp_negate_dep_list(mp, dep_list(r));
+ } while (r!=p);
+ } /* if |cur_type=mp_known| then |cur_exp=0| */
+ mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
+ break;
+case mp_dependent:
+case mp_proto_dependent:
+ mp_negate_dep_list(mp, dep_list(mp->cur_exp));
+ break;
+case mp_known:
+ negate(mp->cur_exp);
+ break;
+default:
+ mp_bad_unary(mp, minus);
+ break;
+}
+
+@ @<Declare unary action...@>=
+void mp_negate_dep_list (MP mp,pointer p) {
+ while (1) {
+ negate(value(p));
+ if ( info(p)==null ) return;
+ p=link(p);
+ }
+}
+
+@ @<Additional cases of unary operators@>=
+case not_op:
+ if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
+ else mp->cur_exp=true_code+false_code-mp->cur_exp;
+ break;
+
+@ @d three_sixty_units 23592960 /* that's |360*unity| */
+@d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
+
+@<Additional cases of unary operators@>=
+case sqrt_op:
+case m_exp_op:
+case m_log_op:
+case sin_d_op:
+case cos_d_op:
+case floor_op:
+case uniform_deviate:
+case odd_op:
+case char_exists_op:
+ if ( mp->cur_type!=mp_known ) {
+ mp_bad_unary(mp, c);
+ } else {
+ switch (c) {
+ case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
+ case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
+ case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
+ case sin_d_op:
+ case cos_d_op:
+ mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
+ if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
+ else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
+ break;
+ case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
+ case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
+ case odd_op:
+ boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
+ mp->cur_type=mp_boolean_type;
+ break;
+ case char_exists_op:
+ @<Determine if a character has been shipped out@>;
+ break;
+ } /* there are no other cases */
+ }
+ break;
+
+@ @<Additional cases of unary operators@>=
+case angle_op:
+ if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
+ p=value(mp->cur_exp);
+ x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
+ if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
+ else mp_flush_cur_exp(mp, -((-x+8)/ 16));
+ } else {
+ mp_bad_unary(mp, angle_op);
+ }
+ break;
+
+@ If the current expression is a pair, but the context wants it to
+be a path, we call |pair_to_path|.
+
+@<Declare unary action...@>=
+void mp_pair_to_path (MP mp) {
+ mp->cur_exp=mp_new_knot(mp);
+ mp->cur_type=mp_path_type;
+}
+
+@
+@d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
+ (has_color(link(dummy_loc(mp->cur_exp)))) &&
+ (color_model(link(dummy_loc(mp->cur_exp)))==A))
+
+@<Additional cases of unary operators@>=
+case x_part:
+case y_part:
+ if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
+ mp_take_part(mp, c);
+ else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
+ else mp_bad_unary(mp, c);
+ break;
+case xx_part:
+case xy_part:
+case yx_part:
+case yy_part:
+ if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
+ else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
+ else mp_bad_unary(mp, c);
+ break;
+case red_part:
+case green_part:
+case blue_part:
+ if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
+ else if ( mp->cur_type==mp_picture_type ) {
+ if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
+ else mp_bad_color_part(mp, c);
+ }
+ else mp_bad_unary(mp, c);
+ break;
+case cyan_part:
+case magenta_part:
+case yellow_part:
+case black_part:
+ if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
+ else if ( mp->cur_type==mp_picture_type ) {
+ if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
+ else mp_bad_color_part(mp, c);
+ }
+ else mp_bad_unary(mp, c);
+ break;
+case grey_part:
+ if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
+ else if ( mp->cur_type==mp_picture_type ) {
+ if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
+ else mp_bad_color_part(mp, c);
+ }
+ else mp_bad_unary(mp, c);
+ break;
+case color_model_part:
+ if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
+ else mp_bad_unary(mp, c);
+ break;
+
+@ @<Declarations@>=
+void mp_bad_color_part(MP mp, quarterword c);
+
+@ @c
+void mp_bad_color_part(MP mp, quarterword c) {
+ pointer p; /* the big node */
+ p=link(dummy_loc(mp->cur_exp));
+ exp_err("Wrong picture color model: "); mp_print_op(mp, c);
+@.Wrong picture color model...@>
+ if (color_model(p)==mp_grey_model)
+ mp_print(mp, " of grey object");
+ else if (color_model(p)==mp_cmyk_model)
+ mp_print(mp, " of cmyk object");
+ else if (color_model(p)==mp_rgb_model)
+ mp_print(mp, " of rgb object");
+ else if (color_model(p)==mp_no_model)
+ mp_print(mp, " of marking object");
+ else
+ mp_print(mp," of defaulted object");
+ help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
+ ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
+ ("or the greypart of a grey object. No mixing and matching, please.");
+ mp_error(mp);
+ if (c==black_part)
+ mp_flush_cur_exp(mp,unity);
+ else
+ mp_flush_cur_exp(mp,0);
+}
+
+@ In the following procedure, |cur_exp| points to a capsule, which points to
+a big node. We want to delete all but one part of the big node.
+
+@<Declare unary action...@>=
+void mp_take_part (MP mp,quarterword c) {
+ pointer p; /* the big node */
+ p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
+ link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
+ mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
+ mp_recycle_value(mp, temp_val);
+}
+
+@ @<Initialize table entries...@>=
+name_type(temp_val)=mp_capsule;
+
+@ @<Additional cases of unary operators@>=
+case font_part:
+case text_part:
+case path_part:
+case pen_part:
+case dash_part:
+ if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
+ else mp_bad_unary(mp, c);
+ break;
+
+@ @<Declarations@>=
+void mp_scale_edges (MP mp);
+
+@ @<Declare unary action...@>=
+void mp_take_pict_part (MP mp,quarterword c) {
+ pointer p; /* first graphical object in |cur_exp| */
+ p=link(dummy_loc(mp->cur_exp));
+ if ( p!=null ) {
+ switch (c) {
+ case x_part: case y_part: case xx_part:
+ case xy_part: case yx_part: case yy_part:
+ if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
+ else goto NOT_FOUND;
+ break;
+ case red_part: case green_part: case blue_part:
+ if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
+ else goto NOT_FOUND;
+ break;
+ case cyan_part: case magenta_part: case yellow_part:
+ case black_part:
+ if ( has_color(p) ) {
+ if ( color_model(p)==mp_uninitialized_model )
+ mp_flush_cur_exp(mp, unity);
+ else
+ mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
+ } else goto NOT_FOUND;
+ break;
+ case grey_part:
+ if ( has_color(p) )
+ mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
+ else goto NOT_FOUND;
+ break;
+ case color_model_part:
+ if ( has_color(p) ) {
+ if ( color_model(p)==mp_uninitialized_model )
+ mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
+ else
+ mp_flush_cur_exp(mp, color_model(p)*unity);
+ } else goto NOT_FOUND;
+ break;
+ @<Handle other cases in |take_pict_part| or |goto not_found|@>;
+ } /* all cases have been enumerated */
+ return;
+ };
+NOT_FOUND:
+ @<Convert the current expression to a null value appropriate
+ for |c|@>;
+}
+
+@ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
+case text_part:
+ if ( type(p)!=mp_text_code ) goto NOT_FOUND;
+ else {
+ mp_flush_cur_exp(mp, text_p(p));
+ add_str_ref(mp->cur_exp);
+ mp->cur_type=mp_string_type;
+ };
+ break;
+case font_part:
+ if ( type(p)!=mp_text_code ) goto NOT_FOUND;
+ else {
+ mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
+ add_str_ref(mp->cur_exp);
+ mp->cur_type=mp_string_type;
+ };
+ break;
+case path_part:
+ if ( type(p)==mp_text_code ) goto NOT_FOUND;
+ else if ( is_stop(p) ) mp_confusion(mp, "pict");
+@:this can't happen pict}{\quad pict@>
+ else {
+ mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
+ mp->cur_type=mp_path_type;
+ }
+ break;
+case pen_part:
+ if ( ! has_pen(p) ) goto NOT_FOUND;
+ else {
+ if ( pen_p(p)==null ) goto NOT_FOUND;
+ else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
+ mp->cur_type=mp_pen_type;
+ };
+ }
+ break;
+case dash_part:
+ if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
+ else { if ( dash_p(p)==null ) goto NOT_FOUND;
+ else { add_edge_ref(dash_p(p));
+ mp->se_sf=dash_scale(p);
+ mp->se_pic=dash_p(p);
+ mp_scale_edges(mp);
+ mp_flush_cur_exp(mp, mp->se_pic);
+ mp->cur_type=mp_picture_type;
+ };
+ }
+ break;
+
+@ Since |scale_edges| had to be declared |forward|, it had to be declared as a
+parameterless procedure even though it really takes two arguments and updates
+one of them. Hence the following globals are needed.
+
+@<Global...@>=
+pointer se_pic; /* edge header used and updated by |scale_edges| */
+scaled se_sf; /* the scale factor argument to |scale_edges| */
+
+@ @<Convert the current expression to a null value appropriate...@>=
+switch (c) {
+case text_part: case font_part:
+ mp_flush_cur_exp(mp, rts(""));
+ mp->cur_type=mp_string_type;
+ break;
+case path_part:
+ mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
+ left_type(mp->cur_exp)=mp_endpoint;
+ right_type(mp->cur_exp)=mp_endpoint;
+ link(mp->cur_exp)=mp->cur_exp;
+ x_coord(mp->cur_exp)=0;
+ y_coord(mp->cur_exp)=0;
+ originator(mp->cur_exp)=mp_metapost_user;
+ mp->cur_type=mp_path_type;
+ break;
+case pen_part:
+ mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
+ mp->cur_type=mp_pen_type;
+ break;
+case dash_part:
+ mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
+ mp_init_edges(mp, mp->cur_exp);
+ mp->cur_type=mp_picture_type;
+ break;
+default:
+ mp_flush_cur_exp(mp, 0);
+ break;
+}
+
+@ @<Additional cases of unary...@>=
+case char_op:
+ if ( mp->cur_type!=mp_known ) {
+ mp_bad_unary(mp, char_op);
+ } else {
+ mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
+ mp->cur_type=mp_string_type;
+ if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
+ }
+ break;
+case decimal:
+ if ( mp->cur_type!=mp_known ) {
+ mp_bad_unary(mp, decimal);
+ } else {
+ mp->old_setting=mp->selector; mp->selector=new_string;
+ mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
+ mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
+ }
+ break;
+case oct_op:
+case hex_op:
+case ASCII_op:
+ if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
+ else mp_str_to_num(mp, c);
+ break;
+case font_size:
+ if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
+ else @<Find the design size of the font whose name is |cur_exp|@>;
+ break;
+
+@ @<Declare unary action...@>=
+void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
+ integer n; /* accumulator */
+ ASCII_code m; /* current character */
+ pool_pointer k; /* index into |str_pool| */
+ int b; /* radix of conversion */
+ boolean bad_char; /* did the string contain an invalid digit? */
+ if ( c==ASCII_op ) {
+ if ( length(mp->cur_exp)==0 ) n=-1;
+ else n=mp->str_pool[mp->str_start[mp->cur_exp]];
+ } else {
+ if ( c==oct_op ) b=8; else b=16;
+ n=0; bad_char=false;
+ for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
+ m=mp->str_pool[k];
+ if ( (m>='0')&&(m<='9') ) m=m-'0';
+ else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
+ else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
+ else { bad_char=true; m=0; };
+ if ( m>=b ) { bad_char=true; m=0; };
+ if ( n<32768 / b ) n=n*b+m; else n=32767;
+ }
+ @<Give error messages if |bad_char| or |n>=4096|@>;
+ }
+ mp_flush_cur_exp(mp, n*unity);
+}
+
+@ @<Give error messages if |bad_char|...@>=
+if ( bad_char ) {
+ exp_err("String contains illegal digits");
+@.String contains illegal digits@>
+ if ( c==oct_op ) {
+ help1("I zeroed out characters that weren't in the range 0..7.");
+ } else {
+ help1("I zeroed out characters that weren't hex digits.");
+ }
+ mp_put_get_error(mp);
+}
+if ( (n>4095) ) {
+ if ( mp->internal[mp_warning_check]>0 ) {
+ print_err("Number too large (");
+ mp_print_int(mp, n); mp_print_char(mp, ')');
+@.Number too large@>
+ help2("I have trouble with numbers greater than 4095; watch out.")
+ ("(Set warningcheck:=0 to suppress this message.)");
+ mp_put_get_error(mp);
+ }
+}
+
+@ The length operation is somewhat unusual in that it applies to a variety
+of different types of operands.
+
+@<Additional cases of unary...@>=
+case length_op:
+ switch (mp->cur_type) {
+ case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
+ case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
+ case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
+ case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
+ default:
+ if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
+ mp_flush_cur_exp(mp, mp_pyth_add(mp,
+ value(x_part_loc(value(mp->cur_exp))),
+ value(y_part_loc(value(mp->cur_exp)))));
+ else mp_bad_unary(mp, c);
+ break;
+ }
+ break;
+
+@ @<Declare unary action...@>=
+scaled mp_path_length (MP mp) { /* computes the length of the current path */
+ scaled n; /* the path length so far */
+ pointer p; /* traverser */
+ p=mp->cur_exp;
+ if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
+ do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
+ return n;
+}
+
+@ @<Declare unary action...@>=
+scaled mp_pict_length (MP mp) {
+ /* counts interior components in picture |cur_exp| */
+ scaled n; /* the count so far */
+ pointer p; /* traverser */
+ n=0;
+ p=link(dummy_loc(mp->cur_exp));
+ if ( p!=null ) {
+ if ( is_start_or_stop(p) )
+ if ( mp_skip_1component(mp, p)==null ) p=link(p);
+ while ( p!=null ) {
+ skip_component(p) return n;
+ n=n+unity;
+ }
+ }
+ return n;
+}
+
+@ Implement |turningnumber|
+
+@<Additional cases of unary...@>=
+case turning_op:
+ if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
+ else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
+ else if ( left_type(mp->cur_exp)==mp_endpoint )
+ mp_flush_cur_exp(mp, 0); /* not a cyclic path */
+ else
+ mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
+ break;
+
+@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
+argument is |origin|.
+
+@<Declare unary action...@>=
+angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
+ if ( (! ((xpar==0) && (ypar==0))) )
+ return mp_n_arg(mp, xpar,ypar);
+ return 0;
+}
+
+
+@ The actual turning number is (for the moment) computed in a C function
+that receives eight integers corresponding to the four controlling points,
+and returns a single angle. Besides those, we have to account for discrete
+moves at the actual points.
+
+@d floor(a) (a>=0 ? a : -(int)(-a))
+@d bezier_error (720<<20)+1
+@d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
+@d print_roots(a)
+@d out ((double)(xo>>20))
+@d mid ((double)(xm>>20))
+@d in ((double)(xi>>20))
+@d divisor (256*256)
+@d double2angle(a) (int)floor(a*256.0*256.0*16.0)
+
+@<Declare unary action...@>=
+angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
+ integer CX,integer CY,integer DX,integer DY);
+
+@ @c
+angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
+ integer CX,integer CY,integer DX,integer DY) {
+ double a, b, c;
+ integer deltax,deltay;
+ double ax,ay,bx,by,cx,cy,dx,dy;
+ angle xi = 0, xo = 0, xm = 0;
+ double res = 0;
+ ax=AX/divisor; ay=AY/divisor;
+ bx=BX/divisor; by=BY/divisor;
+ cx=CX/divisor; cy=CY/divisor;
+ dx=DX/divisor; dy=DY/divisor;
+
+ deltax = (BX-AX); deltay = (BY-AY);
+ if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
+ if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
+ xi = mp_an_angle(mp,deltax,deltay);
+
+ deltax = (CX-BX); deltay = (CY-BY);
+ xm = mp_an_angle(mp,deltax,deltay);
+
+ deltax = (DX-CX); deltay = (DY-CY);
+ if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
+ if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
+ xo = mp_an_angle(mp,deltax,deltay);
+
+ a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
+ b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
+ c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
+
+ if ((a==0)&&(c==0)) {
+ res = (b==0 ? 0 : (out-in));
+ print_roots("no roots (a)");
+ } else if ((a==0)||(c==0)) {
+ if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
+ res = out-in; /* ? */
+ if (res<-180.0)
+ res += 360.0;
+ else if (res>180.0)
+ res -= 360.0;
+ print_roots("no roots (b)");
+ } else {
+ res = out-in; /* ? */
+ print_roots("one root (a)");
+ }
+ } else if ((sign(a)*sign(c))<0) {
+ res = out-in; /* ? */
+ if (res<-180.0)
+ res += 360.0;
+ else if (res>180.0)
+ res -= 360.0;
+ print_roots("one root (b)");
+ } else {
+ if (sign(a) == sign(b)) {
+ res = out-in; /* ? */
+ if (res<-180.0)
+ res += 360.0;
+ else if (res>180.0)
+ res -= 360.0;
+ print_roots("no roots (d)");
+ } else {
+ if ((b*b) == (4*a*c)) {
+ res = bezier_error;
+ print_roots("double root"); /* cusp */
+ } else if ((b*b) < (4*a*c)) {
+ res = out-in; /* ? */
+ if (res<=0.0 &&res>-180.0)
+ res += 360.0;
+ else if (res>=0.0 && res<180.0)
+ res -= 360.0;
+ print_roots("no roots (e)");
+ } else {
+ res = out-in;
+ if (res<-180.0)
+ res += 360.0;
+ else if (res>180.0)
+ res -= 360.0;
+ print_roots("two roots"); /* two inflections */
+ }
+ }
+ }
+ return double2angle(res);
+}
+
+@
+@d p_nextnext link(link(p))
+@d p_next link(p)
+@d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
+
+@<Declare unary action...@>=
+scaled mp_new_turn_cycles (MP mp,pointer c) {
+ angle res,ang; /* the angles of intermediate results */
+ scaled turns; /* the turn counter */
+ pointer p; /* for running around the path */
+ integer xp,yp; /* coordinates of next point */
+ integer x,y; /* helper coordinates */
+ angle in_angle,out_angle; /* helper angles */
+ int old_setting; /* saved |selector| setting */
+ res=0;
+ turns= 0;
+ p=c;
+ old_setting = mp->selector; mp->selector=term_only;
+ if ( mp->internal[mp_tracing_commands]>unity ) {
+ mp_begin_diagnostic(mp);
+ mp_print_nl(mp, "");
+ mp_end_diagnostic(mp, false);
+ }
+ do {
+ xp = x_coord(p_next); yp = y_coord(p_next);
+ ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
+ left_x(p_next), left_y(p_next), xp, yp);
+ if ( ang>seven_twenty_deg ) {
+ print_err("Strange path");
+ mp_error(mp);
+ mp->selector=old_setting;
+ return 0;
+ }
+ res = res + ang;
+ if ( res > one_eighty_deg ) {
+ res = res - three_sixty_deg;
+ turns = turns + unity;
+ }
+ if ( res <= -one_eighty_deg ) {
+ res = res + three_sixty_deg;
+ turns = turns - unity;
+ }
+ /* incoming angle at next point */
+ x = left_x(p_next); y = left_y(p_next);
+ if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
+ if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
+ in_angle = mp_an_angle(mp, xp - x, yp - y);
+ /* outgoing angle at next point */
+ x = right_x(p_next); y = right_y(p_next);
+ if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
+ if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
+ out_angle = mp_an_angle(mp, x - xp, y- yp);
+ ang = (out_angle - in_angle);
+ reduce_angle(ang);
+ if ( ang!=0 ) {
+ res = res + ang;
+ if ( res >= one_eighty_deg ) {
+ res = res - three_sixty_deg;
+ turns = turns + unity;
+ };
+ if ( res <= -one_eighty_deg ) {
+ res = res + three_sixty_deg;
+ turns = turns - unity;
+ };
+ };
+ p = link(p);
+ } while (p!=c);
+ mp->selector=old_setting;
+ return turns;
+}
+
+
+@ This code is based on Bogus\l{}av Jackowski's
+|emergency_turningnumber| macro, with some minor changes by Taco
+Hoekwater. The macro code looked more like this:
+{\obeylines
+vardef turning\_number primary p =
+~~save res, ang, turns;
+~~res := 0;
+~~if length p <= 2:
+~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
+~~else:
+~~~~for t = 0 upto length p-1 :
+~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
+~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
+~~~~~~if angc > 180: angc := angc - 360; fi;
+~~~~~~if angc < -180: angc := angc + 360; fi;
+~~~~~~res := res + angc;
+~~~~endfor;
+~~res/360
+~~fi
+enddef;}
+The general idea is to calculate only the sum of the angles of
+straight lines between the points, of a path, not worrying about cusps
+or self-intersections in the segments at all. If the segment is not
+well-behaved, the result is not necesarily correct. But the old code
+was not always correct either, and worse, it sometimes failed for
+well-behaved paths as well. All known bugs that were triggered by the
+original code no longer occur with this code, and it runs roughly 3
+times as fast because the algorithm is much simpler.
+
+@ It is possible to overflow the return value of the |turn_cycles|
+function when the path is sufficiently long and winding, but I am not
+going to bother testing for that. In any case, it would only return
+the looped result value, which is not a big problem.
+
+The macro code for the repeat loop was a bit nicer to look
+at than the pascal code, because it could use |point -1 of p|. In
+pascal, the fastest way to loop around the path is not to look
+backward once, but forward twice. These defines help hide the trick.
+
+@d p_to link(link(p))
+@d p_here link(p)
+@d p_from p
+
+@<Declare unary action...@>=
+scaled mp_turn_cycles (MP mp,pointer c) {
+ angle res,ang; /* the angles of intermediate results */
+ scaled turns; /* the turn counter */
+ pointer p; /* for running around the path */
+ res=0; turns= 0; p=c;
+ do {
+ ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
+ y_coord(p_to) - y_coord(p_here))
+ - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
+ y_coord(p_here) - y_coord(p_from));
+ reduce_angle(ang);
+ res = res + ang;
+ if ( res >= three_sixty_deg ) {
+ res = res - three_sixty_deg;
+ turns = turns + unity;
+ };
+ if ( res <= -three_sixty_deg ) {
+ res = res + three_sixty_deg;
+ turns = turns - unity;
+ };
+ p = link(p);
+ } while (p!=c);
+ return turns;
+}
+
+@ @<Declare unary action...@>=
+scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
+ scaled nval,oval;
+ scaled saved_t_o; /* tracing\_online saved */
+ if ( (link(c)==c)||(link(link(c))==c) ) {
+ if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
+ return unity;
+ else
+ return -unity;
+ } else {
+ nval = mp_new_turn_cycles(mp, c);
+ oval = mp_turn_cycles(mp, c);
+ if ( nval!=oval ) {
+ saved_t_o=mp->internal[mp_tracing_online];
+ mp->internal[mp_tracing_online]=unity;
+ mp_begin_diagnostic(mp);
+ mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
+ " The current computed value is ");
+ mp_print_scaled(mp, nval);
+ mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
+ mp_print_scaled(mp, oval);
+ mp_end_diagnostic(mp, false);
+ mp->internal[mp_tracing_online]=saved_t_o;
+ }
+ return nval;
+ }
+}
+
+@ @<Declare unary action...@>=
+scaled mp_count_turns (MP mp,pointer c) {
+ pointer p; /* a knot in envelope spec |c| */
+ integer t; /* total pen offset changes counted */
+ t=0; p=c;
+ do {
+ t=t+info(p)-zero_off;
+ p=link(p);
+ } while (p!=c);
+ return ((t / 3)*unity);
+}
+
+@ @d type_range(A,B) {
+ if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
+ mp_flush_cur_exp(mp, true_code);
+ else mp_flush_cur_exp(mp, false_code);
+ mp->cur_type=mp_boolean_type;
+ }
+@d type_test(A) {
+ if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
+ else mp_flush_cur_exp(mp, false_code);
+ mp->cur_type=mp_boolean_type;
+ }
+
+@<Additional cases of unary operators@>=
+case mp_boolean_type:
+ type_range(mp_boolean_type,mp_unknown_boolean); break;
+case mp_string_type:
+ type_range(mp_string_type,mp_unknown_string); break;
+case mp_pen_type:
+ type_range(mp_pen_type,mp_unknown_pen); break;
+case mp_path_type:
+ type_range(mp_path_type,mp_unknown_path); break;
+case mp_picture_type:
+ type_range(mp_picture_type,mp_unknown_picture); break;
+case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
+case mp_pair_type:
+ type_test(c); break;
+case mp_numeric_type:
+ type_range(mp_known,mp_independent); break;
+case known_op: case unknown_op:
+ mp_test_known(mp, c); break;
+
+@ @<Declare unary action procedures@>=
+void mp_test_known (MP mp,quarterword c) {
+ int b; /* is the current expression known? */
+ pointer p,q; /* locations in a big node */
+ b=false_code;
+ switch (mp->cur_type) {
+ case mp_vacuous: case mp_boolean_type: case mp_string_type:
+ case mp_pen_type: case mp_path_type: case mp_picture_type:
+ case mp_known:
+ b=true_code;
+ break;
+ case mp_transform_type:
+ case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
+ p=value(mp->cur_exp);
+ q=p+mp->big_node_size[mp->cur_type];
+ do {
+ q=q-2;
+ if ( type(q)!=mp_known )
+ goto DONE;
+ } while (q!=p);
+ b=true_code;
+ DONE:
+ break;
+ default:
+ break;
+ }
+ if ( c==known_op ) mp_flush_cur_exp(mp, b);
+ else mp_flush_cur_exp(mp, true_code+false_code-b);
+ mp->cur_type=mp_boolean_type;
+}
+
+@ @<Additional cases of unary operators@>=
+case cycle_op:
+ if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
+ else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
+ else mp_flush_cur_exp(mp, false_code);
+ mp->cur_type=mp_boolean_type;
+ break;
+
+@ @<Additional cases of unary operators@>=
+case arc_length:
+ if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
+ else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
+ break;
+
+@ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
+object |type|.
+@^data structure assumptions@>
+
+@<Additional cases of unary operators@>=
+case filled_op:
+case stroked_op:
+case textual_op:
+case clipped_op:
+case bounded_op:
+ if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
+ else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
+ else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
+ mp_flush_cur_exp(mp, true_code);
+ else mp_flush_cur_exp(mp, false_code);
+ mp->cur_type=mp_boolean_type;
+ break;
+
+@ @<Additional cases of unary operators@>=
+case make_pen_op:
+ if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
+ else {
+ mp->cur_type=mp_pen_type;
+ mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
+ };
+ break;
+case make_path_op:
+ if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
+ else {
+ mp->cur_type=mp_path_type;
+ mp_make_path(mp, mp->cur_exp);
+ };
+ break;
+case reverse:
+ if ( mp->cur_type==mp_path_type ) {
+ p=mp_htap_ypoc(mp, mp->cur_exp);
+ if ( right_type(p)==mp_endpoint ) p=link(p);
+ mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
+ } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ else mp_bad_unary(mp, reverse);
+ break;
+
+@ The |pair_value| routine changes the current expression to a
+given ordered pair of values.
+
+@<Declare unary action procedures@>=
+void mp_pair_value (MP mp,scaled x, scaled y) {
+ pointer p; /* a pair node */
+ p=mp_get_node(mp, value_node_size);
+ mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
+ type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
+ p=value(p);
+ type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
+ type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
+}
+
+@ @<Additional cases of unary operators@>=
+case ll_corner_op:
+ if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
+ else mp_pair_value(mp, minx,miny);
+ break;
+case lr_corner_op:
+ if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
+ else mp_pair_value(mp, maxx,miny);
+ break;
+case ul_corner_op:
+ if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
+ else mp_pair_value(mp, minx,maxy);
+ break;
+case ur_corner_op:
+ if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
+ else mp_pair_value(mp, maxx,maxy);
+ break;
+
+@ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
+box of the current expression. The boolean result is |false| if the expression
+has the wrong type.
+
+@<Declare unary action procedures@>=
+boolean mp_get_cur_bbox (MP mp) {
+ switch (mp->cur_type) {
+ case mp_picture_type:
+ mp_set_bbox(mp, mp->cur_exp,true);
+ if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
+ minx=0; maxx=0; miny=0; maxy=0;
+ } else {
+ minx=minx_val(mp->cur_exp);
+ maxx=maxx_val(mp->cur_exp);
+ miny=miny_val(mp->cur_exp);
+ maxy=maxy_val(mp->cur_exp);
+ }
+ break;
+ case mp_path_type:
+ mp_path_bbox(mp, mp->cur_exp);
+ break;
+ case mp_pen_type:
+ mp_pen_bbox(mp, mp->cur_exp);
+ break;
+ default:
+ return false;
+ }
+ return true;
+}
+
+@ @<Additional cases of unary operators@>=
+case read_from_op:
+case close_from_op:
+ if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
+ else mp_do_read_or_close(mp,c);
+ break;
+
+@ Here is a routine that interprets |cur_exp| as a file name and tries to read
+a line from the file or to close the file.
+
+@<Declare unary action procedures@>=
+void mp_do_read_or_close (MP mp,quarterword c) {
+ readf_index n,n0; /* indices for searching |rd_fname| */
+ @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
+ call |start_read_input| and |goto found| or |not_found|@>;
+ mp_begin_file_reading(mp);
+ name=is_read;
+ if ( mp_input_ln(mp, mp->rd_file[n] ) )
+ goto FOUND;
+ mp_end_file_reading(mp);
+NOT_FOUND:
+ @<Record the end of file and set |cur_exp| to a dummy value@>;
+ return;
+CLOSE_FILE:
+ mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
+ return;
+FOUND:
+ mp_flush_cur_exp(mp, 0);
+ mp_finish_read(mp);
+}
+
+@ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
+|rd_fname|.
+
+@<Find the |n| where |rd_fname[n]=cur_exp|...@>=
+{
+ char *fn;
+ n=mp->read_files;
+ n0=mp->read_files;
+ fn = str(mp->cur_exp);
+ while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
+ if ( n>0 ) {
+ decr(n);
+ } else if ( c==close_from_op ) {
+ goto CLOSE_FILE;
+ } else {
+ if ( n0==mp->read_files ) {
+ if ( mp->read_files<mp->max_read_files ) {
+ incr(mp->read_files);
+ } else {
+ void **rd_file;
+ char **rd_fname;
+ readf_index l,k;
+ l = mp->max_read_files + (mp->max_read_files>>2);
+ rd_file = xmalloc((l+1), sizeof(void *));
+ rd_fname = xmalloc((l+1), sizeof(char *));
+ for (k=0;k<=l;k++) {
+ if (k<=mp->max_read_files) {
+ rd_file[k]=mp->rd_file[k];
+ rd_fname[k]=mp->rd_fname[k];
+ } else {
+ rd_file[k]=0;
+ rd_fname[k]=NULL;
+ }
+ }
+ xfree(mp->rd_file); xfree(mp->rd_fname);
+ mp->max_read_files = l;
+ mp->rd_file = rd_file;
+ mp->rd_fname = rd_fname;
+ }
+ }
+ n=n0;
+ if ( mp_start_read_input(mp,fn,n) )
+ goto FOUND;
+ else
+ goto NOT_FOUND;
+ }
+ if ( mp->rd_fname[n]==NULL ) { n0=n; }
+ }
+ if ( c==close_from_op ) {
+ (mp->close_file)(mp,mp->rd_file[n]);
+ goto NOT_FOUND;
+ }
+}
+
+@ @<Record the end of file and set |cur_exp| to a dummy value@>=
+xfree(mp->rd_fname[n]);
+mp->rd_fname[n]=NULL;
+if ( n==mp->read_files-1 ) mp->read_files=n;
+if ( c==close_from_op )
+ goto CLOSE_FILE;
+mp_flush_cur_exp(mp, mp->eof_line);
+mp->cur_type=mp_string_type
+
+@ The string denoting end-of-file is a one-byte string at position zero, by definition
+
+@<Glob...@>=
+str_number eof_line;
+
+@ @<Set init...@>=
+mp->eof_line=0;
+
+@ Finally, we have the operations that combine a capsule~|p|
+with the current expression.
+
+@d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
+
+@c @<Declare binary action procedures@>
+void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
+ check_arith;
+ @<Recycle any sidestepped |independent| capsules@>;
+}
+void mp_do_binary (MP mp,pointer p, quarterword c) {
+ pointer q,r,rr; /* for list manipulation */
+ pointer old_p,old_exp; /* capsules to recycle */
+ integer v; /* for numeric manipulation */
+ check_arith;
+ if ( mp->internal[mp_tracing_commands]>two ) {
+ @<Trace the current binary operation@>;
+ }
+ @<Sidestep |independent| cases in capsule |p|@>;
+ @<Sidestep |independent| cases in the current expression@>;
+ switch (c) {
+ case plus: case minus:
+ @<Add or subtract the current expression from |p|@>;
+ break;
+ @<Additional cases of binary operators@>;
+ }; /* there are no other cases */
+ mp_recycle_value(mp, p);
+ mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
+ mp_finish_binary(mp, old_p, old_exp);
+}
+
+@ @<Declare binary action...@>=
+void mp_bad_binary (MP mp,pointer p, quarterword c) {
+ mp_disp_err(mp, p,"");
+ exp_err("Not implemented: ");
+@.Not implemented...@>
+ if ( c>=min_of ) mp_print_op(mp, c);
+ mp_print_known_or_unknown_type(mp, type(p),p);
+ if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
+ mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
+ help3("I'm afraid I don't know how to apply that operation to that")
+ ("combination of types. Continue, and I'll return the second")
+ ("argument (see above) as the result of the operation.");
+ mp_put_get_error(mp);
+}
+void mp_bad_envelope_pen (MP mp) {
+ mp_disp_err(mp, null,"");
+ exp_err("Not implemented: envelope(elliptical pen)of(path)");
+@.Not implemented...@>
+ help3("I'm afraid I don't know how to apply that operation to that")
+ ("combination of types. Continue, and I'll return the second")
+ ("argument (see above) as the result of the operation.");
+ mp_put_get_error(mp);
+}
+
+@ @<Trace the current binary operation@>=
+{
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
+ mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
+ mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
+ mp_print_exp(mp,null,0); mp_print(mp,")}");
+ mp_end_diagnostic(mp, false);
+}
+
+@ Several of the binary operations are potentially complicated by the
+fact that |independent| values can sneak into capsules. For example,
+we've seen an instance of this difficulty in the unary operation
+of negation. In order to reduce the number of cases that need to be
+handled, we first change the two operands (if necessary)
+to rid them of |independent| components. The original operands are
+put into capsules called |old_p| and |old_exp|, which will be
+recycled after the binary operation has been safely carried out.
+
+@<Recycle any sidestepped |independent| capsules@>=
+if ( old_p!=null ) {
+ mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
+}
+if ( old_exp!=null ) {
+ mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
+}
+
+@ A big node is considered to be ``tarnished'' if it contains at least one
+independent component. We will define a simple function called `|tarnished|'
+that returns |null| if and only if its argument is not tarnished.
+
+@<Sidestep |independent| cases in capsule |p|@>=
+switch (type(p)) {
+case mp_transform_type:
+case mp_color_type:
+case mp_cmykcolor_type:
+case mp_pair_type:
+ old_p=mp_tarnished(mp, p);
+ break;
+case mp_independent: old_p=mp_void; break;
+default: old_p=null; break;
+}
+if ( old_p!=null ) {
+ q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
+ p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
+}
+
+@ @<Sidestep |independent| cases in the current expression@>=
+switch (mp->cur_type) {
+case mp_transform_type:
+case mp_color_type:
+case mp_cmykcolor_type:
+case mp_pair_type:
+ old_exp=mp_tarnished(mp, mp->cur_exp);
+ break;
+case mp_independent:old_exp=mp_void; break;
+default: old_exp=null; break;
+}
+if ( old_exp!=null ) {
+ old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
+}
+
+@ @<Declare binary action...@>=
+pointer mp_tarnished (MP mp,pointer p) {
+ pointer q; /* beginning of the big node */
+ pointer r; /* current position in the big node */
+ q=value(p); r=q+mp->big_node_size[type(p)];
+ do {
+ r=r-2;
+ if ( type(r)==mp_independent ) return mp_void;
+ } while (r!=q);
+ return null;
+}
+
+@ @<Add or subtract the current expression from |p|@>=
+if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
+ mp_bad_binary(mp, p,c);
+} else {
+ if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
+ mp_add_or_subtract(mp, p,null,c);
+ } else {
+ if ( mp->cur_type!=type(p) ) {
+ mp_bad_binary(mp, p,c);
+ } else {
+ q=value(p); r=value(mp->cur_exp);
+ rr=r+mp->big_node_size[mp->cur_type];
+ while ( r<rr ) {
+ mp_add_or_subtract(mp, q,r,c);
+ q=q+2; r=r+2;
+ }
+ }
+ }
+}
+
+@ The first argument to |add_or_subtract| is the location of a value node
+in a capsule or pair node that will soon be recycled. The second argument
+is either a location within a pair or transform node of |cur_exp|,
+or it is null (which means that |cur_exp| itself should be the second
+argument). The third argument is either |plus| or |minus|.
+
+The sum or difference of the numeric quantities will replace the second
+operand. Arithmetic overflow may go undetected; users aren't supposed to
+be monkeying around with really big values.
+@^overflow in arithmetic@>
+
+@<Declare binary action...@>=
+@<Declare the procedure called |dep_finish|@>
+void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
+ small_number s,t; /* operand types */
+ pointer r; /* list traverser */
+ integer v; /* second operand value */
+ if ( q==null ) {
+ t=mp->cur_type;
+ if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
+ } else {
+ t=type(q);
+ if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
+ }
+ if ( t==mp_known ) {
+ if ( c==minus ) negate(v);
+ if ( type(p)==mp_known ) {
+ v=mp_slow_add(mp, value(p),v);
+ if ( q==null ) mp->cur_exp=v; else value(q)=v;
+ return;
+ }
+ @<Add a known value to the constant term of |dep_list(p)|@>;
+ } else {
+ if ( c==minus ) mp_negate_dep_list(mp, v);
+ @<Add operand |p| to the dependency list |v|@>;
+ }
+}
+
+@ @<Add a known value to the constant term of |dep_list(p)|@>=
+r=dep_list(p);
+while ( info(r)!=null ) r=link(r);
+value(r)=mp_slow_add(mp, value(r),v);
+if ( q==null ) {
+ q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
+ name_type(q)=mp_capsule;
+}
+dep_list(q)=dep_list(p); type(q)=type(p);
+prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
+type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
+
+@ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
+nice to retain the extra accuracy of |fraction| coefficients.
+But we have to handle both kinds, and mixtures too.
+
+@<Add operand |p| to the dependency list |v|@>=
+if ( type(p)==mp_known ) {
+ @<Add the known |value(p)| to the constant term of |v|@>;
+} else {
+ s=type(p); r=dep_list(p);
+ if ( t==mp_dependent ) {
+ if ( s==mp_dependent ) {
+ if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
+ v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
+ } /* |fix_needed| will necessarily be false */
+ t=mp_proto_dependent;
+ v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
+ }
+ if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
+ else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
+ DONE:
+ @<Output the answer, |v| (which might have become |known|)@>;
+ }
+
+@ @<Add the known |value(p)| to the constant term of |v|@>=
+{
+ while ( info(v)!=null ) v=link(v);
+ value(v)=mp_slow_add(mp, value(p),value(v));
+}
+
+@ @<Output the answer, |v| (which might have become |known|)@>=
+if ( q!=null ) mp_dep_finish(mp, v,q,t);
+else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
+
+@ Here's the current situation: The dependency list |v| of type |t|
+should either be put into the current expression (if |q=null|) or
+into location |q| within a pair node (otherwise). The destination (|cur_exp|
+or |q|) formerly held a dependency list with the same
+final pointer as the list |v|.
+
+@<Declare the procedure called |dep_finish|@>=
+void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
+ pointer p; /* the destination */
+ scaled vv; /* the value, if it is |known| */
+ if ( q==null ) p=mp->cur_exp; else p=q;
+ dep_list(p)=v; type(p)=t;
+ if ( info(v)==null ) {
+ vv=value(v);
+ if ( q==null ) {
+ mp_flush_cur_exp(mp, vv);
+ } else {
+ mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
+ }
+ } else if ( q==null ) {
+ mp->cur_type=t;
+ }
+ if ( mp->fix_needed ) mp_fix_dependencies(mp);
+}
+
+@ Let's turn now to the six basic relations of comparison.
+
+@<Additional cases of binary operators@>=
+case less_than: case less_or_equal: case greater_than:
+case greater_or_equal: case equal_to: case unequal_to:
+ check_arith; /* at this point |arith_error| should be |false|? */
+ if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
+ mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
+ } else if ( mp->cur_type!=type(p) ) {
+ mp_bad_binary(mp, p,c); goto DONE;
+ } else if ( mp->cur_type==mp_string_type ) {
+ mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
+ } else if ((mp->cur_type==mp_unknown_string)||
+ (mp->cur_type==mp_unknown_boolean) ) {
+ @<Check if unknowns have been equated@>;
+ } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
+ @<Reduce comparison of big nodes to comparison of scalars@>;
+ } else if ( mp->cur_type==mp_boolean_type ) {
+ mp_flush_cur_exp(mp, mp->cur_exp-value(p));
+ } else {
+ mp_bad_binary(mp, p,c); goto DONE;
+ }
+ @<Compare the current expression with zero@>;
+DONE:
+ mp->arith_error=false; /* ignore overflow in comparisons */
+ break;
+
+@ @<Compare the current expression with zero@>=
+if ( mp->cur_type!=mp_known ) {
+ if ( mp->cur_type<mp_known ) {
+ mp_disp_err(mp, p,"");
+ help1("The quantities shown above have not been equated.")
+ } else {
+ help2("Oh dear. I can\'t decide if the expression above is positive,")
+ ("negative, or zero. So this comparison test won't be `true'.");
+ }
+ exp_err("Unknown relation will be considered false");
+@.Unknown relation...@>
+ mp_put_get_flush_error(mp, false_code);
+} else {
+ switch (c) {
+ case less_than: boolean_reset(mp->cur_exp<0); break;
+ case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
+ case greater_than: boolean_reset(mp->cur_exp>0); break;
+ case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
+ case equal_to: boolean_reset(mp->cur_exp==0); break;
+ case unequal_to: boolean_reset(mp->cur_exp!=0); break;
+ }; /* there are no other cases */
+}
+mp->cur_type=mp_boolean_type
+
+@ When two unknown strings are in the same ring, we know that they are
+equal. Otherwise, we don't know whether they are equal or not, so we
+make no change.
+
+@<Check if unknowns have been equated@>=
+{
+ q=value(mp->cur_exp);
+ while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
+ if ( q==p ) mp_flush_cur_exp(mp, 0);
+}
+
+@ @<Reduce comparison of big nodes to comparison of scalars@>=
+{
+ q=value(p); r=value(mp->cur_exp);
+ rr=r+mp->big_node_size[mp->cur_type]-2;
+ while (1) { mp_add_or_subtract(mp, q,r,minus);
+ if ( type(r)!=mp_known ) break;
+ if ( value(r)!=0 ) break;
+ if ( r==rr ) break;
+ q=q+2; r=r+2;
+ }
+ mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
+}
+
+@ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
+
+@<Additional cases of binary operators@>=
+case and_op:
+case or_op:
+ if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
+ mp_bad_binary(mp, p,c);
+ else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
+ break;
+
+@ @<Additional cases of binary operators@>=
+case times:
+ if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
+ mp_bad_binary(mp, p,times);
+ } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
+ @<Multiply when at least one operand is known@>;
+ } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
+ ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
+ (type(p)>mp_pair_type)) ) {
+ mp_hard_times(mp, p);
+ binary_return;
+ } else {
+ mp_bad_binary(mp, p,times);
+ }
+ break;
+
+@ @<Multiply when at least one operand is known@>=
+{
+ if ( type(p)==mp_known ) {
+ v=value(p); mp_free_node(mp, p,value_node_size);
+ } else {
+ v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
+ }
+ if ( mp->cur_type==mp_known ) {
+ mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
+ } else if ( (mp->cur_type==mp_pair_type)||
+ (mp->cur_type==mp_color_type)||
+ (mp->cur_type==mp_cmykcolor_type) ) {
+ p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
+ do {
+ p=p-2; mp_dep_mult(mp, p,v,true);
+ } while (p!=value(mp->cur_exp));
+ } else {
+ mp_dep_mult(mp, null,v,true);
+ }
+ binary_return;
+}
+
+@ @<Declare binary action...@>=
+void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
+ pointer q; /* the dependency list being multiplied by |v| */
+ small_number s,t; /* its type, before and after */
+ if ( p==null ) {
+ q=mp->cur_exp;
+ } else if ( type(p)!=mp_known ) {
+ q=p;
+ } else {
+ if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
+ else value(p)=mp_take_fraction(mp, value(p),v);
+ return;
+ };
+ t=type(q); q=dep_list(q); s=t;
+ if ( t==mp_dependent ) if ( v_is_scaled )
+ if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
+ t=mp_proto_dependent;
+ q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
+ mp_dep_finish(mp, q,p,t);
+}
+
+@ Here is a routine that is similar to |times|; but it is invoked only
+internally, when |v| is a |fraction| whose magnitude is at most~1,
+and when |cur_type>=mp_color_type|.
+
+@c void mp_frac_mult (MP mp,scaled n, scaled d) {
+ /* multiplies |cur_exp| by |n/d| */
+ pointer p; /* a pair node */
+ pointer old_exp; /* a capsule to recycle */
+ fraction v; /* |n/d| */
+ if ( mp->internal[mp_tracing_commands]>two ) {
+ @<Trace the fraction multiplication@>;
+ }
+ switch (mp->cur_type) {
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ old_exp=mp_tarnished(mp, mp->cur_exp);
+ break;
+ case mp_independent: old_exp=mp_void; break;
+ default: old_exp=null; break;
+ }
+ if ( old_exp!=null ) {
+ old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
+ }
+ v=mp_make_fraction(mp, n,d);
+ if ( mp->cur_type==mp_known ) {
+ mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
+ } else if ( mp->cur_type<=mp_pair_type ) {
+ p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
+ do {
+ p=p-2;
+ mp_dep_mult(mp, p,v,false);
+ } while (p!=value(mp->cur_exp));
+ } else {
+ mp_dep_mult(mp, null,v,false);
+ }
+ if ( old_exp!=null ) {
+ mp_recycle_value(mp, old_exp);
+ mp_free_node(mp, old_exp,value_node_size);
+ }
+}
+
+@ @<Trace the fraction multiplication@>=
+{
+ mp_begin_diagnostic(mp);
+ mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
+ mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
+ mp_print(mp,")}");
+ mp_end_diagnostic(mp, false);
+}
+
+@ The |hard_times| routine multiplies a nice color or pair by a dependency list.
+
+@<Declare binary action procedures@>=
+void mp_hard_times (MP mp,pointer p) {
+ pointer q; /* a copy of the dependent variable |p| */
+ pointer r; /* a component of the big node for the nice color or pair */
+ scaled v; /* the known value for |r| */
+ if ( type(p)<=mp_pair_type ) {
+ q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
+ }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
+ r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
+ while (1) {
+ r=r-2;
+ v=value(r);
+ type(r)=type(p);
+ if ( r==value(mp->cur_exp) )
+ break;
+ mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
+ mp_dep_mult(mp, r,v,true);
+ }
+ mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
+ link(prev_dep(p))=r;
+ mp_free_node(mp, p,value_node_size);
+ mp_dep_mult(mp, r,v,true);
+}
+
+@ @<Additional cases of binary operators@>=
+case over:
+ if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
+ mp_bad_binary(mp, p,over);
+ } else {
+ v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
+ if ( v==0 ) {
+ @<Squeal about division by zero@>;
+ } else {
+ if ( mp->cur_type==mp_known ) {
+ mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
+ } else if ( mp->cur_type<=mp_pair_type ) {
+ p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
+ do {
+ p=p-2; mp_dep_div(mp, p,v);
+ } while (p!=value(mp->cur_exp));
+ } else {
+ mp_dep_div(mp, null,v);
+ }
+ }
+ binary_return;
+ }
+ break;
+
+@ @<Declare binary action...@>=
+void mp_dep_div (MP mp,pointer p, scaled v) {
+ pointer q; /* the dependency list being divided by |v| */
+ small_number s,t; /* its type, before and after */
+ if ( p==null ) q=mp->cur_exp;
+ else if ( type(p)!=mp_known ) q=p;
+ else { value(p)=mp_make_scaled(mp, value(p),v); return; };
+ t=type(q); q=dep_list(q); s=t;
+ if ( t==mp_dependent )
+ if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
+ t=mp_proto_dependent;
+ q=mp_p_over_v(mp, q,v,s,t);
+ mp_dep_finish(mp, q,p,t);
+}
+
+@ @<Squeal about division by zero@>=
+{
+ exp_err("Division by zero");
+@.Division by zero@>
+ help2("You're trying to divide the quantity shown above the error")
+ ("message by zero. I'm going to divide it by one instead.");
+ mp_put_get_error(mp);
+}
+
+@ @<Additional cases of binary operators@>=
+case pythag_add:
+case pythag_sub:
+ if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
+ if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
+ else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
+ } else mp_bad_binary(mp, p,c);
+ break;
+
+@ The next few sections of the program deal with affine transformations
+of coordinate data.
+
+@<Additional cases of binary operators@>=
+case rotated_by: case slanted_by:
+case scaled_by: case shifted_by: case transformed_by:
+case x_scaled: case y_scaled: case z_scaled:
+ if ( type(p)==mp_path_type ) {
+ path_trans(c,p); binary_return;
+ } else if ( type(p)==mp_pen_type ) {
+ pen_trans(c,p);
+ mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
+ /* rounding error could destroy convexity */
+ binary_return;
+ } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
+ mp_big_trans(mp, p,c);
+ } else if ( type(p)==mp_picture_type ) {
+ mp_do_edges_trans(mp, p,c); binary_return;
+ } else {
+ mp_bad_binary(mp, p,c);
+ }
+ break;
+
+@ Let |c| be one of the eight transform operators. The procedure call
+|set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
+|c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
+change at all if |c=transformed_by|.)
+
+Then, if all components of the resulting transform are |known|, they are
+moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
+and |cur_exp| is changed to the known value zero.
+
+@<Declare binary action...@>=
+void mp_set_up_trans (MP mp,quarterword c) {
+ pointer p,q,r; /* list manipulation registers */
+ if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
+ @<Put the current transform into |cur_exp|@>;
+ }
+ @<If the current transform is entirely known, stash it in global variables;
+ otherwise |return|@>;
+}
+
+@ @<Glob...@>=
+scaled txx;
+scaled txy;
+scaled tyx;
+scaled tyy;
+scaled tx;
+scaled ty; /* current transform coefficients */
+
+@ @<Put the current transform...@>=
+{
+ p=mp_stash_cur_exp(mp);
+ mp->cur_exp=mp_id_transform(mp);
+ mp->cur_type=mp_transform_type;
+ q=value(mp->cur_exp);
+ switch (c) {
+ @<For each of the eight cases, change the relevant fields of |cur_exp|
+ and |goto done|;
+ but do nothing if capsule |p| doesn't have the appropriate type@>;
+ }; /* there are no other cases */
+ mp_disp_err(mp, p,"Improper transformation argument");
+@.Improper transformation argument@>
+ help3("The expression shown above has the wrong type,")
+ ("so I can\'t transform anything using it.")
+ ("Proceed, and I'll omit the transformation.");
+ mp_put_get_error(mp);
+DONE:
+ mp_recycle_value(mp, p);
+ mp_free_node(mp, p,value_node_size);
+}
+
+@ @<If the current transform is entirely known, ...@>=
+q=value(mp->cur_exp); r=q+transform_node_size;
+do {
+ r=r-2;
+ if ( type(r)!=mp_known ) return;
+} while (r!=q);
+mp->txx=value(xx_part_loc(q));
+mp->txy=value(xy_part_loc(q));
+mp->tyx=value(yx_part_loc(q));
+mp->tyy=value(yy_part_loc(q));
+mp->tx=value(x_part_loc(q));
+mp->ty=value(y_part_loc(q));
+mp_flush_cur_exp(mp, 0)
+
+@ @<For each of the eight cases...@>=
+case rotated_by:
+ if ( type(p)==mp_known )
+ @<Install sines and cosines, then |goto done|@>;
+ break;
+case slanted_by:
+ if ( type(p)>mp_pair_type ) {
+ mp_install(mp, xy_part_loc(q),p); goto DONE;
+ };
+ break;
+case scaled_by:
+ if ( type(p)>mp_pair_type ) {
+ mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
+ goto DONE;
+ };
+ break;
+case shifted_by:
+ if ( type(p)==mp_pair_type ) {
+ r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
+ mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
+ };
+ break;
+case x_scaled:
+ if ( type(p)>mp_pair_type ) {
+ mp_install(mp, xx_part_loc(q),p); goto DONE;
+ };
+ break;
+case y_scaled:
+ if ( type(p)>mp_pair_type ) {
+ mp_install(mp, yy_part_loc(q),p); goto DONE;
+ };
+ break;
+case z_scaled:
+ if ( type(p)==mp_pair_type )
+ @<Install a complex multiplier, then |goto done|@>;
+ break;
+case transformed_by:
+ break;
+
+
+@ @<Install sines and cosines, then |goto done|@>=
+{ mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
+ value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
+ value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
+ value(xy_part_loc(q))=-value(yx_part_loc(q));
+ value(yy_part_loc(q))=value(xx_part_loc(q));
+ goto DONE;
+}
+
+@ @<Install a complex multiplier, then |goto done|@>=
+{
+ r=value(p);
+ mp_install(mp, xx_part_loc(q),x_part_loc(r));
+ mp_install(mp, yy_part_loc(q),x_part_loc(r));
+ mp_install(mp, yx_part_loc(q),y_part_loc(r));
+ if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
+ else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
+ mp_install(mp, xy_part_loc(q),y_part_loc(r));
+ goto DONE;
+}
+
+@ Procedure |set_up_known_trans| is like |set_up_trans|, but it
+insists that the transformation be entirely known.
+
+@<Declare binary action...@>=
+void mp_set_up_known_trans (MP mp,quarterword c) {
+ mp_set_up_trans(mp, c);
+ if ( mp->cur_type!=mp_known ) {
+ exp_err("Transform components aren't all known");
+@.Transform components...@>
+ help3("I'm unable to apply a partially specified transformation")
+ ("except to a fully known pair or transform.")
+ ("Proceed, and I'll omit the transformation.");
+ mp_put_get_flush_error(mp, 0);
+ mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
+ mp->tx=0; mp->ty=0;
+ }
+}
+
+@ Here's a procedure that applies the transform |txx..ty| to a pair of
+coordinates in locations |p| and~|q|.
+
+@<Declare binary action...@>=
+void mp_trans (MP mp,pointer p, pointer q) {
+ scaled v; /* the new |x| value */
+ v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
+ mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
+ mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
+ mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
+ mp->mem[p].sc=v;
+}
+
+@ The simplest transformation procedure applies a transform to all
+coordinates of a path. The |path_trans(c)(p)| macro applies
+a transformation defined by |cur_exp| and the transform operator |c|
+to the path~|p|.
+
+@d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
+ mp_unstash_cur_exp(mp, (B));
+ mp_do_path_trans(mp, mp->cur_exp); }
+
+@<Declare binary action...@>=
+void mp_do_path_trans (MP mp,pointer p) {
+ pointer q; /* list traverser */
+ q=p;
+ do {
+ if ( left_type(q)!=mp_endpoint )
+ mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
+ mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
+ if ( right_type(q)!=mp_endpoint )
+ mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
+@^data structure assumptions@>
+ q=link(q);
+ } while (q!=p);
+}
+
+@ Transforming a pen is very similar, except that there are no |left_type|
+and |right_type| fields.
+
+@d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
+ mp_unstash_cur_exp(mp, (B));
+ mp_do_pen_trans(mp, mp->cur_exp); }
+
+@<Declare binary action...@>=
+void mp_do_pen_trans (MP mp,pointer p) {
+ pointer q; /* list traverser */
+ if ( pen_is_elliptical(p) ) {
+ mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
+ mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
+ };
+ q=p;
+ do {
+ mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
+@^data structure assumptions@>
+ q=link(q);
+ } while (q!=p);
+}
+
+@ The next transformation procedure applies to edge structures. It will do
+any transformation, but the results may be substandard if the picture contains
+text that uses downloaded bitmap fonts. The binary action procedure is
+|do_edges_trans|, but we also need a function that just scales a picture.
+That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
+should be thought of as procedures that update an edge structure |h|, except
+that they have to return a (possibly new) structure because of the need to call
+|private_edges|.
+
+@<Declare binary action...@>=
+pointer mp_edges_trans (MP mp, pointer h) {
+ pointer q; /* the object being transformed */
+ pointer r,s; /* for list manipulation */
+ scaled sx,sy; /* saved transformation parameters */
+ scaled sqdet; /* square root of determinant for |dash_scale| */
+ integer sgndet; /* sign of the determinant */
+ scaled v; /* a temporary value */
+ h=mp_private_edges(mp, h);
+ sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
+ sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
+ if ( dash_list(h)!=null_dash ) {
+ @<Try to transform the dash list of |h|@>;
+ }
+ @<Make the bounding box of |h| unknown if it can't be updated properly
+ without scanning the whole structure@>;
+ q=link(dummy_loc(h));
+ while ( q!=null ) {
+ @<Transform graphical object |q|@>;
+ q=link(q);
+ }
+ return h;
+}
+void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
+ mp_set_up_known_trans(mp, c);
+ value(p)=mp_edges_trans(mp, value(p));
+ mp_unstash_cur_exp(mp, p);
+}
+void mp_scale_edges (MP mp) {
+ mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
+ mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
+ mp->se_pic=mp_edges_trans(mp, mp->se_pic);
+}
+
+@ @<Try to transform the dash list of |h|@>=
+if ( (mp->txy!=0)||(mp->tyx!=0)||
+ (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
+ mp_flush_dash_list(mp, h);
+} else {
+ if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
+ @<Scale the dash list by |txx| and shift it by |tx|@>;
+ dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
+}
+
+@ @<Reverse the dash list of |h|@>=
+{
+ r=dash_list(h);
+ dash_list(h)=null_dash;
+ while ( r!=null_dash ) {
+ s=r; r=link(r);
+ v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
+ link(s)=dash_list(h);
+ dash_list(h)=s;
+ }
+}
+
+@ @<Scale the dash list by |txx| and shift it by |tx|@>=
+r=dash_list(h);
+while ( r!=null_dash ) {
+ start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
+ stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
+ r=link(r);
+}
+
+@ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
+if ( (mp->txx==0)&&(mp->tyy==0) ) {
+ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
+} else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
+ mp_init_bbox(mp, h);
+ goto DONE1;
+}
+if ( minx_val(h)<=maxx_val(h) ) {
+ @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
+ |(tx,ty)|@>;
+}
+DONE1:
+
+
+
+@ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
+{
+ v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
+ v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
+}
+
+@ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
+sum is similar.
+
+@<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
+{
+ minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
+ maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
+ miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
+ maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
+ if ( mp->txx+mp->txy<0 ) {
+ v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
+ }
+ if ( mp->tyx+mp->tyy<0 ) {
+ v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
+ }
+}
+
+@ Now we ready for the main task of transforming the graphical objects in edge
+structure~|h|.
+
+@<Transform graphical object |q|@>=
+switch (type(q)) {
+case mp_fill_code: case mp_stroked_code:
+ mp_do_path_trans(mp, path_p(q));
+ @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
+ break;
+case mp_start_clip_code: case mp_start_bounds_code:
+ mp_do_path_trans(mp, path_p(q));
+ break;
+case mp_text_code:
+ r=text_tx_loc(q);
+ @<Transform the compact transformation starting at |r|@>;
+ break;
+case mp_stop_clip_code: case mp_stop_bounds_code:
+ break;
+} /* there are no other cases */
+
+@ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
+The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
+since the \ps\ output procedures will try to compensate for the transformation
+we are applying to |pen_p(q)|. Since this compensation is based on the square
+root of the determinant, |sqdet| is the appropriate factor.
+
+@<Transform |pen_p(q)|, making sure...@>=
+if ( pen_p(q)!=null ) {
+ sx=mp->tx; sy=mp->ty;
+ mp->tx=0; mp->ty=0;
+ mp_do_pen_trans(mp, pen_p(q));
+ if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
+ dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
+ if ( ! pen_is_elliptical(pen_p(q)) )
+ if ( sgndet<0 )
+ pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
+ /* this unreverses the pen */
+ mp->tx=sx; mp->ty=sy;
+}
+
+@ This uses the fact that transformations are stored in the order
+|(tx,ty,txx,txy,tyx,tyy)|.
+@^data structure assumptions@>
+
+@<Transform the compact transformation starting at |r|@>=
+mp_trans(mp, r,r+1);
+sx=mp->tx; sy=mp->ty;
+mp->tx=0; mp->ty=0;
+mp_trans(mp, r+2,r+4);
+mp_trans(mp, r+3,r+5);
+mp->tx=sx; mp->ty=sy
+
+@ The hard cases of transformation occur when big nodes are involved,
+and when some of their components are unknown.
+
+@<Declare binary action...@>=
+@<Declare subroutines needed by |big_trans|@>
+void mp_big_trans (MP mp,pointer p, quarterword c) {
+ pointer q,r,pp,qq; /* list manipulation registers */
+ small_number s; /* size of a big node */
+ s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
+ do {
+ r=r-2;
+ if ( type(r)!=mp_known ) {
+ @<Transform an unknown big node and |return|@>;
+ }
+ } while (r!=q);
+ @<Transform a known big node@>;
+} /* node |p| will now be recycled by |do_binary| */
+
+@ @<Transform an unknown big node and |return|@>=
+{
+ mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
+ r=value(mp->cur_exp);
+ if ( mp->cur_type==mp_transform_type ) {
+ mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
+ mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
+ mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
+ mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
+ }
+ mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
+ mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
+ return;
+}
+
+@ Let |p| point to a two-word value field inside a big node of |cur_exp|,
+and let |q| point to a another value field. The |bilin1| procedure
+replaces |p| by $p\cdot t+q\cdot u+\delta$.
+
+@<Declare subroutines needed by |big_trans|@>=
+void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
+ scaled u, scaled delta) {
+ pointer r; /* list traverser */
+ if ( t!=unity ) mp_dep_mult(mp, p,t,true);
+ if ( u!=0 ) {
+ if ( type(q)==mp_known ) {
+ delta+=mp_take_scaled(mp, value(q),u);
+ } else {
+ @<Ensure that |type(p)=mp_proto_dependent|@>;
+ dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
+ mp_proto_dependent,type(q));
+ }
+ }
+ if ( type(p)==mp_known ) {
+ value(p)+=delta;
+ } else {
+ r=dep_list(p);
+ while ( info(r)!=null ) r=link(r);
+ delta+=value(r);
+ if ( r!=dep_list(p) ) value(r)=delta;
+ else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
+ }
+ if ( mp->fix_needed ) mp_fix_dependencies(mp);
+}
+
+@ @<Ensure that |type(p)=mp_proto_dependent|@>=
+if ( type(p)!=mp_proto_dependent ) {
+ if ( type(p)==mp_known )
+ mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
+ else
+ dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
+ mp_proto_dependent,true);
+ type(p)=mp_proto_dependent;
+}
+
+@ @<Transform a known big node@>=
+mp_set_up_trans(mp, c);
+if ( mp->cur_type==mp_known ) {
+ @<Transform known by known@>;
+} else {
+ pp=mp_stash_cur_exp(mp); qq=value(pp);
+ mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
+ if ( mp->cur_type==mp_transform_type ) {
+ mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
+ value(xy_part_loc(q)),yx_part_loc(qq),null);
+ mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
+ value(xx_part_loc(q)),yx_part_loc(qq),null);
+ mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
+ value(yy_part_loc(q)),xy_part_loc(qq),null);
+ mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
+ value(yx_part_loc(q)),xy_part_loc(qq),null);
+ };
+ mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
+ value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
+ mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
+ value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
+ mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
+}
+
+@ Let |p| be a |mp_proto_dependent| value whose dependency list ends
+at |dep_final|. The following procedure adds |v| times another
+numeric quantity to~|p|.
+
+@<Declare subroutines needed by |big_trans|@>=
+void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
+ if ( type(r)==mp_known ) {
+ value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
+ } else {
+ dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
+ mp_proto_dependent,type(r));
+ if ( mp->fix_needed ) mp_fix_dependencies(mp);
+ }
+}
+
+@ The |bilin2| procedure is something like |bilin1|, but with known
+and unknown quantities reversed. Parameter |p| points to a value field
+within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
+|t| and~|u| point to value fields elsewhere; so does parameter~|q|,
+unless it is |null| (which stands for zero). Location~|p| will be
+replaced by $p\cdot t+v\cdot u+q$.
+
+@<Declare subroutines needed by |big_trans|@>=
+void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
+ pointer u, pointer q) {
+ scaled vv; /* temporary storage for |value(p)| */
+ vv=value(p); type(p)=mp_proto_dependent;
+ mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
+ if ( vv!=0 )
+ mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
+ if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
+ if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
+ if ( dep_list(p)==mp->dep_final ) {
+ vv=value(mp->dep_final); mp_recycle_value(mp, p);
+ type(p)=mp_known; value(p)=vv;
+ }
+}
+
+@ @<Transform known by known@>=
+{
+ mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
+ if ( mp->cur_type==mp_transform_type ) {
+ mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
+ mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
+ mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
+ mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
+ }
+ mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
+ mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
+}
+
+@ Finally, in |bilin3| everything is |known|.
+
+@<Declare subroutines needed by |big_trans|@>=
+void mp_bilin3 (MP mp,pointer p, scaled t,
+ scaled v, scaled u, scaled delta) {
+ if ( t!=unity )
+ delta+=mp_take_scaled(mp, value(p),t);
+ else
+ delta+=value(p);
+ if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
+ else value(p)=delta;
+}
+
+@ @<Additional cases of binary operators@>=
+case concatenate:
+ if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
+ else mp_bad_binary(mp, p,concatenate);
+ break;
+case substring_of:
+ if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
+ mp_chop_string(mp, value(p));
+ else mp_bad_binary(mp, p,substring_of);
+ break;
+case subpath_of:
+ if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
+ mp_chop_path(mp, value(p));
+ else mp_bad_binary(mp, p,subpath_of);
+ break;
+
+@ @<Declare binary action...@>=
+void mp_cat (MP mp,pointer p) {
+ str_number a,b; /* the strings being concatenated */
+ pool_pointer k; /* index into |str_pool| */
+ a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
+ for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
+ append_char(mp->str_pool[k]);
+ }
+ for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
+ append_char(mp->str_pool[k]);
+ }
+ mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
+}
+
+@ @<Declare binary action...@>=
+void mp_chop_string (MP mp,pointer p) {
+ integer a, b; /* start and stop points */
+ integer l; /* length of the original string */
+ integer k; /* runs from |a| to |b| */
+ str_number s; /* the original string */
+ boolean reversed; /* was |a>b|? */
+ a=mp_round_unscaled(mp, value(x_part_loc(p)));
+ b=mp_round_unscaled(mp, value(y_part_loc(p)));
+ if ( a<=b ) reversed=false;
+ else { reversed=true; k=a; a=b; b=k; };
+ s=mp->cur_exp; l=length(s);
+ if ( a<0 ) {
+ a=0;
+ if ( b<0 ) b=0;
+ }
+ if ( b>l ) {
+ b=l;
+ if ( a>l ) a=l;
+ }
+ str_room(b-a);
+ if ( reversed ) {
+ for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
+ append_char(mp->str_pool[k]);
+ }
+ } else {
+ for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
+ append_char(mp->str_pool[k]);
+ }
+ }
+ mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
+}
+
+@ @<Declare binary action...@>=
+void mp_chop_path (MP mp,pointer p) {
+ pointer q; /* a knot in the original path */
+ pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
+ scaled a,b,k,l; /* indices for chopping */
+ boolean reversed; /* was |a>b|? */
+ l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
+ if ( a<=b ) reversed=false;
+ else { reversed=true; k=a; a=b; b=k; };
+ @<Dispense with the cases |a<0| and/or |b>l|@>;
+ q=mp->cur_exp;
+ while ( a>=unity ) {
+ q=link(q); a=a-unity; b=b-unity;
+ }
+ if ( b==a ) {
+ @<Construct a path from |pp| to |qq| of length zero@>;
+ } else {
+ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
+ }
+ left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
+ mp_toss_knot_list(mp, mp->cur_exp);
+ if ( reversed ) {
+ mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
+ } else {
+ mp->cur_exp=pp;
+ }
+}
+
+@ @<Dispense with the cases |a<0| and/or |b>l|@>=
+if ( a<0 ) {
+ if ( left_type(mp->cur_exp)==mp_endpoint ) {
+ a=0; if ( b<0 ) b=0;
+ } else {
+ do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
+ }
+}
+if ( b>l ) {
+ if ( left_type(mp->cur_exp)==mp_endpoint ) {
+ b=l; if ( a>l ) a=l;
+ } else {
+ while ( a>=l ) {
+ a=a-l; b=b-l;
+ }
+ }
+}
+
+@ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
+{
+ pp=mp_copy_knot(mp, q); qq=pp;
+ do {
+ q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
+ } while (b>0);
+ if ( a>0 ) {
+ ss=pp; pp=link(pp);
+ mp_split_cubic(mp, ss,a*010000); pp=link(ss);
+ mp_free_node(mp, ss,knot_node_size);
+ if ( rr==ss ) {
+ b=mp_make_scaled(mp, b,unity-a); rr=pp;
+ }
+ }
+ if ( b<0 ) {
+ mp_split_cubic(mp, rr,(b+unity)*010000);
+ mp_free_node(mp, qq,knot_node_size);
+ qq=link(rr);
+ }
+}
+
+@ @<Construct a path from |pp| to |qq| of length zero@>=
+{
+ if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
+ pp=mp_copy_knot(mp, q); qq=pp;
+}
+
+@ @<Additional cases of binary operators@>=
+case point_of: case precontrol_of: case postcontrol_of:
+ if ( mp->cur_type==mp_pair_type )
+ mp_pair_to_path(mp);
+ if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
+ mp_find_point(mp, value(p),c);
+ else
+ mp_bad_binary(mp, p,c);
+ break;
+case pen_offset_of:
+ if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
+ mp_set_up_offset(mp, value(p));
+ else
+ mp_bad_binary(mp, p,pen_offset_of);
+ break;
+case direction_time_of:
+ if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
+ mp_set_up_direction_time(mp, value(p));
+ else
+ mp_bad_binary(mp, p,direction_time_of);
+ break;
+case envelope_of:
+ if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
+ mp_bad_binary(mp, p,envelope_of);
+ else
+ mp_set_up_envelope(mp, p);
+ break;
+
+@ @<Declare binary action...@>=
+void mp_set_up_offset (MP mp,pointer p) {
+ mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
+ mp_pair_value(mp, mp->cur_x,mp->cur_y);
+}
+void mp_set_up_direction_time (MP mp,pointer p) {
+ mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
+ value(y_part_loc(p)),mp->cur_exp));
+}
+void mp_set_up_envelope (MP mp,pointer p) {
+ small_number ljoin, lcap;
+ scaled miterlim;
+ pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
+ /* TODO: accept elliptical pens for straight paths */
+ if (pen_is_elliptical(value(p))) {
+ mp_bad_envelope_pen(mp);
+ mp->cur_exp = q;
+ mp->cur_type = mp_path_type;
+ return;
+ }
+ if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
+ else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
+ else ljoin=0;
+ if ( mp->internal[mp_linecap]>unity ) lcap=2;
+ else if ( mp->internal[mp_linecap]>0 ) lcap=1;
+ else lcap=0;
+ if ( mp->internal[mp_miterlimit]<unity )
+ miterlim=unity;
+ else
+ miterlim=mp->internal[mp_miterlimit];
+ mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
+ mp->cur_type = mp_path_type;
+}
+
+@ @<Declare binary action...@>=
+void mp_find_point (MP mp,scaled v, quarterword c) {
+ pointer p; /* the path */
+ scaled n; /* its length */
+ p=mp->cur_exp;
+ if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
+ do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
+ if ( n==0 ) {
+ v=0;
+ } else if ( v<0 ) {
+ if ( left_type(p)==mp_endpoint ) v=0;
+ else v=n-1-((-v-1) % n);
+ } else if ( v>n ) {
+ if ( left_type(p)==mp_endpoint ) v=n;
+ else v=v % n;
+ }
+ p=mp->cur_exp;
+ while ( v>=unity ) { p=link(p); v=v-unity; };
+ if ( v!=0 ) {
+ @<Insert a fractional node by splitting the cubic@>;
+ }
+ @<Set the current expression to the desired path coordinates@>;
+}
+
+@ @<Insert a fractional node...@>=
+{ mp_split_cubic(mp, p,v*010000); p=link(p); }
+
+@ @<Set the current expression to the desired path coordinates...@>=
+switch (c) {
+case point_of:
+ mp_pair_value(mp, x_coord(p),y_coord(p));
+ break;
+case precontrol_of:
+ if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
+ else mp_pair_value(mp, left_x(p),left_y(p));
+ break;
+case postcontrol_of:
+ if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
+ else mp_pair_value(mp, right_x(p),right_y(p));
+ break;
+} /* there are no other cases */
+
+@ @<Additional cases of binary operators@>=
+case arc_time_of:
+ if ( mp->cur_type==mp_pair_type )
+ mp_pair_to_path(mp);
+ if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
+ mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
+ else
+ mp_bad_binary(mp, p,c);
+ break;
+
+@ @<Additional cases of bin...@>=
+case intersect:
+ if ( type(p)==mp_pair_type ) {
+ q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
+ mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
+ };
+ if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
+ mp_path_intersection(mp, value(p),mp->cur_exp);
+ mp_pair_value(mp, mp->cur_t,mp->cur_tt);
+ } else {
+ mp_bad_binary(mp, p,intersect);
+ }
+ break;
+
+@ @<Additional cases of bin...@>=
+case in_font:
+ if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
+ mp_bad_binary(mp, p,in_font);
+ else { mp_do_infont(mp, p); binary_return; }
+ break;
+
+@ Function |new_text_node| owns the reference count for its second argument
+(the text string) but not its first (the font name).
+
+@<Declare binary action...@>=
+void mp_do_infont (MP mp,pointer p) {
+ pointer q;
+ q=mp_get_node(mp, edge_header_size);
+ mp_init_edges(mp, q);
+ link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
+ obj_tail(q)=link(obj_tail(q));
+ mp_free_node(mp, p,value_node_size);
+ mp_flush_cur_exp(mp, q);
+ mp->cur_type=mp_picture_type;
+}
+
+@* \[40] Statements and commands.
+The chief executive of \MP\ is the |do_statement| routine, which
+contains the master switch that causes all the various pieces of \MP\
+to do their things, in the right order.
+
+In a sense, this is the grand climax of the program: It applies all the
+tools that we have worked so hard to construct. In another sense, this is
+the messiest part of the program: It necessarily refers to other pieces
+of code all over the place, so that a person can't fully understand what is
+going on without paging back and forth to be reminded of conventions that
+are defined elsewhere. We are now at the hub of the web.
+
+The structure of |do_statement| itself is quite simple. The first token
+of the statement is fetched using |get_x_next|. If it can be the first
+token of an expression, we look for an equation, an assignment, or a
+title. Otherwise we use a \&{case} construction to branch at high speed to
+the appropriate routine for various and sundry other types of commands,
+each of which has an ``action procedure'' that does the necessary work.
+
+The program uses the fact that
+$$\hbox{|min_primary_command=max_statement_command=type_name|}$$
+to interpret a statement that starts with, e.g., `\&{string}',
+as a type declaration rather than a boolean expression.
+
+@c void mp_do_statement (MP mp) { /* governs \MP's activities */
+ mp->cur_type=mp_vacuous; mp_get_x_next(mp);
+ if ( mp->cur_cmd>max_primary_command ) {
+ @<Worry about bad statement@>;
+ } else if ( mp->cur_cmd>max_statement_command ) {
+ @<Do an equation, assignment, title, or
+ `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
+ } else {
+ @<Do a statement that doesn't begin with an expression@>;
+ }
+ if ( mp->cur_cmd<semicolon )
+ @<Flush unparsable junk that was found after the statement@>;
+ mp->error_count=0;
+}
+
+@ @<Declarations@>=
+@<Declare action procedures for use by |do_statement|@>
+
+@ The only command codes |>max_primary_command| that can be present
+at the beginning of a statement are |semicolon| and higher; these
+occur when the statement is null.
+
+@<Worry about bad statement@>=
+{
+ if ( mp->cur_cmd<semicolon ) {
+ print_err("A statement can't begin with `");
+@.A statement can't begin with x@>
+ mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
+ help5("I was looking for the beginning of a new statement.")
+ ("If you just proceed without changing anything, I'll ignore")
+ ("everything up to the next `;'. Please insert a semicolon")
+ ("now in front of anything that you don't want me to delete.")
+ ("(See Chapter 27 of The METAFONTbook for an example.)");
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+ mp_back_error(mp); mp_get_x_next(mp);
+ }
+}
+
+@ The help message printed here says that everything is flushed up to
+a semicolon, but actually the commands |end_group| and |stop| will
+also terminate a statement.
+
+@<Flush unparsable junk that was found after the statement@>=
+{
+ print_err("Extra tokens will be flushed");
+@.Extra tokens will be flushed@>
+ help6("I've just read as much of that statement as I could fathom,")
+ ("so a semicolon should have been next. It's very puzzling...")
+ ("but I'll try to get myself back together, by ignoring")
+ ("everything up to the next `;'. Please insert a semicolon")
+ ("now in front of anything that you don't want me to delete.")
+ ("(See Chapter 27 of The METAFONTbook for an example.)");
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+ mp_back_error(mp); mp->scanner_status=flushing;
+ do {
+ get_t_next;
+ @<Decrease the string reference count...@>;
+ } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
+ mp->scanner_status=normal;
+}
+
+@ If |do_statement| ends with |cur_cmd=end_group|, we should have
+|cur_type=mp_vacuous| unless the statement was simply an expression;
+in the latter case, |cur_type| and |cur_exp| should represent that
+expression.
+
+@<Do a statement that doesn't...@>=
+{
+ if ( mp->internal[mp_tracing_commands]>0 )
+ show_cur_cmd_mod;
+ switch (mp->cur_cmd ) {
+ case type_name:mp_do_type_declaration(mp); break;
+ case macro_def:
+ if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
+ else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
+ break;
+ @<Cases of |do_statement| that invoke particular commands@>;
+ } /* there are no other cases */
+ mp->cur_type=mp_vacuous;
+}
+
+@ The most important statements begin with expressions.
+
+@<Do an equation, assignment, title, or...@>=
+{
+ mp->var_flag=assignment; mp_scan_expression(mp);
+ if ( mp->cur_cmd<end_group ) {
+ if ( mp->cur_cmd==equals ) mp_do_equation(mp);
+ else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
+ else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
+ else if ( mp->cur_type!=mp_vacuous ){
+ exp_err("Isolated expression");
+@.Isolated expression@>
+ help3("I couldn't find an `=' or `:=' after the")
+ ("expression that is shown above this error message,")
+ ("so I guess I'll just ignore it and carry on.");
+ mp_put_get_error(mp);
+ }
+ mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
+ }
+}
+
+@ @<Do a title@>=
+{
+ if ( mp->internal[mp_tracing_titles]>0 ) {
+ mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
+ }
+}
+
+@ Equations and assignments are performed by the pair of mutually recursive
+@^recursion@>
+routines |do_equation| and |do_assignment|. These routines are called when
+|cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
+side is in |cur_type| and |cur_exp|, while the right-hand side is yet
+to be scanned. After the routines are finished, |cur_type| and |cur_exp|
+will be equal to the right-hand side (which will normally be equal
+to the left-hand side).
+
+@<Declare action procedures for use by |do_statement|@>=
+@<Declare the procedure called |try_eq|@>
+@<Declare the procedure called |make_eq|@>
+void mp_do_equation (MP mp) ;
+
+@ @c
+void mp_do_equation (MP mp) {
+ pointer lhs; /* capsule for the left-hand side */
+ pointer p; /* temporary register */
+ lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
+ mp->var_flag=assignment; mp_scan_expression(mp);
+ if ( mp->cur_cmd==equals ) mp_do_equation(mp);
+ else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
+ if ( mp->internal[mp_tracing_commands]>two )
+ @<Trace the current equation@>;
+ if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
+ p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
+ }; /* in this case |make_eq| will change the pair to a path */
+ mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
+}
+
+@ And |do_assignment| is similar to |do_equation|:
+
+@<Declarations@>=
+void mp_do_assignment (MP mp);
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_assignment (MP mp) ;
+
+@ @c
+void mp_do_assignment (MP mp) {
+ pointer lhs; /* token list for the left-hand side */
+ pointer p; /* where the left-hand value is stored */
+ pointer q; /* temporary capsule for the right-hand value */
+ if ( mp->cur_type!=mp_token_list ) {
+ exp_err("Improper `:=' will be changed to `='");
+@.Improper `:='@>
+ help2("I didn't find a variable name at the left of the `:=',")
+ ("so I'm going to pretend that you said `=' instead.");
+ mp_error(mp); mp_do_equation(mp);
+ } else {
+ lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
+ mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
+ if ( mp->cur_cmd==equals ) mp_do_equation(mp);
+ else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
+ if ( mp->internal[mp_tracing_commands]>two )
+ @<Trace the current assignment@>;
+ if ( info(lhs)>hash_end ) {
+ @<Assign the current expression to an internal variable@>;
+ } else {
+ @<Assign the current expression to the variable |lhs|@>;
+ }
+ mp_flush_node_list(mp, lhs);
+ }
+}
+
+@ @<Trace the current equation@>=
+{
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
+ mp_print(mp,")=("); mp_print_exp(mp,null,0);
+ mp_print(mp,")}"); mp_end_diagnostic(mp, false);
+}
+
+@ @<Trace the current assignment@>=
+{
+ mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
+ if ( info(lhs)>hash_end )
+ mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
+ else
+ mp_show_token_list(mp, lhs,null,1000,0);
+ mp_print(mp, ":="); mp_print_exp(mp, null,0);
+ mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
+}
+
+@ @<Assign the current expression to an internal variable@>=
+if ( mp->cur_type==mp_known ) {
+ mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
+} else {
+ exp_err("Internal quantity `");
+@.Internal quantity...@>
+ mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
+ mp_print(mp, "' must receive a known value");
+ help2("I can\'t set an internal quantity to anything but a known")
+ ("numeric value, so I'll have to ignore this assignment.");
+ mp_put_get_error(mp);
+}
+
+@ @<Assign the current expression to the variable |lhs|@>=
+{
+ p=mp_find_variable(mp, lhs);
+ if ( p!=null ) {
+ q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
+ mp_recycle_value(mp, p);
+ type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
+ p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
+ } else {
+ mp_obliterated(mp, lhs); mp_put_get_error(mp);
+ }
+}
+
+
+@ And now we get to the nitty-gritty. The |make_eq| procedure is given
+a pointer to a capsule that is to be equated to the current expression.
+
+@<Declare the procedure called |make_eq|@>=
+void mp_make_eq (MP mp,pointer lhs) ;
+
+
+@
+@c void mp_make_eq (MP mp,pointer lhs) {
+ small_number t; /* type of the left-hand side */
+ pointer p,q; /* pointers inside of big nodes */
+ integer v=0; /* value of the left-hand side */
+RESTART:
+ t=type(lhs);
+ if ( t<=mp_pair_type ) v=value(lhs);
+ switch (t) {
+ @<For each type |t|, make an equation and |goto done| unless |cur_type|
+ is incompatible with~|t|@>;
+ } /* all cases have been listed */
+ @<Announce that the equation cannot be performed@>;
+DONE:
+ check_arith; mp_recycle_value(mp, lhs);
+ mp_free_node(mp, lhs,value_node_size);
+}
+
+@ @<Announce that the equation cannot be performed@>=
+mp_disp_err(mp, lhs,"");
+exp_err("Equation cannot be performed (");
+@.Equation cannot be performed@>
+if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
+else mp_print(mp, "numeric");
+mp_print_char(mp, '=');
+if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
+else mp_print(mp, "numeric");
+mp_print_char(mp, ')');
+help2("I'm sorry, but I don't know how to make such things equal.")
+ ("(See the two expressions just above the error message.)");
+mp_put_get_error(mp)
+
+@ @<For each type |t|, make an equation and |goto done| unless...@>=
+case mp_boolean_type: case mp_string_type: case mp_pen_type:
+case mp_path_type: case mp_picture_type:
+ if ( mp->cur_type==t+unknown_tag ) {
+ mp_nonlinear_eq(mp, v,mp->cur_exp,false);
+ mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
+ } else if ( mp->cur_type==t ) {
+ @<Report redundant or inconsistent equation and |goto done|@>;
+ }
+ break;
+case unknown_types:
+ if ( mp->cur_type==t-unknown_tag ) {
+ mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
+ } else if ( mp->cur_type==t ) {
+ mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
+ } else if ( mp->cur_type==mp_pair_type ) {
+ if ( t==mp_unknown_path ) {
+ mp_pair_to_path(mp); goto RESTART;
+ };
+ }
+ break;
+case mp_transform_type: case mp_color_type:
+case mp_cmykcolor_type: case mp_pair_type:
+ if ( mp->cur_type==t ) {
+ @<Do multiple equations and |goto done|@>;
+ }
+ break;
+case mp_known: case mp_dependent:
+case mp_proto_dependent: case mp_independent:
+ if ( mp->cur_type>=mp_known ) {
+ mp_try_eq(mp, lhs,null); goto DONE;
+ };
+ break;
+case mp_vacuous:
+ break;
+
+@ @<Report redundant or inconsistent equation and |goto done|@>=
+{
+ if ( mp->cur_type<=mp_string_type ) {
+ if ( mp->cur_type==mp_string_type ) {
+ if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
+ goto NOT_FOUND;
+ }
+ } else if ( v!=mp->cur_exp ) {
+ goto NOT_FOUND;
+ }
+ @<Exclaim about a redundant equation@>; goto DONE;
+ }
+ print_err("Redundant or inconsistent equation");
+@.Redundant or inconsistent equation@>
+ help2("An equation between already-known quantities can't help.")
+ ("But don't worry; continue and I'll just ignore it.");
+ mp_put_get_error(mp); goto DONE;
+NOT_FOUND:
+ print_err("Inconsistent equation");
+@.Inconsistent equation@>
+ help2("The equation I just read contradicts what was said before.")
+ ("But don't worry; continue and I'll just ignore it.");
+ mp_put_get_error(mp); goto DONE;
+}
+
+@ @<Do multiple equations and |goto done|@>=
+{
+ p=v+mp->big_node_size[t];
+ q=value(mp->cur_exp)+mp->big_node_size[t];
+ do {
+ p=p-2; q=q-2; mp_try_eq(mp, p,q);
+ } while (p!=v);
+ goto DONE;
+}
+
+@ The first argument to |try_eq| is the location of a value node
+in a capsule that will soon be recycled. The second argument is
+either a location within a pair or transform node pointed to by
+|cur_exp|, or it is |null| (which means that |cur_exp| itself
+serves as the second argument). The idea is to leave |cur_exp| unchanged,
+but to equate the two operands.
+
+@<Declare the procedure called |try_eq|@>=
+void mp_try_eq (MP mp,pointer l, pointer r) ;
+
+@
+@c void mp_try_eq (MP mp,pointer l, pointer r) {
+ pointer p; /* dependency list for right operand minus left operand */
+ int t; /* the type of list |p| */
+ pointer q; /* the constant term of |p| is here */
+ pointer pp; /* dependency list for right operand */
+ int tt; /* the type of list |pp| */
+ boolean copied; /* have we copied a list that ought to be recycled? */
+ @<Remove the left operand from its container, negate it, and
+ put it into dependency list~|p| with constant term~|q|@>;
+ @<Add the right operand to list |p|@>;
+ if ( info(p)==null ) {
+ @<Deal with redundant or inconsistent equation@>;
+ } else {
+ mp_linear_eq(mp, p,t);
+ if ( r==null ) if ( mp->cur_type!=mp_known ) {
+ if ( type(mp->cur_exp)==mp_known ) {
+ pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
+ mp_free_node(mp, pp,value_node_size);
+ }
+ }
+ }
+}
+
+@ @<Remove the left operand from its container, negate it, and...@>=
+t=type(l);
+if ( t==mp_known ) {
+ t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
+} else if ( t==mp_independent ) {
+ t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
+ q=mp->dep_final;
+} else {
+ p=dep_list(l); q=p;
+ while (1) {
+ negate(value(q));
+ if ( info(q)==null ) break;
+ q=link(q);
+ }
+ link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
+ type(l)=mp_known;
+}
+
+@ @<Deal with redundant or inconsistent equation@>=
+{
+ if ( abs(value(p))>64 ) { /* off by .001 or more */
+ print_err("Inconsistent equation");
+@.Inconsistent equation@>
+ mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
+ mp_print_char(mp, ')');
+ help2("The equation I just read contradicts what was said before.")
+ ("But don't worry; continue and I'll just ignore it.");
+ mp_put_get_error(mp);
+ } else if ( r==null ) {
+ @<Exclaim about a redundant equation@>;
+ }
+ mp_free_node(mp, p,dep_node_size);
+}
+
+@ @<Add the right operand to list |p|@>=
+if ( r==null ) {
+ if ( mp->cur_type==mp_known ) {
+ value(q)=value(q)+mp->cur_exp; goto DONE1;
+ } else {
+ tt=mp->cur_type;
+ if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
+ else pp=dep_list(mp->cur_exp);
+ }
+} else {
+ if ( type(r)==mp_known ) {
+ value(q)=value(q)+value(r); goto DONE1;
+ } else {
+ tt=type(r);
+ if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
+ else pp=dep_list(r);
+ }
+}
+if ( tt!=mp_independent ) copied=false;
+else { copied=true; tt=mp_dependent; };
+@<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
+if ( copied ) mp_flush_node_list(mp, pp);
+DONE1:
+
+@ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
+mp->watch_coefs=false;
+if ( t==tt ) {
+ p=mp_p_plus_q(mp, p,pp,t);
+} else if ( t==mp_proto_dependent ) {
+ p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
+} else {
+ q=p;
+ while ( info(q)!=null ) {
+ value(q)=mp_round_fraction(mp, value(q)); q=link(q);
+ }
+ t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
+}
+mp->watch_coefs=true;
+
+@ Our next goal is to process type declarations. For this purpose it's
+convenient to have a procedure that scans a $\langle\,$declared
+variable$\,\rangle$ and returns the corresponding token list. After the
+following procedure has acted, the token after the declared variable
+will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
+and~|cur_sym|.
+
+@<Declare the function called |scan_declared_variable|@>=
+pointer mp_scan_declared_variable (MP mp) {
+ pointer x; /* hash address of the variable's root */
+ pointer h,t; /* head and tail of the token list to be returned */
+ pointer l; /* hash address of left bracket */
+ mp_get_symbol(mp); x=mp->cur_sym;
+ if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
+ h=mp_get_avail(mp); info(h)=x; t=h;
+ while (1) {
+ mp_get_x_next(mp);
+ if ( mp->cur_sym==0 ) break;
+ if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
+ if ( mp->cur_cmd==left_bracket ) {
+ @<Descend past a collective subscript@>;
+ } else {
+ break;
+ }
+ }
+ link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
+ }
+ if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
+ if ( equiv(x)==null ) mp_new_root(mp, x);
+ return h;
+}
+
+@ If the subscript isn't collective, we don't accept it as part of the
+declared variable.
+
+@<Descend past a collective subscript@>=
+{
+ l=mp->cur_sym; mp_get_x_next(mp);
+ if ( mp->cur_cmd!=right_bracket ) {
+ mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
+ } else {
+ mp->cur_sym=collective_subscript;
+ }
+}
+
+@ Type declarations are introduced by the following primitive operations.
+
+@<Put each...@>=
+mp_primitive(mp, "numeric",type_name,mp_numeric_type);
+@:numeric_}{\&{numeric} primitive@>
+mp_primitive(mp, "string",type_name,mp_string_type);
+@:string_}{\&{string} primitive@>
+mp_primitive(mp, "boolean",type_name,mp_boolean_type);
+@:boolean_}{\&{boolean} primitive@>
+mp_primitive(mp, "path",type_name,mp_path_type);
+@:path_}{\&{path} primitive@>
+mp_primitive(mp, "pen",type_name,mp_pen_type);
+@:pen_}{\&{pen} primitive@>
+mp_primitive(mp, "picture",type_name,mp_picture_type);
+@:picture_}{\&{picture} primitive@>
+mp_primitive(mp, "transform",type_name,mp_transform_type);
+@:transform_}{\&{transform} primitive@>
+mp_primitive(mp, "color",type_name,mp_color_type);
+@:color_}{\&{color} primitive@>
+mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
+@:color_}{\&{rgbcolor} primitive@>
+mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
+@:color_}{\&{cmykcolor} primitive@>
+mp_primitive(mp, "pair",type_name,mp_pair_type);
+@:pair_}{\&{pair} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case type_name: mp_print_type(mp, m); break;
+
+@ Now we are ready to handle type declarations, assuming that a
+|type_name| has just been scanned.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_type_declaration (MP mp) ;
+
+@ @c
+void mp_do_type_declaration (MP mp) {
+ small_number t; /* the type being declared */
+ pointer p; /* token list for a declared variable */
+ pointer q; /* value node for the variable */
+ if ( mp->cur_mod>=mp_transform_type )
+ t=mp->cur_mod;
+ else
+ t=mp->cur_mod+unknown_tag;
+ do {
+ p=mp_scan_declared_variable(mp);
+ mp_flush_variable(mp, equiv(info(p)),link(p),false);
+ q=mp_find_variable(mp, p);
+ if ( q!=null ) {
+ type(q)=t; value(q)=null;
+ } else {
+ print_err("Declared variable conflicts with previous vardef");
+@.Declared variable conflicts...@>
+ help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
+ ("Proceed, and I'll ignore the illegal redeclaration.");
+ mp_put_get_error(mp);
+ }
+ mp_flush_list(mp, p);
+ if ( mp->cur_cmd<comma ) {
+ @<Flush spurious symbols after the declared variable@>;
+ }
+ } while (! end_of_statement);
+}
+
+@ @<Flush spurious symbols after the declared variable@>=
+{
+ print_err("Illegal suffix of declared variable will be flushed");
+@.Illegal suffix...flushed@>
+ help5("Variables in declarations must consist entirely of")
+ ("names and collective subscripts, e.g., `x[]a'.")
+ ("Are you trying to use a reserved word in a variable name?")
+ ("I'm going to discard the junk I found here,")
+ ("up to the next comma or the end of the declaration.");
+ if ( mp->cur_cmd==numeric_token )
+ mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
+ mp_put_get_error(mp); mp->scanner_status=flushing;
+ do {
+ get_t_next;
+ @<Decrease the string reference count...@>;
+ } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
+ mp->scanner_status=normal;
+}
+
+@ \MP's |main_control| procedure just calls |do_statement| repeatedly
+until coming to the end of the user's program.
+Each execution of |do_statement| concludes with
+|cur_cmd=semicolon|, |end_group|, or |stop|.
+
+@c void mp_main_control (MP mp) {
+ do {
+ mp_do_statement(mp);
+ if ( mp->cur_cmd==end_group ) {
+ print_err("Extra `endgroup'");
+@.Extra `endgroup'@>
+ help2("I'm not currently working on a `begingroup',")
+ ("so I had better not try to end anything.");
+ mp_flush_error(mp, 0);
+ }
+ } while (mp->cur_cmd!=stop);
+}
+int __attribute__((noinline))
+mp_run (MP mp) {
+ if (mp->history < mp_fatal_error_stop ) {
+ @<Install and test the non-local jump buffer@>;
+ mp_main_control(mp); /* come to life */
+ mp_final_cleanup(mp); /* prepare for death */
+ mp_close_files_and_terminate(mp);
+ }
+ return mp->history;
+}
+int __attribute__((noinline))
+mp_execute (MP mp) {
+ if (mp->history < mp_fatal_error_stop ) {
+ mp->history = mp_spotless;
+ mp->file_offset = 0;
+ mp->term_offset = 0;
+ mp->tally = 0;
+ @<Install and test the non-local jump buffer@>;
+ if (mp->run_state==0) {
+ mp->run_state = 1;
+ } else {
+ mp_input_ln(mp,mp->term_in);
+ mp_firm_up_the_line(mp);
+ mp->buffer[limit]='%';
+ mp->first=limit+1;
+ loc=start;
+ }
+ do {
+ mp_do_statement(mp);
+ } while (mp->cur_cmd!=stop);
+ }
+ return mp->history;
+}
+int __attribute__((noinline))
+mp_finish (MP mp) {
+ if (mp->history < mp_fatal_error_stop ) {
+ @<Install and test the non-local jump buffer@>;
+ mp_final_cleanup(mp); /* prepare for death */
+ mp_close_files_and_terminate(mp);
+ }
+ return mp->history;
+}
+const char * mp_mplib_version (MP mp) {
+ (void)mp;
+ return mplib_version;
+}
+const char * mp_metapost_version (MP mp) {
+ (void)mp;
+ return metapost_version;
+}
+
+@ @<Exported function headers@>=
+int mp_run (MP mp);
+int mp_execute (MP mp);
+int mp_finish (MP mp);
+const char * mp_mplib_version (MP mp);
+const char * mp_metapost_version (MP mp);
+
+@ @<Put each...@>=
+mp_primitive(mp, "end",stop,0);
+@:end_}{\&{end} primitive@>
+mp_primitive(mp, "dump",stop,1);
+@:dump_}{\&{dump} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case stop:
+ if ( m==0 ) mp_print(mp, "end");
+ else mp_print(mp, "dump");
+ break;
+
+@* \[41] Commands.
+Let's turn now to statements that are classified as ``commands'' because
+of their imperative nature. We'll begin with simple ones, so that it
+will be clear how to hook command processing into the |do_statement| routine;
+then we'll tackle the tougher commands.
+
+Here's one of the simplest:
+
+@<Cases of |do_statement|...@>=
+case mp_random_seed: mp_do_random_seed(mp); break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_random_seed (MP mp) ;
+
+@ @c void mp_do_random_seed (MP mp) {
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd!=assignment ) {
+ mp_missing_err(mp, ":=");
+@.Missing `:='@>
+ help1("Always say `randomseed:=<numeric expression>'.");
+ mp_back_error(mp);
+ };
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ) {
+ exp_err("Unknown value will be ignored");
+@.Unknown value...ignored@>
+ help2("Your expression was too random for me to handle,")
+ ("so I won't change the random seed just now.");
+ mp_put_get_flush_error(mp, 0);
+ } else {
+ @<Initialize the random seed to |cur_exp|@>;
+ }
+}
+
+@ @<Initialize the random seed to |cur_exp|@>=
+{
+ mp_init_randoms(mp, mp->cur_exp);
+ if ( mp->selector>=log_only && mp->selector<write_file) {
+ mp->old_setting=mp->selector; mp->selector=log_only;
+ mp_print_nl(mp, "{randomseed:=");
+ mp_print_scaled(mp, mp->cur_exp);
+ mp_print_char(mp, '}');
+ mp_print_nl(mp, ""); mp->selector=mp->old_setting;
+ }
+}
+
+@ And here's another simple one (somewhat different in flavor):
+
+@<Cases of |do_statement|...@>=
+case mode_command:
+ mp_print_ln(mp); mp->interaction=mp->cur_mod;
+ @<Initialize the print |selector| based on |interaction|@>;
+ if ( mp->log_opened ) mp->selector=mp->selector+2;
+ mp_get_x_next(mp);
+ break;
+
+@ @<Put each...@>=
+mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
+@:mp_batch_mode_}{\&{batchmode} primitive@>
+mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
+@:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
+mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
+@:mp_scroll_mode_}{\&{scrollmode} primitive@>
+mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
+@:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
+
+@ @<Cases of |print_cmd_mod|...@>=
+case mode_command:
+ switch (m) {
+ case mp_batch_mode: mp_print(mp, "batchmode"); break;
+ case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
+ case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
+ default: mp_print(mp, "errorstopmode"); break;
+ }
+ break;
+
+@ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
+
+@<Cases of |do_statement|...@>=
+case protection_command: mp_do_protection(mp); break;
+
+@ @<Put each...@>=
+mp_primitive(mp, "inner",protection_command,0);
+@:inner_}{\&{inner} primitive@>
+mp_primitive(mp, "outer",protection_command,1);
+@:outer_}{\&{outer} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case protection_command:
+ if ( m==0 ) mp_print(mp, "inner");
+ else mp_print(mp, "outer");
+ break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_protection (MP mp) ;
+
+@ @c void mp_do_protection (MP mp) {
+ int m; /* 0 to unprotect, 1 to protect */
+ halfword t; /* the |eq_type| before we change it */
+ m=mp->cur_mod;
+ do {
+ mp_get_symbol(mp); t=eq_type(mp->cur_sym);
+ if ( m==0 ) {
+ if ( t>=outer_tag )
+ eq_type(mp->cur_sym)=t-outer_tag;
+ } else if ( t<outer_tag ) {
+ eq_type(mp->cur_sym)=t+outer_tag;
+ }
+ mp_get_x_next(mp);
+ } while (mp->cur_cmd==comma);
+}
+
+@ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
+plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
+declaration assigns the command code |left_delimiter| to `\.{(}' and
+|right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
+hash address of its mate.
+
+@<Cases of |do_statement|...@>=
+case delimiters: mp_def_delims(mp); break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_def_delims (MP mp) ;
+
+@ @c void mp_def_delims (MP mp) {
+ pointer l_delim,r_delim; /* the new delimiter pair */
+ mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
+ mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
+ eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
+ eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
+ mp_get_x_next(mp);
+}
+
+@ Here is a procedure that is called when \MP\ has reached a point
+where some right delimiter is mandatory.
+
+@<Declare the procedure called |check_delimiter|@>=
+void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
+ if ( mp->cur_cmd==right_delimiter )
+ if ( mp->cur_mod==l_delim )
+ return;
+ if ( mp->cur_sym!=r_delim ) {
+ mp_missing_err(mp, str(text(r_delim)));
+@.Missing `)'@>
+ help2("I found no right delimiter to match a left one. So I've")
+ ("put one in, behind the scenes; this may fix the problem.");
+ mp_back_error(mp);
+ } else {
+ print_err("The token `"); mp_print_text(r_delim);
+@.The token...delimiter@>
+ mp_print(mp, "' is no longer a right delimiter");
+ help3("Strange: This token has lost its former meaning!")
+ ("I'll read it as a right delimiter this time;")
+ ("but watch out, I'll probably miss it later.");
+ mp_error(mp);
+ }
+}
+
+@ The next four commands save or change the values associated with tokens.
+
+@<Cases of |do_statement|...@>=
+case save_command:
+ do {
+ mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
+ } while (mp->cur_cmd==comma);
+ break;
+case interim_command: mp_do_interim(mp); break;
+case let_command: mp_do_let(mp); break;
+case new_internal: mp_do_new_internal(mp); break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_statement (MP mp);
+void mp_do_interim (MP mp);
+
+@ @c void mp_do_interim (MP mp) {
+ mp_get_x_next(mp);
+ if ( mp->cur_cmd!=internal_quantity ) {
+ print_err("The token `");
+@.The token...quantity@>
+ if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
+ else mp_print_text(mp->cur_sym);
+ mp_print(mp, "' isn't an internal quantity");
+ help1("Something like `tracingonline' should follow `interim'.");
+ mp_back_error(mp);
+ } else {
+ mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
+ }
+ mp_do_statement(mp);
+}
+
+@ The following procedure is careful not to undefine the left-hand symbol
+too soon, lest commands like `{\tt let x=x}' have a surprising effect.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_let (MP mp) ;
+
+@ @c void mp_do_let (MP mp) {
+ pointer l; /* hash location of the left-hand symbol */
+ mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
+ if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
+ mp_missing_err(mp, "=");
+@.Missing `='@>
+ help3("You should have said `let symbol = something'.")
+ ("But don't worry; I'll pretend that an equals sign")
+ ("was present. The next token I read will be `something'.");
+ mp_back_error(mp);
+ }
+ mp_get_symbol(mp);
+ switch (mp->cur_cmd) {
+ case defined_macro: case secondary_primary_macro:
+ case tertiary_secondary_macro: case expression_tertiary_macro:
+ add_mac_ref(mp->cur_mod);
+ break;
+ default:
+ break;
+ }
+ mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
+ if ( mp->cur_cmd==tag_token ) equiv(l)=null;
+ else equiv(l)=mp->cur_mod;
+ mp_get_x_next(mp);
+}
+
+@ @<Declarations@>=
+void mp_grow_internals (MP mp, int l);
+void mp_do_new_internal (MP mp) ;
+
+@ @c
+void mp_grow_internals (MP mp, int l) {
+ scaled *internal;
+ char * *int_name;
+ int k;
+ if ( hash_end+l>max_halfword ) {
+ mp_confusion(mp, "out of memory space"); /* can't be reached */
+ }
+ int_name = xmalloc ((l+1),sizeof(char *));
+ internal = xmalloc ((l+1),sizeof(scaled));
+ for (k=0;k<=l; k++ ) {
+ if (k<=mp->max_internal) {
+ internal[k]=mp->internal[k];
+ int_name[k]=mp->int_name[k];
+ } else {
+ internal[k]=0;
+ int_name[k]=NULL;
+ }
+ }
+ xfree(mp->internal); xfree(mp->int_name);
+ mp->int_name = int_name;
+ mp->internal = internal;
+ mp->max_internal = l;
+}
+
+
+void mp_do_new_internal (MP mp) {
+ do {
+ if ( mp->int_ptr==mp->max_internal ) {
+ mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
+ }
+ mp_get_clear_symbol(mp); incr(mp->int_ptr);
+ eq_type(mp->cur_sym)=internal_quantity;
+ equiv(mp->cur_sym)=mp->int_ptr;
+ if(mp->int_name[mp->int_ptr]!=NULL)
+ xfree(mp->int_name[mp->int_ptr]);
+ mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
+ mp->internal[mp->int_ptr]=0;
+ mp_get_x_next(mp);
+ } while (mp->cur_cmd==comma);
+}
+
+@ @<Dealloc variables@>=
+for (k=0;k<=mp->max_internal;k++) {
+ xfree(mp->int_name[k]);
+}
+xfree(mp->internal);
+xfree(mp->int_name);
+
+
+@ The various `\&{show}' commands are distinguished by modifier fields
+in the usual way.
+
+@d show_token_code 0 /* show the meaning of a single token */
+@d show_stats_code 1 /* show current memory and string usage */
+@d show_code 2 /* show a list of expressions */
+@d show_var_code 3 /* show a variable and its descendents */
+@d show_dependencies_code 4 /* show dependent variables in terms of independents */
+
+@<Put each...@>=
+mp_primitive(mp, "showtoken",show_command,show_token_code);
+@:show_token_}{\&{showtoken} primitive@>
+mp_primitive(mp, "showstats",show_command,show_stats_code);
+@:show_stats_}{\&{showstats} primitive@>
+mp_primitive(mp, "show",show_command,show_code);
+@:show_}{\&{show} primitive@>
+mp_primitive(mp, "showvariable",show_command,show_var_code);
+@:show_var_}{\&{showvariable} primitive@>
+mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
+@:show_dependencies_}{\&{showdependencies} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case show_command:
+ switch (m) {
+ case show_token_code:mp_print(mp, "showtoken"); break;
+ case show_stats_code:mp_print(mp, "showstats"); break;
+ case show_code:mp_print(mp, "show"); break;
+ case show_var_code:mp_print(mp, "showvariable"); break;
+ default: mp_print(mp, "showdependencies"); break;
+ }
+ break;
+
+@ @<Cases of |do_statement|...@>=
+case show_command:mp_do_show_whatever(mp); break;
+
+@ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
+if it's |show_code|, complicated structures are abbreviated, otherwise
+they aren't.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_show (MP mp) ;
+
+@ @c void mp_do_show (MP mp) {
+ do {
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ mp_print_nl(mp, ">> ");
+@.>>@>
+ mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
+ } while (mp->cur_cmd==comma);
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_disp_token (MP mp) ;
+
+@ @c void mp_disp_token (MP mp) {
+ mp_print_nl(mp, "> ");
+@.>\relax@>
+ if ( mp->cur_sym==0 ) {
+ @<Show a numeric or string or capsule token@>;
+ } else {
+ mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
+ if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
+ mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
+ if ( mp->cur_cmd==defined_macro ) {
+ mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
+ } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
+@^recursion@>
+ }
+}
+
+@ @<Show a numeric or string or capsule token@>=
+{
+ if ( mp->cur_cmd==numeric_token ) {
+ mp_print_scaled(mp, mp->cur_mod);
+ } else if ( mp->cur_cmd==capsule_token ) {
+ mp_print_capsule(mp,mp->cur_mod);
+ } else {
+ mp_print_char(mp, '"');
+ mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
+ delete_str_ref(mp->cur_mod);
+ }
+}
+
+@ The following cases of |print_cmd_mod| might arise in connection
+with |disp_token|, although they don't necessarily correspond to
+primitive tokens.
+
+@<Cases of |print_cmd_...@>=
+case left_delimiter:
+case right_delimiter:
+ if ( c==left_delimiter ) mp_print(mp, "left");
+ else mp_print(mp, "right");
+ mp_print(mp, " delimiter that matches ");
+ mp_print_text(m);
+ break;
+case tag_token:
+ if ( m==null ) mp_print(mp, "tag");
+ else mp_print(mp, "variable");
+ break;
+case defined_macro:
+ mp_print(mp, "macro:");
+ break;
+case secondary_primary_macro:
+case tertiary_secondary_macro:
+case expression_tertiary_macro:
+ mp_print_cmd_mod(mp, macro_def,c);
+ mp_print(mp, "'d macro:");
+ mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
+ break;
+case repeat_loop:
+ mp_print(mp, "[repeat the loop]");
+ break;
+case internal_quantity:
+ mp_print(mp, mp->int_name[m]);
+ break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_show_token (MP mp) ;
+
+@ @c void mp_do_show_token (MP mp) {
+ do {
+ get_t_next; mp_disp_token(mp);
+ mp_get_x_next(mp);
+ } while (mp->cur_cmd==comma);
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_show_stats (MP mp) ;
+
+@ @c void mp_do_show_stats (MP mp) {
+ mp_print_nl(mp, "Memory usage ");
+@.Memory usage...@>
+ mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
+ mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
+ mp_print(mp, " still untouched)"); mp_print_ln(mp);
+ mp_print_nl(mp, "String usage ");
+ mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
+ mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
+ mp_print(mp, " (");
+ mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
+ mp_print_int(mp, mp->pool_size-mp->pool_ptr);
+ mp_print(mp, " now untouched)"); mp_print_ln(mp);
+ mp_get_x_next(mp);
+}
+
+@ Here's a recursive procedure that gives an abbreviated account
+of a variable, for use by |do_show_var|.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_disp_var (MP mp,pointer p) ;
+
+@ @c void mp_disp_var (MP mp,pointer p) {
+ pointer q; /* traverses attributes and subscripts */
+ int n; /* amount of macro text to show */
+ if ( type(p)==mp_structured ) {
+ @<Descend the structure@>;
+ } else if ( type(p)>=mp_unsuffixed_macro ) {
+ @<Display a variable macro@>;
+ } else if ( type(p)!=undefined ){
+ mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
+ mp_print_char(mp, '=');
+ mp_print_exp(mp, p,0);
+ }
+}
+
+@ @<Descend the structure@>=
+{
+ q=attr_head(p);
+ do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
+ q=subscr_head(p);
+ while ( name_type(q)==mp_subscr ) {
+ mp_disp_var(mp, q); q=link(q);
+ }
+}
+
+@ @<Display a variable macro@>=
+{
+ mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
+ if ( type(p)>mp_unsuffixed_macro )
+ mp_print(mp, "@@#"); /* |suffixed_macro| */
+ mp_print(mp, "=macro:");
+ if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
+ else n=mp->max_print_line-mp->file_offset-15;
+ mp_show_macro(mp, value(p),null,n);
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_show_var (MP mp) ;
+
+@ @c void mp_do_show_var (MP mp) {
+ do {
+ get_t_next;
+ if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
+ if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
+ mp_disp_var(mp, mp->cur_mod); goto DONE;
+ }
+ mp_disp_token(mp);
+ DONE:
+ mp_get_x_next(mp);
+ } while (mp->cur_cmd==comma);
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_show_dependencies (MP mp) ;
+
+@ @c void mp_do_show_dependencies (MP mp) {
+ pointer p; /* link that runs through all dependencies */
+ p=link(dep_head);
+ while ( p!=dep_head ) {
+ if ( mp_interesting(mp, p) ) {
+ mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
+ if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
+ else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
+ mp_print_dependency(mp, dep_list(p),type(p));
+ }
+ p=dep_list(p);
+ while ( info(p)!=null ) p=link(p);
+ p=link(p);
+ }
+ mp_get_x_next(mp);
+}
+
+@ Finally we are ready for the procedure that governs all of the
+show commands.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_show_whatever (MP mp) ;
+
+@ @c void mp_do_show_whatever (MP mp) {
+ if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
+ switch (mp->cur_mod) {
+ case show_token_code:mp_do_show_token(mp); break;
+ case show_stats_code:mp_do_show_stats(mp); break;
+ case show_code:mp_do_show(mp); break;
+ case show_var_code:mp_do_show_var(mp); break;
+ case show_dependencies_code:mp_do_show_dependencies(mp); break;
+ } /* there are no other cases */
+ if ( mp->internal[mp_showstopping]>0 ){
+ print_err("OK");
+@.OK@>
+ if ( mp->interaction<mp_error_stop_mode ) {
+ help0; decr(mp->error_count);
+ } else {
+ help1("This isn't an error message; I'm just showing something.");
+ }
+ if ( mp->cur_cmd==semicolon ) mp_error(mp);
+ else mp_put_get_error(mp);
+ }
+}
+
+@ The `\&{addto}' command needs the following additional primitives:
+
+@d double_path_code 0 /* command modifier for `\&{doublepath}' */
+@d contour_code 1 /* command modifier for `\&{contour}' */
+@d also_code 2 /* command modifier for `\&{also}' */
+
+@ Pre and postscripts need two new identifiers:
+
+@d with_pre_script 11
+@d with_post_script 13
+
+@<Put each...@>=
+mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
+@:double_path_}{\&{doublepath} primitive@>
+mp_primitive(mp, "contour",thing_to_add,contour_code);
+@:contour_}{\&{contour} primitive@>
+mp_primitive(mp, "also",thing_to_add,also_code);
+@:also_}{\&{also} primitive@>
+mp_primitive(mp, "withpen",with_option,mp_pen_type);
+@:with_pen_}{\&{withpen} primitive@>
+mp_primitive(mp, "dashed",with_option,mp_picture_type);
+@:dashed_}{\&{dashed} primitive@>
+mp_primitive(mp, "withprescript",with_option,with_pre_script);
+@:with_pre_script_}{\&{withprescript} primitive@>
+mp_primitive(mp, "withpostscript",with_option,with_post_script);
+@:with_post_script_}{\&{withpostscript} primitive@>
+mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
+@:with_color_}{\&{withoutcolor} primitive@>
+mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
+@:with_color_}{\&{withgreyscale} primitive@>
+mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
+@:with_color_}{\&{withcolor} primitive@>
+/* \&{withrgbcolor} is an alias for \&{withcolor} */
+mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
+@:with_color_}{\&{withrgbcolor} primitive@>
+mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
+@:with_color_}{\&{withcmykcolor} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case thing_to_add:
+ if ( m==contour_code ) mp_print(mp, "contour");
+ else if ( m==double_path_code ) mp_print(mp, "doublepath");
+ else mp_print(mp, "also");
+ break;
+case with_option:
+ if ( m==mp_pen_type ) mp_print(mp, "withpen");
+ else if ( m==with_pre_script ) mp_print(mp, "withprescript");
+ else if ( m==with_post_script ) mp_print(mp, "withpostscript");
+ else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
+ else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
+ else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
+ else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
+ else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
+ else mp_print(mp, "dashed");
+ break;
+
+@ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
+updates the list of graphical objects starting at |p|. Each $\langle$with
+clause$\rangle$ updates all graphical objects whose |type| is compatible.
+Other objects are ignored.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_scan_with_list (MP mp,pointer p) ;
+
+@ @c void mp_scan_with_list (MP mp,pointer p) {
+ small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
+ pointer q; /* for list manipulation */
+ int old_setting; /* saved |selector| setting */
+ pointer k; /* for finding the near-last item in a list */
+ str_number s; /* for string cleanup after combining */
+ pointer cp,pp,dp,ap,bp;
+ /* objects being updated; |void| initially; |null| to suppress update */
+ cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
+ k=0;
+ while ( mp->cur_cmd==with_option ){
+ t=mp->cur_mod;
+ mp_get_x_next(mp);
+ if ( t!=mp_no_model ) mp_scan_expression(mp);
+ if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
+ ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
+ ((t==mp_uninitialized_model)&&
+ ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
+ &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
+ ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
+ ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
+ ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
+ ((t==mp_pen_type)&&(mp->cur_type!=t))||
+ ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
+ @<Complain about improper type@>;
+ } else if ( t==mp_uninitialized_model ) {
+ if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
+ if ( cp!=null )
+ @<Transfer a color from the current expression to object~|cp|@>;
+ mp_flush_cur_exp(mp, 0);
+ } else if ( t==mp_rgb_model ) {
+ if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
+ if ( cp!=null )
+ @<Transfer a rgbcolor from the current expression to object~|cp|@>;
+ mp_flush_cur_exp(mp, 0);
+ } else if ( t==mp_cmyk_model ) {
+ if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
+ if ( cp!=null )
+ @<Transfer a cmykcolor from the current expression to object~|cp|@>;
+ mp_flush_cur_exp(mp, 0);
+ } else if ( t==mp_grey_model ) {
+ if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
+ if ( cp!=null )
+ @<Transfer a greyscale from the current expression to object~|cp|@>;
+ mp_flush_cur_exp(mp, 0);
+ } else if ( t==mp_no_model ) {
+ if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
+ if ( cp!=null )
+ @<Transfer a noncolor from the current expression to object~|cp|@>;
+ } else if ( t==mp_pen_type ) {
+ if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
+ if ( pp!=null ) {
+ if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
+ pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
+ }
+ } else if ( t==with_pre_script ) {
+ if ( ap==mp_void )
+ ap=p;
+ while ( (ap!=null)&&(! has_color(ap)) )
+ ap=link(ap);
+ if ( ap!=null ) {
+ if ( pre_script(ap)!=null ) { /* build a new,combined string */
+ s=pre_script(ap);
+ old_setting=mp->selector;
+ mp->selector=new_string;
+ str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
+ mp_print_str(mp, mp->cur_exp);
+ append_char(13); /* a forced \ps\ newline */
+ mp_print_str(mp, pre_script(ap));
+ pre_script(ap)=mp_make_string(mp);
+ delete_str_ref(s);
+ mp->selector=old_setting;
+ } else {
+ pre_script(ap)=mp->cur_exp;
+ }
+ mp->cur_type=mp_vacuous;
+ }
+ } else if ( t==with_post_script ) {
+ if ( bp==mp_void )
+ k=p;
+ bp=k;
+ while ( link(k)!=null ) {
+ k=link(k);
+ if ( has_color(k) ) bp=k;
+ }
+ if ( bp!=null ) {
+ if ( post_script(bp)!=null ) {
+ s=post_script(bp);
+ old_setting=mp->selector;
+ mp->selector=new_string;
+ str_room(length(post_script(bp))+length(mp->cur_exp)+2);
+ mp_print_str(mp, post_script(bp));
+ append_char(13); /* a forced \ps\ newline */
+ mp_print_str(mp, mp->cur_exp);
+ post_script(bp)=mp_make_string(mp);
+ delete_str_ref(s);
+ mp->selector=old_setting;
+ } else {
+ post_script(bp)=mp->cur_exp;
+ }
+ mp->cur_type=mp_vacuous;
+ }
+ } else {
+ if ( dp==mp_void ) {
+ @<Make |dp| a stroked node in list~|p|@>;
+ }
+ if ( dp!=null ) {
+ if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
+ dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
+ dash_scale(dp)=unity;
+ mp->cur_type=mp_vacuous;
+ }
+ }
+ }
+ @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
+ of the list@>;
+}
+
+@ @<Complain about improper type@>=
+{ exp_err("Improper type");
+@.Improper type@>
+help2("Next time say `withpen <known pen expression>';")
+ ("I'll ignore the bad `with' clause and look for another.");
+if ( t==with_pre_script )
+ mp->help_line[1]="Next time say `withprescript <known string expression>';";
+else if ( t==with_post_script )
+ mp->help_line[1]="Next time say `withpostscript <known string expression>';";
+else if ( t==mp_picture_type )
+ mp->help_line[1]="Next time say `dashed <known picture expression>';";
+else if ( t==mp_uninitialized_model )
+ mp->help_line[1]="Next time say `withcolor <known color expression>';";
+else if ( t==mp_rgb_model )
+ mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
+else if ( t==mp_cmyk_model )
+ mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
+else if ( t==mp_grey_model )
+ mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
+mp_put_get_flush_error(mp, 0);
+}
+
+@ Forcing the color to be between |0| and |unity| here guarantees that no
+picture will ever contain a color outside the legal range for \ps\ graphics.
+
+@<Transfer a color from the current expression to object~|cp|@>=
+{ if ( mp->cur_type==mp_color_type )
+ @<Transfer a rgbcolor from the current expression to object~|cp|@>
+else if ( mp->cur_type==mp_cmykcolor_type )
+ @<Transfer a cmykcolor from the current expression to object~|cp|@>
+else if ( mp->cur_type==mp_known )
+ @<Transfer a greyscale from the current expression to object~|cp|@>
+else if ( mp->cur_exp==false_code )
+ @<Transfer a noncolor from the current expression to object~|cp|@>;
+}
+
+@ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
+{ q=value(mp->cur_exp);
+cyan_val(cp)=0;
+magenta_val(cp)=0;
+yellow_val(cp)=0;
+black_val(cp)=0;
+red_val(cp)=value(red_part_loc(q));
+green_val(cp)=value(green_part_loc(q));
+blue_val(cp)=value(blue_part_loc(q));
+color_model(cp)=mp_rgb_model;
+if ( red_val(cp)<0 ) red_val(cp)=0;
+if ( green_val(cp)<0 ) green_val(cp)=0;
+if ( blue_val(cp)<0 ) blue_val(cp)=0;
+if ( red_val(cp)>unity ) red_val(cp)=unity;
+if ( green_val(cp)>unity ) green_val(cp)=unity;
+if ( blue_val(cp)>unity ) blue_val(cp)=unity;
+}
+
+@ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
+{ q=value(mp->cur_exp);
+cyan_val(cp)=value(cyan_part_loc(q));
+magenta_val(cp)=value(magenta_part_loc(q));
+yellow_val(cp)=value(yellow_part_loc(q));
+black_val(cp)=value(black_part_loc(q));
+color_model(cp)=mp_cmyk_model;
+if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
+if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
+if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
+if ( black_val(cp)<0 ) black_val(cp)=0;
+if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
+if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
+if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
+if ( black_val(cp)>unity ) black_val(cp)=unity;
+}
+
+@ @<Transfer a greyscale from the current expression to object~|cp|@>=
+{ q=mp->cur_exp;
+cyan_val(cp)=0;
+magenta_val(cp)=0;
+yellow_val(cp)=0;
+black_val(cp)=0;
+grey_val(cp)=q;
+color_model(cp)=mp_grey_model;
+if ( grey_val(cp)<0 ) grey_val(cp)=0;
+if ( grey_val(cp)>unity ) grey_val(cp)=unity;
+}
+
+@ @<Transfer a noncolor from the current expression to object~|cp|@>=
+{
+cyan_val(cp)=0;
+magenta_val(cp)=0;
+yellow_val(cp)=0;
+black_val(cp)=0;
+grey_val(cp)=0;
+color_model(cp)=mp_no_model;
+}
+
+@ @<Make |cp| a colored object in object list~|p|@>=
+{ cp=p;
+ while ( cp!=null ){
+ if ( has_color(cp) ) break;
+ cp=link(cp);
+ }
+}
+
+@ @<Make |pp| an object in list~|p| that needs a pen@>=
+{ pp=p;
+ while ( pp!=null ) {
+ if ( has_pen(pp) ) break;
+ pp=link(pp);
+ }
+}
+
+@ @<Make |dp| a stroked node in list~|p|@>=
+{ dp=p;
+ while ( dp!=null ) {
+ if ( type(dp)==mp_stroked_code ) break;
+ dp=link(dp);
+ }
+}
+
+@ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
+@<Copy |cp|'s color into the colored objects linked to~|cp|@>;
+if ( pp>mp_void ) {
+ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
+}
+if ( dp>mp_void ) {
+ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
+}
+
+
+@ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
+{ q=link(cp);
+ while ( q!=null ) {
+ if ( has_color(q) ) {
+ red_val(q)=red_val(cp);
+ green_val(q)=green_val(cp);
+ blue_val(q)=blue_val(cp);
+ black_val(q)=black_val(cp);
+ color_model(q)=color_model(cp);
+ }
+ q=link(q);
+ }
+}
+
+@ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
+{ q=link(pp);
+ while ( q!=null ) {
+ if ( has_pen(q) ) {
+ if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
+ pen_p(q)=copy_pen(pen_p(pp));
+ }
+ q=link(q);
+ }
+}
+
+@ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
+{ q=link(dp);
+ while ( q!=null ) {
+ if ( type(q)==mp_stroked_code ) {
+ if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
+ dash_p(q)=dash_p(dp);
+ dash_scale(q)=unity;
+ if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
+ }
+ q=link(q);
+ }
+}
+
+@ One of the things we need to do when we've parsed an \&{addto} or
+similar command is find the header of a supposed \&{picture} variable, given
+a token list for that variable. Since the edge structure is about to be
+updated, we use |private_edges| to make sure that this is possible.
+
+@<Declare action procedures for use by |do_statement|@>=
+pointer mp_find_edges_var (MP mp, pointer t) ;
+
+@ @c pointer mp_find_edges_var (MP mp, pointer t) {
+ pointer p;
+ pointer cur_edges; /* the return value */
+ p=mp_find_variable(mp, t); cur_edges=null;
+ if ( p==null ) {
+ mp_obliterated(mp, t); mp_put_get_error(mp);
+ } else if ( type(p)!=mp_picture_type ) {
+ print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
+@.Variable x is the wrong type@>
+ mp_print(mp, " is the wrong type (");
+ mp_print_type(mp, type(p)); mp_print_char(mp, ')');
+ help2("I was looking for a \"known\" picture variable.")
+ ("So I'll not change anything just now.");
+ mp_put_get_error(mp);
+ } else {
+ value(p)=mp_private_edges(mp, value(p));
+ cur_edges=value(p);
+ }
+ mp_flush_node_list(mp, t);
+ return cur_edges;
+}
+
+@ @<Cases of |do_statement|...@>=
+case add_to_command: mp_do_add_to(mp); break;
+case bounds_command:mp_do_bounds(mp); break;
+
+@ @<Put each...@>=
+mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
+@:clip_}{\&{clip} primitive@>
+mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
+@:set_bounds_}{\&{setbounds} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case bounds_command:
+ if ( m==mp_start_clip_code ) mp_print(mp, "clip");
+ else mp_print(mp, "setbounds");
+ break;
+
+@ The following function parses the beginning of an \&{addto} or \&{clip}
+command: it expects a variable name followed by a token with |cur_cmd=sep|
+and then an expression. The function returns the token list for the variable
+and stores the command modifier for the separator token in the global variable
+|last_add_type|. We must be careful because this variable might get overwritten
+any time we call |get_x_next|.
+
+@<Glob...@>=
+quarterword last_add_type;
+ /* command modifier that identifies the last \&{addto} command */
+
+@ @<Declare action procedures for use by |do_statement|@>=
+pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
+
+@ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
+ pointer lhv; /* variable to add to left */
+ quarterword add_type=0; /* value to be returned in |last_add_type| */
+ lhv=null;
+ mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
+ if ( mp->cur_type!=mp_token_list ) {
+ @<Abandon edges command because there's no variable@>;
+ } else {
+ lhv=mp->cur_exp; add_type=mp->cur_mod;
+ mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
+ }
+ mp->last_add_type=add_type;
+ return lhv;
+}
+
+@ @<Abandon edges command because there's no variable@>=
+{ exp_err("Not a suitable variable");
+@.Not a suitable variable@>
+ help4("At this point I needed to see the name of a picture variable.")
+ ("(Or perhaps you have indeed presented me with one; I might")
+ ("have missed it, if it wasn't followed by the proper token.)")
+ ("So I'll not change anything just now.");
+ mp_put_get_flush_error(mp, 0);
+}
+
+@ Here is an example of how to use |start_draw_cmd|.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_bounds (MP mp) ;
+
+@ @c void mp_do_bounds (MP mp) {
+ pointer lhv,lhe; /* variable on left, the corresponding edge structure */
+ pointer p; /* for list manipulation */
+ integer m; /* initial value of |cur_mod| */
+ m=mp->cur_mod;
+ lhv=mp_start_draw_cmd(mp, to_token);
+ if ( lhv!=null ) {
+ lhe=mp_find_edges_var(mp, lhv);
+ if ( lhe==null ) {
+ mp_flush_cur_exp(mp, 0);
+ } else if ( mp->cur_type!=mp_path_type ) {
+ exp_err("Improper `clip'");
+@.Improper `addto'@>
+ help2("This expression should have specified a known path.")
+ ("So I'll not change anything just now.");
+ mp_put_get_flush_error(mp, 0);
+ } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
+ @<Complain about a non-cycle@>;
+ } else {
+ @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
+ }
+ }
+}
+
+@ @<Complain about a non-cycle@>=
+{ print_err("Not a cycle");
+@.Not a cycle@>
+ help2("That contour should have ended with `..cycle' or `&cycle'.")
+ ("So I'll not change anything just now."); mp_put_get_error(mp);
+}
+
+@ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
+{ p=mp_new_bounds_node(mp, mp->cur_exp,m);
+ link(p)=link(dummy_loc(lhe));
+ link(dummy_loc(lhe))=p;
+ if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
+ p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
+ type(p)=stop_type(m);
+ link(obj_tail(lhe))=p;
+ obj_tail(lhe)=p;
+ mp_init_bbox(mp, lhe);
+}
+
+@ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
+cases to deal with.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_add_to (MP mp) ;
+
+@ @c void mp_do_add_to (MP mp) {
+ pointer lhv,lhe; /* variable on left, the corresponding edge structure */
+ pointer p; /* the graphical object or list for |scan_with_list| to update */
+ pointer e; /* an edge structure to be merged */
+ quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
+ lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
+ if ( lhv!=null ) {
+ if ( add_type==also_code ) {
+ @<Make sure the current expression is a suitable picture and set |e| and |p|
+ appropriately@>;
+ } else {
+ @<Create a graphical object |p| based on |add_type| and the current
+ expression@>;
+ }
+ mp_scan_with_list(mp, p);
+ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
+ }
+}
+
+@ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
+setting |e:=null| prevents anything from being added to |lhe|.
+
+@ @<Make sure the current expression is a suitable picture and set |e|...@>=
+{
+ p=null; e=null;
+ if ( mp->cur_type!=mp_picture_type ) {
+ exp_err("Improper `addto'");
+@.Improper `addto'@>
+ help2("This expression should have specified a known picture.")
+ ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
+ } else {
+ e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
+ p=link(dummy_loc(e));
+ }
+}
+
+@ In this case |add_type<>also_code| so setting |p:=null| suppresses future
+attempts to add to the edge structure.
+
+@<Create a graphical object |p| based on |add_type| and the current...@>=
+{ e=null; p=null;
+ if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
+ if ( mp->cur_type!=mp_path_type ) {
+ exp_err("Improper `addto'");
+@.Improper `addto'@>
+ help2("This expression should have specified a known path.")
+ ("So I'll not change anything just now.");
+ mp_put_get_flush_error(mp, 0);
+ } else if ( add_type==contour_code ) {
+ if ( left_type(mp->cur_exp)==mp_endpoint ) {
+ @<Complain about a non-cycle@>;
+ } else {
+ p=mp_new_fill_node(mp, mp->cur_exp);
+ mp->cur_type=mp_vacuous;
+ }
+ } else {
+ p=mp_new_stroked_node(mp, mp->cur_exp);
+ mp->cur_type=mp_vacuous;
+ }
+}
+
+@ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
+lhe=mp_find_edges_var(mp, lhv);
+if ( lhe==null ) {
+ if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
+ if ( e!=null ) delete_edge_ref(e);
+} else if ( add_type==also_code ) {
+ if ( e!=null ) {
+ @<Merge |e| into |lhe| and delete |e|@>;
+ } else {
+ do_nothing;
+ }
+} else if ( p!=null ) {
+ link(obj_tail(lhe))=p;
+ obj_tail(lhe)=p;
+ if ( add_type==double_path_code )
+ if ( pen_p(p)==null )
+ pen_p(p)=mp_get_pen_circle(mp, 0);
+}
+
+@ @<Merge |e| into |lhe| and delete |e|@>=
+{ if ( link(dummy_loc(e))!=null ) {
+ link(obj_tail(lhe))=link(dummy_loc(e));
+ obj_tail(lhe)=obj_tail(e);
+ obj_tail(e)=dummy_loc(e);
+ link(dummy_loc(e))=null;
+ mp_flush_dash_list(mp, lhe);
+ }
+ mp_toss_edges(mp, e);
+}
+
+@ @<Cases of |do_statement|...@>=
+case ship_out_command: mp_do_ship_out(mp); break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+@<Declare the function called |tfm_check|@>
+@<Declare the \ps\ output procedures@>
+void mp_do_ship_out (MP mp) ;
+
+@ @c void mp_do_ship_out (MP mp) {
+ integer c; /* the character code */
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_picture_type ) {
+ @<Complain that it's not a known picture@>;
+ } else {
+ c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
+ if ( c<0 ) c=c+256;
+ @<Store the width information for character code~|c|@>;
+ mp_ship_out(mp, mp->cur_exp);
+ mp_flush_cur_exp(mp, 0);
+ }
+}
+
+@ @<Complain that it's not a known picture@>=
+{
+ exp_err("Not a known picture");
+ help1("I can only output known pictures.");
+ mp_put_get_flush_error(mp, 0);
+}
+
+@ The \&{everyjob} command simply assigns a nonzero value to the global variable
+|start_sym|.
+
+@<Cases of |do_statement|...@>=
+case every_job_command:
+ mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
+ break;
+
+@ @<Glob...@>=
+halfword start_sym; /* a symbolic token to insert at beginning of job */
+
+@ @<Set init...@>=
+mp->start_sym=0;
+
+@ Finally, we have only the ``message'' commands remaining.
+
+@d message_code 0
+@d err_message_code 1
+@d err_help_code 2
+@d filename_template_code 3
+@d print_with_leading_zeroes(A) g = mp->pool_ptr;
+ mp_print_int(mp, (A)); g = mp->pool_ptr-g;
+ if ( f>g ) {
+ mp->pool_ptr = mp->pool_ptr - g;
+ while ( f>g ) {
+ mp_print_char(mp, '0');
+ decr(f);
+ };
+ mp_print_int(mp, (A));
+ };
+ f = 0
+
+@<Put each...@>=
+mp_primitive(mp, "message",message_command,message_code);
+@:message_}{\&{message} primitive@>
+mp_primitive(mp, "errmessage",message_command,err_message_code);
+@:err_message_}{\&{errmessage} primitive@>
+mp_primitive(mp, "errhelp",message_command,err_help_code);
+@:err_help_}{\&{errhelp} primitive@>
+mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
+@:filename_template_}{\&{filenametemplate} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case message_command:
+ if ( m<err_message_code ) mp_print(mp, "message");
+ else if ( m==err_message_code ) mp_print(mp, "errmessage");
+ else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
+ else mp_print(mp, "errhelp");
+ break;
+
+@ @<Cases of |do_statement|...@>=
+case message_command: mp_do_message(mp); break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+@<Declare a procedure called |no_string_err|@>
+void mp_do_message (MP mp) ;
+
+@
+@c void mp_do_message (MP mp) {
+ int m; /* the type of message */
+ m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_string_type )
+ mp_no_string_err(mp, "A message should be a known string expression.");
+ else {
+ switch (m) {
+ case message_code:
+ mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
+ break;
+ case err_message_code:
+ @<Print string |cur_exp| as an error message@>;
+ break;
+ case err_help_code:
+ @<Save string |cur_exp| as the |err_help|@>;
+ break;
+ case filename_template_code:
+ @<Save the filename template@>;
+ break;
+ } /* there are no other cases */
+ }
+ mp_flush_cur_exp(mp, 0);
+}
+
+@ @<Declare a procedure called |no_string_err|@>=
+void mp_no_string_err (MP mp, const char *s) {
+ exp_err("Not a string");
+@.Not a string@>
+ help1(s);
+ mp_put_get_error(mp);
+}
+
+@ The global variable |err_help| is zero when the user has most recently
+given an empty help string, or if none has ever been given.
+
+@<Save string |cur_exp| as the |err_help|@>=
+{
+ if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
+ if ( length(mp->cur_exp)==0 ) mp->err_help=0;
+ else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
+}
+
+@ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
+\&{errhelp}, we don't want to give a long help message each time. So we
+give a verbose explanation only once.
+
+@<Glob...@>=
+boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
+
+@ @<Set init...@>=mp->long_help_seen=false;
+
+@ @<Print string |cur_exp| as an error message@>=
+{
+ print_err(""); mp_print_str(mp, mp->cur_exp);
+ if ( mp->err_help!=0 ) {
+ mp->use_err_help=true;
+ } else if ( mp->long_help_seen ) {
+ help1("(That was another `errmessage'.)") ;
+ } else {
+ if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
+ help4("This error message was generated by an `errmessage'")
+ ("command, so I can\'t give any explicit help.")
+ ("Pretend that you're Miss Marple: Examine all clues,")
+@^Marple, Jane@>
+ ("and deduce the truth by inspired guesses.");
+ }
+ mp_put_get_error(mp); mp->use_err_help=false;
+}
+
+@ @<Cases of |do_statement|...@>=
+case write_command: mp_do_write(mp); break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_write (MP mp) ;
+
+@ @c void mp_do_write (MP mp) {
+ str_number t; /* the line of text to be written */
+ write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
+ int old_setting; /* for saving |selector| during output */
+ mp_get_x_next(mp);
+ mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_string_type ) {
+ mp_no_string_err(mp, "The text to be written should be a known string expression");
+ } else if ( mp->cur_cmd!=to_token ) {
+ print_err("Missing `to' clause");
+ help1("A write command should end with `to <filename>'");
+ mp_put_get_error(mp);
+ } else {
+ t=mp->cur_exp; mp->cur_type=mp_vacuous;
+ mp_get_x_next(mp);
+ mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_string_type )
+ mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
+ else {
+ @<Write |t| to the file named by |cur_exp|@>;
+ }
+ delete_str_ref(t);
+ }
+ mp_flush_cur_exp(mp, 0);
+}
+
+@ @<Write |t| to the file named by |cur_exp|@>=
+{
+ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
+ |cur_exp| must be inserted@>;
+ if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
+ @<Record the end of file on |wr_file[n]|@>;
+ } else {
+ old_setting=mp->selector;
+ mp->selector=n+write_file;
+ mp_print_str(mp, t); mp_print_ln(mp);
+ mp->selector = old_setting;
+ }
+}
+
+@ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
+{
+ char *fn = str(mp->cur_exp);
+ n=mp->write_files;
+ n0=mp->write_files;
+ while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
+ if ( n==0 ) { /* bottom reached */
+ if ( n0==mp->write_files ) {
+ if ( mp->write_files<mp->max_write_files ) {
+ incr(mp->write_files);
+ } else {
+ void **wr_file;
+ char **wr_fname;
+ write_index l,k;
+ l = mp->max_write_files + (mp->max_write_files>>2);
+ wr_file = xmalloc((l+1),sizeof(void *));
+ wr_fname = xmalloc((l+1),sizeof(char *));
+ for (k=0;k<=l;k++) {
+ if (k<=mp->max_write_files) {
+ wr_file[k]=mp->wr_file[k];
+ wr_fname[k]=mp->wr_fname[k];
+ } else {
+ wr_file[k]=0;
+ wr_fname[k]=NULL;
+ }
+ }
+ xfree(mp->wr_file); xfree(mp->wr_fname);
+ mp->max_write_files = l;
+ mp->wr_file = wr_file;
+ mp->wr_fname = wr_fname;
+ }
+ }
+ n=n0;
+ mp_open_write_file(mp, fn ,n);
+ } else {
+ decr(n);
+ if ( mp->wr_fname[n]==NULL ) n0=n;
+ }
+ }
+}
+
+@ @<Record the end of file on |wr_file[n]|@>=
+{ (mp->close_file)(mp,mp->wr_file[n]);
+ xfree(mp->wr_fname[n]);
+ mp->wr_fname[n]=NULL;
+ if ( n==mp->write_files-1 ) mp->write_files=n;
+}
+
+
+@* \[42] Writing font metric data.
+\TeX\ gets its knowledge about fonts from font metric files, also called
+\.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
+but other programs know about them too. One of \MP's duties is to
+write \.{TFM} files so that the user's fonts can readily be
+applied to typesetting.
+@:TFM files}{\.{TFM} files@>
+@^font metric files@>
+
+The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
+Since the number of bytes is always a multiple of~4, we could
+also regard the file as a sequence of 32-bit words, but \MP\ uses the
+byte interpretation. The format of \.{TFM} files was designed by
+Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
+@^Ramshaw, Lyle Harold@>
+of information in a compact but useful form.
+
+@<Glob...@>=
+void * tfm_file; /* the font metric output goes here */
+char * metric_file_name; /* full name of the font metric file */
+
+@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
+integers that give the lengths of the various subsequent portions
+of the file. These twelve integers are, in order:
+$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
+|lf|&length of the entire file, in words;\cr
+|lh|&length of the header data, in words;\cr
+|bc|&smallest character code in the font;\cr
+|ec|&largest character code in the font;\cr
+|nw|&number of words in the width table;\cr
+|nh|&number of words in the height table;\cr
+|nd|&number of words in the depth table;\cr
+|ni|&number of words in the italic correction table;\cr
+|nl|&number of words in the lig/kern table;\cr
+|nk|&number of words in the kern table;\cr
+|ne|&number of words in the extensible character table;\cr
+|np|&number of font parameter words.\cr}}$$
+They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
+|ne<=256|, and
+$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
+Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
+and as few as 0 characters (if |bc=ec+1|).
+
+Incidentally, when two or more 8-bit bytes are combined to form an integer of
+16 or more bits, the most significant bytes appear first in the file.
+This is called BigEndian order.
+@^BigEndian order@>
+
+@ The rest of the \.{TFM} file may be regarded as a sequence of ten data
+arrays.
+
+The most important data type used here is a |fix_word|, which is
+a 32-bit representation of a binary fraction. A |fix_word| is a signed
+quantity, with the two's complement of the entire word used to represent
+negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
+binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
+the smallest is $-2048$. We will see below, however, that all but two of
+the |fix_word| values must lie between $-16$ and $+16$.
+
+@ The first data array is a block of header information, which contains
+general facts about the font. The header must contain at least two words,
+|header[0]| and |header[1]|, whose meaning is explained below. Additional
+header information of use to other software routines might also be
+included, and \MP\ will generate it if the \.{headerbyte} command occurs.
+For example, 16 more words of header information are in use at the Xerox
+Palo Alto Research Center; the first ten specify the character coding
+scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
+give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
+last gives the ``face byte.''
+
+\yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
+the \.{GF} output file. This helps ensure consistency between files,
+since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
+should match the check sums on actual fonts that are used. The actual
+relation between this check sum and the rest of the \.{TFM} file is not
+important; the check sum is simply an identification number with the
+property that incompatible fonts almost always have distinct check sums.
+@^check sum@>
+
+\yskip\hang|header[1]| is a |fix_word| containing the design size of the
+font, in units of \TeX\ points. This number must be at least 1.0; it is
+fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
+font, i.e., a font that was designed to look best at a 10-point size,
+whatever that really means. When a \TeX\ user asks for a font `\.{at}
+$\delta$ \.{pt}', the effect is to override the design size and replace it
+by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
+the font image by a factor of $\delta$ divided by the design size. {\sl
+All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
+numbers in design-size units.} Thus, for example, the value of |param[6]|,
+which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
+since many fonts have a design size equal to one em. The other dimensions
+must be less than 16 design-size units in absolute value; thus,
+|header[1]| and |param[1]| are the only |fix_word| entries in the whole
+\.{TFM} file whose first byte might be something besides 0 or 255.
+@^design size@>
+
+@ Next comes the |char_info| array, which contains one |char_info_word|
+per character. Each word in this part of the file contains six fields
+packed into four bytes as follows.
+
+\yskip\hang first byte: |width_index| (8 bits)\par
+\hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
+ (4~bits)\par
+\hang third byte: |italic_index| (6 bits) times 4, plus |tag|
+ (2~bits)\par
+\hang fourth byte: |remainder| (8 bits)\par
+\yskip\noindent
+The actual width of a character is \\{width}|[width_index]|, in design-size
+units; this is a device for compressing information, since many characters
+have the same width. Since it is quite common for many characters
+to have the same height, depth, or italic correction, the \.{TFM} format
+imposes a limit of 16 different heights, 16 different depths, and
+64 different italic corrections.
+
+Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
+\\{italic}[0]=0$ should always hold, so that an index of zero implies a
+value of zero. The |width_index| should never be zero unless the
+character does not exist in the font, since a character is valid if and
+only if it lies between |bc| and |ec| and has a nonzero |width_index|.
+
+@ The |tag| field in a |char_info_word| has four values that explain how to
+interpret the |remainder| field.
+
+\yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
+\hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
+program starting at location |remainder| in the |lig_kern| array.\par
+\hang|tag=2| (|list_tag|) means that this character is part of a chain of
+characters of ascending sizes, and not the largest in the chain. The
+|remainder| field gives the character code of the next larger character.\par
+\hang|tag=3| (|ext_tag|) means that this character code represents an
+extensible character, i.e., a character that is built up of smaller pieces
+so that it can be made arbitrarily large. The pieces are specified in
+|exten[remainder]|.\par
+\yskip\noindent
+Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
+unless they are used in special circumstances in math formulas. For example,
+\TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
+operation looks for both |list_tag| and |ext_tag|.
+
+@d no_tag 0 /* vanilla character */
+@d lig_tag 1 /* character has a ligature/kerning program */
+@d list_tag 2 /* character has a successor in a charlist */
+@d ext_tag 3 /* character is extensible */
+
+@ The |lig_kern| array contains instructions in a simple programming language
+that explains what to do for special letter pairs. Each word in this array is a
+|lig_kern_command| of four bytes.
+
+\yskip\hang first byte: |skip_byte|, indicates that this is the final program
+ step if the byte is 128 or more, otherwise the next step is obtained by
+ skipping this number of intervening steps.\par
+\hang second byte: |next_char|, ``if |next_char| follows the current character,
+ then perform the operation and stop, otherwise continue.''\par
+\hang third byte: |op_byte|, indicates a ligature step if less than~128,
+ a kern step otherwise.\par
+\hang fourth byte: |remainder|.\par
+\yskip\noindent
+In a kern step, an
+additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
+between the current character and |next_char|. This amount is
+often negative, so that the characters are brought closer together
+by kerning; but it might be positive.
+
+There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
+$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
+|remainder| is inserted between the current character and |next_char|;
+then the current character is deleted if $b=0$, and |next_char| is
+deleted if $c=0$; then we pass over $a$~characters to reach the next
+current character (which may have a ligature/kerning program of its own).
+
+If the very first instruction of the |lig_kern| array has |skip_byte=255|,
+the |next_char| byte is the so-called right boundary character of this font;
+the value of |next_char| need not lie between |bc| and~|ec|.
+If the very last instruction of the |lig_kern| array has |skip_byte=255|,
+there is a special ligature/kerning program for a left boundary character,
+beginning at location |256*op_byte+remainder|.
+The interpretation is that \TeX\ puts implicit boundary characters
+before and after each consecutive string of characters from the same font.
+These implicit characters do not appear in the output, but they can affect
+ligatures and kerning.
+
+If the very first instruction of a character's |lig_kern| program has
+|skip_byte>128|, the program actually begins in location
+|256*op_byte+remainder|. This feature allows access to large |lig_kern|
+arrays, because the first instruction must otherwise
+appear in a location |<=255|.
+
+Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
+the condition
+$$\hbox{|256*op_byte+remainder<nl|.}$$
+If such an instruction is encountered during
+normal program execution, it denotes an unconditional halt; no ligature
+command is performed.
+
+@d stop_flag (128)
+ /* value indicating `\.{STOP}' in a lig/kern program */
+@d kern_flag (128) /* op code for a kern step */
+@d skip_byte(A) mp->lig_kern[(A)].b0
+@d next_char(A) mp->lig_kern[(A)].b1
+@d op_byte(A) mp->lig_kern[(A)].b2
+@d rem_byte(A) mp->lig_kern[(A)].b3
+
+@ Extensible characters are specified by an |extensible_recipe|, which
+consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
+order). These bytes are the character codes of individual pieces used to
+build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
+present in the built-up result. For example, an extensible vertical line is
+like an extensible bracket, except that the top and bottom pieces are missing.
+
+Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
+if the piece isn't present. Then the extensible characters have the form
+$TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
+in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
+The width of the extensible character is the width of $R$; and the
+height-plus-depth is the sum of the individual height-plus-depths of the
+components used, since the pieces are butted together in a vertical list.
+
+@d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
+@d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
+@d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
+@d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
+
+@ The final portion of a \.{TFM} file is the |param| array, which is another
+sequence of |fix_word| values.
+
+\yskip\hang|param[1]=slant| is the amount of italic slant, which is used
+to help position accents. For example, |slant=.25| means that when you go
+up one unit, you also go .25 units to the right. The |slant| is a pure
+number; it is the only |fix_word| other than the design size itself that is
+not scaled by the design size.
+@^design size@>
+
+\hang|param[2]=space| is the normal spacing between words in text.
+Note that character 040 in the font need not have anything to do with
+blank spaces.
+
+\hang|param[3]=space_stretch| is the amount of glue stretching between words.
+
+\hang|param[4]=space_shrink| is the amount of glue shrinking between words.
+
+\hang|param[5]=x_height| is the size of one ex in the font; it is also
+the height of letters for which accents don't have to be raised or lowered.
+
+\hang|param[6]=quad| is the size of one em in the font.
+
+\hang|param[7]=extra_space| is the amount added to |param[2]| at the
+ends of sentences.
+
+\yskip\noindent
+If fewer than seven parameters are present, \TeX\ sets the missing parameters
+to zero.
+
+@d slant_code 1
+@d space_code 2
+@d space_stretch_code 3
+@d space_shrink_code 4
+@d x_height_code 5
+@d quad_code 6
+@d extra_space_code 7
+
+@ So that is what \.{TFM} files hold. One of \MP's duties is to output such
+information, and it does this all at once at the end of a job.
+In order to prepare for such frenetic activity, it squirrels away the
+necessary facts in various arrays as information becomes available.
+
+Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
+are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
+|tfm_ital_corr|. Other information about a character (e.g., about
+its ligatures or successors) is accessible via the |char_tag| and
+|char_remainder| arrays. Other information about the font as a whole
+is kept in additional arrays called |header_byte|, |lig_kern|,
+|kern|, |exten|, and |param|.
+
+@d max_tfm_int 32510
+@d undefined_label max_tfm_int /* an undefined local label */
+
+@<Glob...@>=
+#define TFM_ITEMS 257
+eight_bits bc;
+eight_bits ec; /* smallest and largest character codes shipped out */
+scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
+scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
+scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
+scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
+boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
+int char_tag[TFM_ITEMS]; /* |remainder| category */
+int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
+char *header_byte; /* bytes of the \.{TFM} header */
+int header_last; /* last initialized \.{TFM} header byte */
+int header_size; /* size of the \.{TFM} header */
+four_quarters *lig_kern; /* the ligature/kern table */
+short nl; /* the number of ligature/kern steps so far */
+scaled *kern; /* distinct kerning amounts */
+short nk; /* the number of distinct kerns so far */
+four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
+short ne; /* the number of extensible characters so far */
+scaled *param; /* \&{fontinfo} parameters */
+short np; /* the largest \&{fontinfo} parameter specified so far */
+short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
+short skip_table[TFM_ITEMS]; /* local label status */
+boolean lk_started; /* has there been a lig/kern step in this command yet? */
+integer bchar; /* right boundary character */
+short bch_label; /* left boundary starting location */
+short ll;short lll; /* registers used for lig/kern processing */
+short label_loc[257]; /* lig/kern starting addresses */
+eight_bits label_char[257]; /* characters for |label_loc| */
+short label_ptr; /* highest position occupied in |label_loc| */
+
+@ @<Allocate or initialize ...@>=
+mp->header_last = 0; mp->header_size = 128; /* just for init */
+mp->header_byte = xmalloc(mp->header_size, sizeof(char));
+mp->lig_kern = NULL; /* allocated when needed */
+mp->kern = NULL; /* allocated when needed */
+mp->param = NULL; /* allocated when needed */
+
+@ @<Dealloc variables@>=
+xfree(mp->header_byte);
+xfree(mp->lig_kern);
+xfree(mp->kern);
+xfree(mp->param);
+
+@ @<Set init...@>=
+for (k=0;k<= 255;k++ ) {
+ mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
+ mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
+ mp->skip_table[k]=undefined_label;
+}
+memset(mp->header_byte,0,mp->header_size);
+mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
+mp->internal[mp_boundary_char]=-unity;
+mp->bch_label=undefined_label;
+mp->label_loc[0]=-1; mp->label_ptr=0;
+
+@ @<Declarations@>=
+scaled mp_tfm_check (MP mp,small_number m) ;
+
+@ @<Declare the function called |tfm_check|@>=
+scaled mp_tfm_check (MP mp,small_number m) {
+ if ( abs(mp->internal[m])>=fraction_half ) {
+ print_err("Enormous "); mp_print(mp, mp->int_name[m]);
+@.Enormous charwd...@>
+@.Enormous chardp...@>
+@.Enormous charht...@>
+@.Enormous charic...@>
+@.Enormous designsize...@>
+ mp_print(mp, " has been reduced");
+ help1("Font metric dimensions must be less than 2048pt.");
+ mp_put_get_error(mp);
+ if ( mp->internal[m]>0 ) return (fraction_half-1);
+ else return (1-fraction_half);
+ } else {
+ return mp->internal[m];
+ }
+}
+
+@ @<Store the width information for character code~|c|@>=
+if ( c<mp->bc ) mp->bc=c;
+if ( c>mp->ec ) mp->ec=c;
+mp->char_exists[c]=true;
+mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
+mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
+mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
+mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
+
+@ Now let's consider \MP's special \.{TFM}-oriented commands.
+
+@<Cases of |do_statement|...@>=
+case tfm_command: mp_do_tfm_command(mp); break;
+
+@ @d char_list_code 0
+@d lig_table_code 1
+@d extensible_code 2
+@d header_byte_code 3
+@d font_dimen_code 4
+
+@<Put each...@>=
+mp_primitive(mp, "charlist",tfm_command,char_list_code);
+@:char_list_}{\&{charlist} primitive@>
+mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
+@:lig_table_}{\&{ligtable} primitive@>
+mp_primitive(mp, "extensible",tfm_command,extensible_code);
+@:extensible_}{\&{extensible} primitive@>
+mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
+@:header_byte_}{\&{headerbyte} primitive@>
+mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
+@:font_dimen_}{\&{fontdimen} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case tfm_command:
+ switch (m) {
+ case char_list_code:mp_print(mp, "charlist"); break;
+ case lig_table_code:mp_print(mp, "ligtable"); break;
+ case extensible_code:mp_print(mp, "extensible"); break;
+ case header_byte_code:mp_print(mp, "headerbyte"); break;
+ default: mp_print(mp, "fontdimen"); break;
+ }
+ break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+eight_bits mp_get_code (MP mp) ;
+
+@ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
+ integer c; /* the code value found */
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type==mp_known ) {
+ c=mp_round_unscaled(mp, mp->cur_exp);
+ if ( c>=0 ) if ( c<256 ) return c;
+ } else if ( mp->cur_type==mp_string_type ) {
+ if ( length(mp->cur_exp)==1 ) {
+ c=mp->str_pool[mp->str_start[mp->cur_exp]];
+ return c;
+ }
+ }
+ exp_err("Invalid code has been replaced by 0");
+@.Invalid code...@>
+ help2("I was looking for a number between 0 and 255, or for a")
+ ("string of length 1. Didn't find it; will use 0 instead.");
+ mp_put_get_flush_error(mp, 0); c=0;
+ return c;
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
+
+@ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
+ if ( mp->char_tag[c]==no_tag ) {
+ mp->char_tag[c]=t; mp->char_remainder[c]=r;
+ if ( t==lig_tag ){
+ incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
+ mp->label_char[mp->label_ptr]=c;
+ }
+ } else {
+ @<Complain about a character tag conflict@>;
+ }
+}
+
+@ @<Complain about a character tag conflict@>=
+{
+ print_err("Character ");
+ if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
+ else if ( c==256 ) mp_print(mp, "||");
+ else { mp_print(mp, "code "); mp_print_int(mp, c); };
+ mp_print(mp, " is already ");
+@.Character c is already...@>
+ switch (mp->char_tag[c]) {
+ case lig_tag: mp_print(mp, "in a ligtable"); break;
+ case list_tag: mp_print(mp, "in a charlist"); break;
+ case ext_tag: mp_print(mp, "extensible"); break;
+ } /* there are no other cases */
+ help2("It's not legal to label a character more than once.")
+ ("So I'll not change anything just now.");
+ mp_put_get_error(mp);
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_tfm_command (MP mp) ;
+
+@ @c void mp_do_tfm_command (MP mp) {
+ int c,cc; /* character codes */
+ int k; /* index into the |kern| array */
+ int j; /* index into |header_byte| or |param| */
+ switch (mp->cur_mod) {
+ case char_list_code:
+ c=mp_get_code(mp);
+ /* we will store a list of character successors */
+ while ( mp->cur_cmd==colon ) {
+ cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
+ };
+ break;
+ case lig_table_code:
+ if (mp->lig_kern==NULL)
+ mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
+ if (mp->kern==NULL)
+ mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
+ @<Store a list of ligature/kern steps@>;
+ break;
+ case extensible_code:
+ @<Define an extensible recipe@>;
+ break;
+ case header_byte_code:
+ case font_dimen_code:
+ c=mp->cur_mod; mp_get_x_next(mp);
+ mp_scan_expression(mp);
+ if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
+ exp_err("Improper location");
+@.Improper location@>
+ help2("I was looking for a known, positive number.")
+ ("For safety's sake I'll ignore the present command.");
+ mp_put_get_error(mp);
+ } else {
+ j=mp_round_unscaled(mp, mp->cur_exp);
+ if ( mp->cur_cmd!=colon ) {
+ mp_missing_err(mp, ":");
+@.Missing `:'@>
+ help1("A colon should follow a headerbyte or fontinfo location.");
+ mp_back_error(mp);
+ }
+ if ( c==header_byte_code ) {
+ @<Store a list of header bytes@>;
+ } else {
+ if (mp->param==NULL)
+ mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
+ @<Store a list of font dimensions@>;
+ }
+ }
+ break;
+ } /* there are no other cases */
+}
+
+@ @<Store a list of ligature/kern steps@>=
+{
+ mp->lk_started=false;
+CONTINUE:
+ mp_get_x_next(mp);
+ if ((mp->cur_cmd==skip_to)&& mp->lk_started )
+ @<Process a |skip_to| command and |goto done|@>;
+ if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
+ else { mp_back_input(mp); c=mp_get_code(mp); };
+ if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
+ @<Record a label in a lig/kern subprogram and |goto continue|@>;
+ }
+ if ( mp->cur_cmd==lig_kern_token ) {
+ @<Compile a ligature/kern command@>;
+ } else {
+ print_err("Illegal ligtable step");
+@.Illegal ligtable step@>
+ help1("I was looking for `=:' or `kern' here.");
+ mp_back_error(mp); next_char(mp->nl)=qi(0);
+ op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
+ skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
+ }
+ if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
+ incr(mp->nl);
+ if ( mp->cur_cmd==comma ) goto CONTINUE;
+ if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
+}
+DONE:
+
+@ @<Put each...@>=
+mp_primitive(mp, "=:",lig_kern_token,0);
+@:=:_}{\.{=:} primitive@>
+mp_primitive(mp, "=:|",lig_kern_token,1);
+@:=:/_}{\.{=:\char'174} primitive@>
+mp_primitive(mp, "=:|>",lig_kern_token,5);
+@:=:/>_}{\.{=:\char'174>} primitive@>
+mp_primitive(mp, "|=:",lig_kern_token,2);
+@:=:/_}{\.{\char'174=:} primitive@>
+mp_primitive(mp, "|=:>",lig_kern_token,6);
+@:=:/>_}{\.{\char'174=:>} primitive@>
+mp_primitive(mp, "|=:|",lig_kern_token,3);
+@:=:/_}{\.{\char'174=:\char'174} primitive@>
+mp_primitive(mp, "|=:|>",lig_kern_token,7);
+@:=:/>_}{\.{\char'174=:\char'174>} primitive@>
+mp_primitive(mp, "|=:|>>",lig_kern_token,11);
+@:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
+mp_primitive(mp, "kern",lig_kern_token,128);
+@:kern_}{\&{kern} primitive@>
+
+@ @<Cases of |print_cmd...@>=
+case lig_kern_token:
+ switch (m) {
+ case 0:mp_print(mp, "=:"); break;
+ case 1:mp_print(mp, "=:|"); break;
+ case 2:mp_print(mp, "|=:"); break;
+ case 3:mp_print(mp, "|=:|"); break;
+ case 5:mp_print(mp, "=:|>"); break;
+ case 6:mp_print(mp, "|=:>"); break;
+ case 7:mp_print(mp, "|=:|>"); break;
+ case 11:mp_print(mp, "|=:|>>"); break;
+ default: mp_print(mp, "kern"); break;
+ }
+ break;
+
+@ Local labels are implemented by maintaining the |skip_table| array,
+where |skip_table[c]| is either |undefined_label| or the address of the
+most recent lig/kern instruction that skips to local label~|c|. In the
+latter case, the |skip_byte| in that instruction will (temporarily)
+be zero if there were no prior skips to this label, or it will be the
+distance to the prior skip.
+
+We may need to cancel skips that span more than 127 lig/kern steps.
+
+@d cancel_skips(A) mp->ll=(A);
+ do {
+ mp->lll=qo(skip_byte(mp->ll));
+ skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
+ } while (mp->lll!=0)
+@d skip_error(A) { print_err("Too far to skip");
+@.Too far to skip@>
+ help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
+ mp_error(mp); cancel_skips((A));
+ }
+
+@<Process a |skip_to| command and |goto done|@>=
+{
+ c=mp_get_code(mp);
+ if ( mp->nl-mp->skip_table[c]>128 ) {
+ skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
+ }
+ if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
+ else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
+ mp->skip_table[c]=mp->nl-1; goto DONE;
+}
+
+@ @<Record a label in a lig/kern subprogram and |goto continue|@>=
+{
+ if ( mp->cur_cmd==colon ) {
+ if ( c==256 ) mp->bch_label=mp->nl;
+ else mp_set_tag(mp, c,lig_tag,mp->nl);
+ } else if ( mp->skip_table[c]<undefined_label ) {
+ mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
+ do {
+ mp->lll=qo(skip_byte(mp->ll));
+ if ( mp->nl-mp->ll>128 ) {
+ skip_error(mp->ll); goto CONTINUE;
+ }
+ skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
+ } while (mp->lll!=0);
+ }
+ goto CONTINUE;
+}
+
+@ @<Compile a ligature/kern...@>=
+{
+ next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
+ if ( mp->cur_mod<128 ) { /* ligature op */
+ op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
+ } else {
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ) {
+ exp_err("Improper kern");
+@.Improper kern@>
+ help2("The amount of kern should be a known numeric value.")
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_put_get_flush_error(mp, 0);
+ }
+ mp->kern[mp->nk]=mp->cur_exp;
+ k=0;
+ while ( mp->kern[k]!=mp->cur_exp ) incr(k);
+ if ( k==mp->nk ) {
+ if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
+ incr(mp->nk);
+ }
+ op_byte(mp->nl)=kern_flag+(k / 256);
+ rem_byte(mp->nl)=qi((k % 256));
+ }
+ mp->lk_started=true;
+}
+
+@ @d missing_extensible_punctuation(A)
+ { mp_missing_err(mp, (A));
+@.Missing `\char`\#'@>
+ help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
+ }
+
+@<Define an extensible recipe@>=
+{
+ if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
+ c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
+ if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
+ ext_top(mp->ne)=qi(mp_get_code(mp));
+ if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
+ ext_mid(mp->ne)=qi(mp_get_code(mp));
+ if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
+ ext_bot(mp->ne)=qi(mp_get_code(mp));
+ if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
+ ext_rep(mp->ne)=qi(mp_get_code(mp));
+ incr(mp->ne);
+}
+
+@ The header could contain ASCII zeroes, so can't use |strdup|.
+
+@<Store a list of header bytes@>=
+do {
+ if ( j>=mp->header_size ) {
+ int l = mp->header_size + (mp->header_size >> 2);
+ char *t = xmalloc(l,sizeof(char));
+ memset(t,0,l);
+ memcpy(t,mp->header_byte,mp->header_size);
+ xfree (mp->header_byte);
+ mp->header_byte = t;
+ mp->header_size = l;
+ }
+ mp->header_byte[j]=mp_get_code(mp);
+ incr(j); incr(mp->header_last);
+} while (mp->cur_cmd==comma)
+
+@ @<Store a list of font dimensions@>=
+do {
+ if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
+ while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_known ){
+ exp_err("Improper font parameter");
+@.Improper font parameter@>
+ help1("I'm zeroing this one. Proceed, with fingers crossed.");
+ mp_put_get_flush_error(mp, 0);
+ }
+ mp->param[j]=mp->cur_exp; incr(j);
+} while (mp->cur_cmd==comma)
+
+@ OK: We've stored all the data that is needed for the \.{TFM} file.
+All that remains is to output it in the correct format.
+
+An interesting problem needs to be solved in this connection, because
+the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
+and 64~italic corrections. If the data has more distinct values than
+this, we want to meet the necessary restrictions by perturbing the
+given values as little as possible.
+
+\MP\ solves this problem in two steps. First the values of a given
+kind (widths, heights, depths, or italic corrections) are sorted;
+then the list of sorted values is perturbed, if necessary.
+
+The sorting operation is facilitated by having a special node of
+essentially infinite |value| at the end of the current list.
+
+@<Initialize table entries...@>=
+value(inf_val)=fraction_four;
+
+@ Straight linear insertion is good enough for sorting, since the lists
+are usually not terribly long. As we work on the data, the current list
+will start at |link(temp_head)| and end at |inf_val|; the nodes in this
+list will be in increasing order of their |value| fields.
+
+Given such a list, the |sort_in| function takes a value and returns a pointer
+to where that value can be found in the list. The value is inserted in
+the proper place, if necessary.
+
+At the time we need to do these operations, most of \MP's work has been
+completed, so we will have plenty of memory to play with. The value nodes
+that are allocated for sorting will never be returned to free storage.
+
+@d clear_the_list link(temp_head)=inf_val
+
+@c pointer mp_sort_in (MP mp,scaled v) {
+ pointer p,q,r; /* list manipulation registers */
+ p=temp_head;
+ while (1) {
+ q=link(p);
+ if ( v<=value(q) ) break;
+ p=q;
+ }
+ if ( v<value(q) ) {
+ r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
+ }
+ return link(p);
+}
+
+@ Now we come to the interesting part, where we reduce the list if necessary
+until it has the required size. The |min_cover| routine is basic to this
+process; it computes the minimum number~|m| such that the values of the
+current sorted list can be covered by |m|~intervals of width~|d|. It
+also sets the global value |perturbation| to the smallest value $d'>d$
+such that the covering found by this algorithm would be different.
+
+In particular, |min_cover(0)| returns the number of distinct values in the
+current list and sets |perturbation| to the minimum distance between
+adjacent values.
+
+@c integer mp_min_cover (MP mp,scaled d) {
+ pointer p; /* runs through the current list */
+ scaled l; /* the least element covered by the current interval */
+ integer m; /* lower bound on the size of the minimum cover */
+ m=0; p=link(temp_head); mp->perturbation=el_gordo;
+ while ( p!=inf_val ){
+ incr(m); l=value(p);
+ do { p=link(p); } while (value(p)<=l+d);
+ if ( value(p)-l<mp->perturbation )
+ mp->perturbation=value(p)-l;
+ }
+ return m;
+}
+
+@ @<Glob...@>=
+scaled perturbation; /* quantity related to \.{TFM} rounding */
+integer excess; /* the list is this much too long */
+
+@ The smallest |d| such that a given list can be covered with |m| intervals
+is determined by the |threshold| routine, which is sort of an inverse
+to |min_cover|. The idea is to increase the interval size rapidly until
+finding the range, then to go sequentially until the exact borderline has
+been discovered.
+
+@c scaled mp_threshold (MP mp,integer m) {
+ scaled d; /* lower bound on the smallest interval size */
+ mp->excess=mp_min_cover(mp, 0)-m;
+ if ( mp->excess<=0 ) {
+ return 0;
+ } else {
+ do {
+ d=mp->perturbation;
+ } while (mp_min_cover(mp, d+d)>m);
+ while ( mp_min_cover(mp, d)>m )
+ d=mp->perturbation;
+ return d;
+ }
+}
+
+@ The |skimp| procedure reduces the current list to at most |m| entries,
+by changing values if necessary. It also sets |info(p):=k| if |value(p)|
+is the |k|th distinct value on the resulting list, and it sets
+|perturbation| to the maximum amount by which a |value| field has
+been changed. The size of the resulting list is returned as the
+value of |skimp|.
+
+@c integer mp_skimp (MP mp,integer m) {
+ scaled d; /* the size of intervals being coalesced */
+ pointer p,q,r; /* list manipulation registers */
+ scaled l; /* the least value in the current interval */
+ scaled v; /* a compromise value */
+ d=mp_threshold(mp, m); mp->perturbation=0;
+ q=temp_head; m=0; p=link(temp_head);
+ while ( p!=inf_val ) {
+ incr(m); l=value(p); info(p)=m;
+ if ( value(link(p))<=l+d ) {
+ @<Replace an interval of values by its midpoint@>;
+ }
+ q=p; p=link(p);
+ }
+ return m;
+}
+
+@ @<Replace an interval...@>=
+{
+ do {
+ p=link(p); info(p)=m;
+ decr(mp->excess); if ( mp->excess==0 ) d=0;
+ } while (value(link(p))<=l+d);
+ v=l+halfp(value(p)-l);
+ if ( value(p)-v>mp->perturbation )
+ mp->perturbation=value(p)-v;
+ r=q;
+ do {
+ r=link(r); value(r)=v;
+ } while (r!=p);
+ link(q)=p; /* remove duplicate values from the current list */
+}
+
+@ A warning message is issued whenever something is perturbed by
+more than 1/16\thinspace pt.
+
+@c void mp_tfm_warning (MP mp,small_number m) {
+ mp_print_nl(mp, "(some ");
+ mp_print(mp, mp->int_name[m]);
+@.some charwds...@>
+@.some chardps...@>
+@.some charhts...@>
+@.some charics...@>
+ mp_print(mp, " values had to be adjusted by as much as ");
+ mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
+}
+
+@ Here's an example of how we use these routines.
+The width data needs to be perturbed only if there are 256 distinct
+widths, but \MP\ must check for this case even though it is
+highly unusual.
+
+An integer variable |k| will be defined when we use this code.
+The |dimen_head| array will contain pointers to the sorted
+lists of dimensions.
+
+@<Massage the \.{TFM} widths@>=
+clear_the_list;
+for (k=mp->bc;k<=mp->ec;k++) {
+ if ( mp->char_exists[k] )
+ mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
+}
+mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
+if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
+
+@ @<Glob...@>=
+pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
+
+@ Heights, depths, and italic corrections are different from widths
+not only because their list length is more severely restricted, but
+also because zero values do not need to be put into the lists.
+
+@<Massage the \.{TFM} heights, depths, and italic corrections@>=
+clear_the_list;
+for (k=mp->bc;k<=mp->ec;k++) {
+ if ( mp->char_exists[k] ) {
+ if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
+ else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
+ }
+}
+mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
+if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
+clear_the_list;
+for (k=mp->bc;k<=mp->ec;k++) {
+ if ( mp->char_exists[k] ) {
+ if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
+ else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
+ }
+}
+mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
+if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
+clear_the_list;
+for (k=mp->bc;k<=mp->ec;k++) {
+ if ( mp->char_exists[k] ) {
+ if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
+ else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
+ }
+}
+mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
+if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
+
+@ @<Initialize table entries...@>=
+value(zero_val)=0; info(zero_val)=0;
+
+@ Bytes 5--8 of the header are set to the design size, unless the user has
+some crazy reason for specifying them differently.
+@^design size@>
+
+Error messages are not allowed at the time this procedure is called,
+so a warning is printed instead.
+
+The value of |max_tfm_dimen| is calculated so that
+$$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
+ < \\{three\_bytes}.$$
+
+@d three_bytes 0100000000 /* $2^{24}$ */
+
+@c
+void mp_fix_design_size (MP mp) {
+ scaled d; /* the design size */
+ d=mp->internal[mp_design_size];
+ if ( (d<unity)||(d>=fraction_half) ) {
+ if ( d!=0 )
+ mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
+@.illegal design size...@>
+ d=040000000; mp->internal[mp_design_size]=d;
+ }
+ if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
+ if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
+ mp->header_byte[4]=d / 04000000;
+ mp->header_byte[5]=(d / 4096) % 256;
+ mp->header_byte[6]=(d / 16) % 256;
+ mp->header_byte[7]=(d % 16)*16;
+ };
+ mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
+ if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
+}
+
+@ The |dimen_out| procedure computes a |fix_word| relative to the
+design size. If the data was out of range, it is corrected and the
+global variable |tfm_changed| is increased by~one.
+
+@c integer mp_dimen_out (MP mp,scaled x) {
+ if ( abs(x)>mp->max_tfm_dimen ) {
+ incr(mp->tfm_changed);
+ if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
+ }
+ x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
+ return x;
+}
+
+@ @<Glob...@>=
+scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
+integer tfm_changed; /* the number of data entries that were out of bounds */
+
+@ If the user has not specified any of the first four header bytes,
+the |fix_check_sum| procedure replaces them by a ``check sum'' computed
+from the |tfm_width| data relative to the design size.
+@^check sum@>
+
+@c void mp_fix_check_sum (MP mp) {
+ eight_bits k; /* runs through character codes */
+ eight_bits B1,B2,B3,B4; /* bytes of the check sum */
+ integer x; /* hash value used in check sum computation */
+ if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
+ mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
+ @<Compute a check sum in |(b1,b2,b3,b4)|@>;
+ mp->header_byte[0]=B1; mp->header_byte[1]=B2;
+ mp->header_byte[2]=B3; mp->header_byte[3]=B4;
+ return;
+ }
+}
+
+@ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
+B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
+for (k=mp->bc;k<=mp->ec;k++) {
+ if ( mp->char_exists[k] ) {
+ x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
+ B1=(B1+B1+x) % 255;
+ B2=(B2+B2+x) % 253;
+ B3=(B3+B3+x) % 251;
+ B4=(B4+B4+x) % 247;
+ }
+}
+
+@ Finally we're ready to actually write the \.{TFM} information.
+Here are some utility routines for this purpose.
+
+@d tfm_out(A) do { /* output one byte to |tfm_file| */
+ unsigned char s=(A);
+ (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
+ } while (0)
+
+@c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
+ tfm_out(x / 256); tfm_out(x % 256);
+}
+void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
+ if ( x>=0 ) tfm_out(x / three_bytes);
+ else {
+ x=x+010000000000; /* use two's complement for negative values */
+ x=x+010000000000;
+ tfm_out((x / three_bytes) + 128);
+ };
+ x=x % three_bytes; tfm_out(x / unity);
+ x=x % unity; tfm_out(x / 0400);
+ tfm_out(x % 0400);
+}
+void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
+ tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
+ tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
+}
+
+@ @<Finish the \.{TFM} file@>=
+if ( mp->job_name==NULL ) mp_open_log_file(mp);
+mp_pack_job_name(mp, ".tfm");
+while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
+ mp_prompt_file_name(mp, "file name for font metrics",".tfm");
+mp->metric_file_name=xstrdup(mp->name_of_file);
+@<Output the subfile sizes and header bytes@>;
+@<Output the character information bytes, then
+ output the dimensions themselves@>;
+@<Output the ligature/kern program@>;
+@<Output the extensible character recipes and the font metric parameters@>;
+ if ( mp->internal[mp_tracing_stats]>0 )
+ @<Log the subfile sizes of the \.{TFM} file@>;
+mp_print_nl(mp, "Font metrics written on ");
+mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
+@.Font metrics written...@>
+(mp->close_file)(mp,mp->tfm_file)
+
+@ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
+this code.
+
+@<Output the subfile sizes and header bytes@>=
+k=mp->header_last;
+LH=(k+3) / 4; /* this is the number of header words */
+if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
+@<Compute the ligature/kern program offset and implant the
+ left boundary label@>;
+mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
+ +lk_offset+mp->nk+mp->ne+mp->np);
+ /* this is the total number of file words that will be output */
+mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
+mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
+mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
+mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
+mp_tfm_two(mp, mp->np);
+for (k=0;k< 4*LH;k++) {
+ tfm_out(mp->header_byte[k]);
+}
+
+@ @<Output the character information bytes...@>=
+for (k=mp->bc;k<=mp->ec;k++) {
+ if ( ! mp->char_exists[k] ) {
+ mp_tfm_four(mp, 0);
+ } else {
+ tfm_out(info(mp->tfm_width[k])); /* the width index */
+ tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
+ tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
+ tfm_out(mp->char_remainder[k]);
+ };
+}
+mp->tfm_changed=0;
+for (k=1;k<=4;k++) {
+ mp_tfm_four(mp, 0); p=mp->dimen_head[k];
+ while ( p!=inf_val ) {
+ mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
+ }
+}
+
+
+@ We need to output special instructions at the beginning of the
+|lig_kern| array in order to specify the right boundary character
+and/or to handle starting addresses that exceed 255. The |label_loc|
+and |label_char| arrays have been set up to record all the
+starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
+\le|label_loc|[|label_ptr]|$.
+
+@<Compute the ligature/kern program offset...@>=
+mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
+if ((mp->bchar<0)||(mp->bchar>255))
+ { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
+else { mp->lk_started=true; lk_offset=1; };
+@<Find the minimum |lk_offset| and adjust all remainders@>;
+if ( mp->bch_label<undefined_label )
+ { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
+ op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
+ rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
+ incr(mp->nl); /* possibly |nl=lig_table_size+1| */
+ }
+
+@ @<Find the minimum |lk_offset|...@>=
+k=mp->label_ptr; /* pointer to the largest unallocated label */
+if ( mp->label_loc[k]+lk_offset>255 ) {
+ lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
+ do {
+ mp->char_remainder[mp->label_char[k]]=lk_offset;
+ while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
+ decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
+ }
+ incr(lk_offset); decr(k);
+ } while (! (lk_offset+mp->label_loc[k]<256));
+ /* N.B.: |lk_offset=256| satisfies this when |k=0| */
+}
+if ( lk_offset>0 ) {
+ while ( k>0 ) {
+ mp->char_remainder[mp->label_char[k]]
+ =mp->char_remainder[mp->label_char[k]]+lk_offset;
+ decr(k);
+ }
+}
+
+@ @<Output the ligature/kern program@>=
+for (k=0;k<= 255;k++ ) {
+ if ( mp->skip_table[k]<undefined_label ) {
+ mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
+@.local label l:: was missing@>
+ cancel_skips(mp->skip_table[k]);
+ }
+}
+if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
+ tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
+} else {
+ for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
+ mp->ll=mp->label_loc[mp->label_ptr];
+ if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
+ else { tfm_out(255); tfm_out(mp->bchar); };
+ mp_tfm_two(mp, mp->ll+lk_offset);
+ do {
+ decr(mp->label_ptr);
+ } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
+ }
+}
+for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
+for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
+
+@ @<Output the extensible character recipes...@>=
+for (k=0;k<=mp->ne-1;k++)
+ mp_tfm_qqqq(mp, mp->exten[k]);
+for (k=1;k<=mp->np;k++) {
+ if ( k==1 ) {
+ if ( abs(mp->param[1])<fraction_half ) {
+ mp_tfm_four(mp, mp->param[1]*16);
+ } else {
+ incr(mp->tfm_changed);
+ if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
+ else mp_tfm_four(mp, -el_gordo);
+ }
+ } else {
+ mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
+ }
+}
+if ( mp->tfm_changed>0 ) {
+ if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
+@.a font metric dimension...@>
+ else {
+ mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
+@.font metric dimensions...@>
+ mp_print(mp, " font metric dimensions");
+ }
+ mp_print(mp, " had to be decreased)");
+}
+
+@ @<Log the subfile sizes of the \.{TFM} file@>=
+{
+ char s[200];
+ wlog_ln(" ");
+ if ( mp->bch_label<undefined_label ) decr(mp->nl);
+ snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
+ mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
+ wlog_ln(s);
+}
+
+@* \[43] Reading font metric data.
+
+\MP\ isn't a typesetting program but it does need to find the bounding box
+of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
+well as write them.
+
+@<Glob...@>=
+void * tfm_infile;
+
+@ All the width, height, and depth information is stored in an array called
+|font_info|. This array is allocated sequentially and each font is stored
+as a series of |char_info| words followed by the width, height, and depth
+tables. Since |font_name| entries are permanent, their |str_ref| values are
+set to |max_str_ref|.
+
+@<Types...@>=
+typedef unsigned int font_number; /* |0..font_max| */
+
+@ The |font_info| array is indexed via a group directory arrays.
+For example, the |char_info| data for character~|c| in font~|f| will be
+in |font_info[char_base[f]+c].qqqq|.
+
+@<Glob...@>=
+font_number font_max; /* maximum font number for included text fonts */
+size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
+memory_word *font_info; /* height, width, and depth data */
+char **font_enc_name; /* encoding names, if any */
+boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
+int next_fmem; /* next unused entry in |font_info| */
+font_number last_fnum; /* last font number used so far */
+scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
+char **font_name; /* name as specified in the \&{infont} command */
+char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
+font_number last_ps_fnum; /* last valid |font_ps_name| index */
+eight_bits *font_bc;
+eight_bits *font_ec; /* first and last character code */
+int *char_base; /* base address for |char_info| */
+int *width_base; /* index for zeroth character width */
+int *height_base; /* index for zeroth character height */
+int *depth_base; /* index for zeroth character depth */
+pointer *font_sizes;
+
+@ @<Allocate or initialize ...@>=
+mp->font_mem_size = 10000;
+mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
+memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
+mp->font_enc_name = NULL;
+mp->font_ps_name_fixed = NULL;
+mp->font_dsize = NULL;
+mp->font_name = NULL;
+mp->font_ps_name = NULL;
+mp->font_bc = NULL;
+mp->font_ec = NULL;
+mp->last_fnum = null_font;
+mp->char_base = NULL;
+mp->width_base = NULL;
+mp->height_base = NULL;
+mp->depth_base = NULL;
+mp->font_sizes = null;
+
+@ @<Dealloc variables@>=
+for (k=1;k<=(int)mp->last_fnum;k++) {
+ xfree(mp->font_enc_name[k]);
+ xfree(mp->font_name[k]);
+ xfree(mp->font_ps_name[k]);
+}
+xfree(mp->font_info);
+xfree(mp->font_enc_name);
+xfree(mp->font_ps_name_fixed);
+xfree(mp->font_dsize);
+xfree(mp->font_name);
+xfree(mp->font_ps_name);
+xfree(mp->font_bc);
+xfree(mp->font_ec);
+xfree(mp->char_base);
+xfree(mp->width_base);
+xfree(mp->height_base);
+xfree(mp->depth_base);
+xfree(mp->font_sizes);
+
+@
+@c
+void mp_reallocate_fonts (MP mp, font_number l) {
+ font_number f;
+ XREALLOC(mp->font_enc_name, l, char *);
+ XREALLOC(mp->font_ps_name_fixed, l, boolean);
+ XREALLOC(mp->font_dsize, l, scaled);
+ XREALLOC(mp->font_name, l, char *);
+ XREALLOC(mp->font_ps_name, l, char *);
+ XREALLOC(mp->font_bc, l, eight_bits);
+ XREALLOC(mp->font_ec, l, eight_bits);
+ XREALLOC(mp->char_base, l, int);
+ XREALLOC(mp->width_base, l, int);
+ XREALLOC(mp->height_base, l, int);
+ XREALLOC(mp->depth_base, l, int);
+ XREALLOC(mp->font_sizes, l, pointer);
+ for (f=(mp->last_fnum+1);f<=l;f++) {
+ mp->font_enc_name[f]=NULL;
+ mp->font_ps_name_fixed[f] = false;
+ mp->font_name[f]=NULL;
+ mp->font_ps_name[f]=NULL;
+ mp->font_sizes[f]=null;
+ }
+ mp->font_max = l;
+}
+
+@ @<Declare |mp_reallocate| functions@>=
+void mp_reallocate_fonts (MP mp, font_number l);
+
+
+@ A |null_font| containing no characters is useful for error recovery. Its
+|font_name| entry starts out empty but is reset each time an erroneous font is
+found. This helps to cut down on the number of duplicate error messages without
+wasting a lot of space.
+
+@d null_font 0 /* the |font_number| for an empty font */
+
+@<Set initial...@>=
+mp->font_dsize[null_font]=0;
+mp->font_bc[null_font]=1;
+mp->font_ec[null_font]=0;
+mp->char_base[null_font]=0;
+mp->width_base[null_font]=0;
+mp->height_base[null_font]=0;
+mp->depth_base[null_font]=0;
+mp->next_fmem=0;
+mp->last_fnum=null_font;
+mp->last_ps_fnum=null_font;
+mp->font_name[null_font]=(char *)"nullfont";
+mp->font_ps_name[null_font]=(char *)"";
+mp->font_ps_name_fixed[null_font] = false;
+mp->font_enc_name[null_font]=NULL;
+mp->font_sizes[null_font]=null;
+
+@ Each |char_info| word is of type |four_quarters|. The |b0| field contains
+the |width index|; the |b1| field contains the height
+index; the |b2| fields contains the depth index, and the |b3| field used only
+for temporary storage. (It is used to keep track of which characters occur in
+an edge structure that is being shipped out.)
+The corresponding words in the width, height, and depth tables are stored as
+|scaled| values in units of \ps\ points.
+
+With the macros below, the |char_info| word for character~|c| in font~|f| is
+|char_info(f)(c)| and the width is
+$$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
+
+@d char_info_end(A) (A)].qqqq
+@d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
+@d char_width_end(A) (A).b0].sc
+@d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
+@d char_height_end(A) (A).b1].sc
+@d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
+@d char_depth_end(A) (A).b2].sc
+@d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
+@d ichar_exists(A) ((A).b0>0)
+
+@ The |font_ps_name| for a built-in font should be what PostScript expects.
+A preliminary name is obtained here from the \.{TFM} name as given in the
+|fname| argument. This gets updated later from an external table if necessary.
+
+@<Declare text measuring subroutines@>=
+@<Declare subroutines for parsing file names@>
+font_number mp_read_font_info (MP mp, char *fname) {
+ boolean file_opened; /* has |tfm_infile| been opened? */
+ font_number n; /* the number to return */
+ halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
+ size_t whd_size; /* words needed for heights, widths, and depths */
+ int i,ii; /* |font_info| indices */
+ int jj; /* counts bytes to be ignored */
+ scaled z; /* used to compute the design size */
+ fraction d;
+ /* height, width, or depth as a fraction of design size times $2^{-8}$ */
+ eight_bits h_and_d; /* height and depth indices being unpacked */
+ unsigned char tfbyte; /* a byte read from the file */
+ n=null_font;
+ @<Open |tfm_infile| for input@>;
+ @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
+ otherwise |goto bad_tfm| or |goto done| as appropriate@>;
+BAD_TFM:
+ @<Complain that the \.{TFM} file is bad@>;
+DONE:
+ if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
+ if ( n!=null_font ) {
+ mp->font_ps_name[n]=mp_xstrdup(mp,fname);
+ mp->font_name[n]=mp_xstrdup(mp,fname);
+ }
+ return n;
+}
+
+@ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
+precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
+@.TFtoPL@> @.PLtoTF@>
+and \.{PLtoTF} can be used to debug \.{TFM} files.
+
+@<Complain that the \.{TFM} file is bad@>=
+print_err("Font ");
+mp_print(mp, fname);
+if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
+else mp_print(mp, " not usable: TFM file not found");
+help3("I wasn't able to read the size data for this font so this")
+ ("`infont' operation won't produce anything. If the font name")
+ ("is right, you might ask an expert to make a TFM file");
+if ( file_opened )
+ mp->help_line[0]="is right, try asking an expert to fix the TFM file";
+mp_error(mp)
+
+@ @<Read data from |tfm_infile|; if there is no room, say so...@>=
+@<Read the \.{TFM} size fields@>;
+@<Use the size fields to allocate space in |font_info|@>;
+@<Read the \.{TFM} header@>;
+@<Read the character data and the width, height, and depth tables and
+ |goto done|@>
+
+@ A bad \.{TFM} file can be shorter than it claims to be. The code given here
+might try to read past the end of the file if this happens. Changes will be
+needed if it causes a system error to refer to |tfm_infile^| or call
+|get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
+@^system dependencies@>
+of |tfget| could be changed to
+``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
+
+@d tfget do {
+ size_t wanted=1;
+ void *tfbyte_ptr = &tfbyte;
+ (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
+ if (wanted==0) goto BAD_TFM;
+} while (0)
+@d read_two(A) { (A)=tfbyte;
+ if ( (A)>127 ) goto BAD_TFM;
+ tfget; (A)=(A)*0400+tfbyte;
+}
+@d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
+
+@<Read the \.{TFM} size fields@>=
+tfget; read_two(lf);
+tfget; read_two(tfm_lh);
+tfget; read_two(bc);
+tfget; read_two(ec);
+if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
+tfget; read_two(nw);
+tfget; read_two(nh);
+tfget; read_two(nd);
+whd_size=(ec+1-bc)+nw+nh+nd;
+if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
+tf_ignore(10)
+
+@ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
+necessary to apply the |so| and |qo| macros when looking up the width of a
+character in the string pool. In order to ensure nonnegative |char_base|
+values when |bc>0|, it may be necessary to reserve a few unused |font_info|
+elements.
+
+@<Use the size fields to allocate space in |font_info|@>=
+if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
+if (mp->last_fnum==mp->font_max)
+ mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
+while (mp->next_fmem+whd_size>=mp->font_mem_size) {
+ size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
+ memory_word *font_info;
+ font_info = xmalloc ((l+1),sizeof(memory_word));
+ memset (font_info,0,sizeof(memory_word)*(l+1));
+ memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
+ xfree(mp->font_info);
+ mp->font_info = font_info;
+ mp->font_mem_size = l;
+}
+incr(mp->last_fnum);
+n=mp->last_fnum;
+mp->font_bc[n]=bc;
+mp->font_ec[n]=ec;
+mp->char_base[n]=mp->next_fmem-bc;
+mp->width_base[n]=mp->next_fmem+ec-bc+1;
+mp->height_base[n]=mp->width_base[n]+nw;
+mp->depth_base[n]=mp->height_base[n]+nh;
+mp->next_fmem=mp->next_fmem+whd_size;
+
+
+@ @<Read the \.{TFM} header@>=
+if ( tfm_lh<2 ) goto BAD_TFM;
+tf_ignore(4);
+tfget; read_two(z);
+tfget; z=z*0400+tfbyte;
+tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
+mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
+ /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
+tf_ignore(4*(tfm_lh-2))
+
+@ @<Read the character data and the width, height, and depth tables...@>=
+ii=mp->width_base[n];
+i=mp->char_base[n]+bc;
+while ( i<ii ) {
+ tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
+ tfget; h_and_d=tfbyte;
+ mp->font_info[i].qqqq.b1=h_and_d / 16;
+ mp->font_info[i].qqqq.b2=h_and_d % 16;
+ tfget; tfget;
+ incr(i);
+}
+while ( i<mp->next_fmem ) {
+ @<Read a four byte dimension, scale it by the design size, store it in
+ |font_info[i]|, and increment |i|@>;
+}
+goto DONE
+
+@ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
+interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
+we can multiply it by sixteen and think of it as a |fraction| that has been
+divided by sixteen. This cancels the extra scale factor contained in
+|font_dsize[n|.
+
+@<Read a four byte dimension, scale it by the design size, store it in...@>=
+{
+tfget; d=tfbyte;
+if ( d>=0200 ) d=d-0400;
+tfget; d=d*0400+tfbyte;
+tfget; d=d*0400+tfbyte;
+tfget; d=d*0400+tfbyte;
+mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
+incr(i);
+}
+
+@ This function does no longer use the file name parser, because |fname| is
+a C string already.
+@<Open |tfm_infile| for input@>=
+file_opened=false;
+mp_ptr_scan_file(mp, fname);
+if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
+if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
+pack_cur_name;
+mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
+if ( !mp->tfm_infile ) goto BAD_TFM;
+file_opened=true
+
+@ When we have a font name and we don't know whether it has been loaded yet,
+we scan the |font_name| array before calling |read_font_info|.
+
+@<Declare text measuring subroutines@>=
+font_number mp_find_font (MP mp, char *f) {
+ font_number n;
+ for (n=0;n<=mp->last_fnum;n++) {
+ if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
+ mp_xfree(f);
+ return n;
+ }
+ }
+ n = mp_read_font_info(mp, f);
+ mp_xfree(f);
+ return n;
+}
+
+@ One simple application of |find_font| is the implementation of the |font_size|
+operator that gets the design size for a given font name.
+
+@<Find the design size of the font whose name is |cur_exp|@>=
+mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
+
+@ If we discover that the font doesn't have a requested character, we omit it
+from the bounding box computation and expect the \ps\ interpreter to drop it.
+This routine issues a warning message if the user has asked for it.
+
+@<Declare text measuring subroutines@>=
+void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
+ if ( mp->internal[mp_tracing_lost_chars]>0 ) {
+ mp_begin_diagnostic(mp);
+ if ( mp->selector==log_only ) incr(mp->selector);
+ mp_print_nl(mp, "Missing character: There is no ");
+@.Missing character@>
+ mp_print_str(mp, mp->str_pool[k]);
+ mp_print(mp, " in font ");
+ mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
+ mp_end_diagnostic(mp, false);
+ }
+}
+
+@ The whole purpose of saving the height, width, and depth information is to be
+able to find the bounding box of an item of text in an edge structure. The
+|set_text_box| procedure takes a text node and adds this information.
+
+@<Declare text measuring subroutines@>=
+void mp_set_text_box (MP mp,pointer p) {
+ font_number f; /* |font_n(p)| */
+ ASCII_code bc,ec; /* range of valid characters for font |f| */
+ pool_pointer k,kk; /* current character and character to stop at */
+ four_quarters cc; /* the |char_info| for the current character */
+ scaled h,d; /* dimensions of the current character */
+ width_val(p)=0;
+ height_val(p)=-el_gordo;
+ depth_val(p)=-el_gordo;
+ f=font_n(p);
+ bc=mp->font_bc[f];
+ ec=mp->font_ec[f];
+ kk=str_stop(text_p(p));
+ k=mp->str_start[text_p(p)];
+ while ( k<kk ) {
+ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
+ }
+ @<Set the height and depth to zero if the bounding box is empty@>;
+}
+
+@ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
+{
+ if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
+ mp_lost_warning(mp, f,k);
+ } else {
+ cc=char_info(f)(mp->str_pool[k]);
+ if ( ! ichar_exists(cc) ) {
+ mp_lost_warning(mp, f,k);
+ } else {
+ width_val(p)=width_val(p)+char_width(f)(cc);
+ h=char_height(f)(cc);
+ d=char_depth(f)(cc);
+ if ( h>height_val(p) ) height_val(p)=h;
+ if ( d>depth_val(p) ) depth_val(p)=d;
+ }
+ }
+ incr(k);
+}
+
+@ Let's hope modern compilers do comparisons correctly when the difference would
+overflow.
+
+@<Set the height and depth to zero if the bounding box is empty@>=
+if ( height_val(p)<-depth_val(p) ) {
+ height_val(p)=0;
+ depth_val(p)=0;
+}
+
+@ The new primitives fontmapfile and fontmapline.
+
+@<Declare action procedures for use by |do_statement|@>=
+void mp_do_mapfile (MP mp) ;
+void mp_do_mapline (MP mp) ;
+
+@ @c void mp_do_mapfile (MP mp) {
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_string_type ) {
+ @<Complain about improper map operation@>;
+ } else {
+ mp_map_file(mp,mp->cur_exp);
+ }
+}
+void mp_do_mapline (MP mp) {
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_string_type ) {
+ @<Complain about improper map operation@>;
+ } else {
+ mp_map_line(mp,mp->cur_exp);
+ }
+}
+
+@ @<Complain about improper map operation@>=
+{
+ exp_err("Unsuitable expression");
+ help1("Only known strings can be map files or map lines.");
+ mp_put_get_error(mp);
+}
+
+@ To print |scaled| value to PDF output we need some subroutines to ensure
+accurary.
+
+@d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
+
+@<Glob...@>=
+scaled one_bp; /* scaled value corresponds to 1bp */
+scaled one_hundred_bp; /* scaled value corresponds to 100bp */
+scaled one_hundred_inch; /* scaled value corresponds to 100in */
+integer ten_pow[10]; /* $10^0..10^9$ */
+integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
+
+@ @<Set init...@>=
+mp->one_bp = 65782; /* 65781.76 */
+mp->one_hundred_bp = 6578176;
+mp->one_hundred_inch = 473628672;
+mp->ten_pow[0] = 1;
+for (i = 1;i<= 9; i++ ) {
+ mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
+}
+
+@ The following function divides |s| by |m|. |dd| is number of decimal digits.
+
+@c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
+ scaled q,r;
+ integer sign,i;
+ sign = 1;
+ if ( s < 0 ) { sign = -sign; s = -s; }
+ if ( m < 0 ) { sign = -sign; m = -m; }
+ if ( m == 0 )
+ mp_confusion(mp, "arithmetic: divided by zero");
+ else if ( m >= (max_integer / 10) )
+ mp_confusion(mp, "arithmetic: number too big");
+ q = s / m;
+ r = s % m;
+ for (i = 1;i<=dd;i++) {
+ q = 10*q + (10*r) / m;
+ r = (10*r) % m;
+ }
+ if ( 2*r >= m ) { incr(q); r = r - m; }
+ mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
+ return (sign*q);
+}
+
+@* \[44] Shipping pictures out.
+The |ship_out| procedure, to be described below, is given a pointer to
+an edge structure. Its mission is to output a file containing the \ps\
+description of an edge structure.
+
+@ Each time an edge structure is shipped out we write a new \ps\ output
+file named according to the current \&{charcode}.
+@:char_code_}{\&{charcode} primitive@>
+
+This is the only backend function that remains in the main |mpost.w| file.
+There are just too many variable accesses needed for status reporting
+etcetera to make it worthwile to move the code to |psout.w|.
+
+@<Internal library declarations@>=
+void mp_open_output_file (MP mp) ;
+
+@ @c
+char *mp_set_output_file_name (MP mp, integer c) {
+ char *ss = NULL; /* filename extension proposal */
+ int old_setting; /* previous |selector| setting */
+ pool_pointer i; /* indexes into |filename_template| */
+ integer cc; /* a temporary integer for template building */
+ integer f,g=0; /* field widths */
+ if ( mp->job_name==NULL ) mp_open_log_file(mp);
+ if ( mp->filename_template==0 ) {
+ char *s; /* a file extension derived from |c| */
+ if ( c<0 )
+ s=xstrdup(".ps");
+ else
+ @<Use |c| to compute the file extension |s|@>;
+ mp_pack_job_name(mp, s);
+ ss = s ;
+ } else { /* initializations */
+ str_number s, n; /* a file extension derived from |c| */
+ old_setting=mp->selector;
+ mp->selector=new_string;
+ f = 0;
+ i = mp->str_start[mp->filename_template];
+ n = rts(""); /* initialize */
+ while ( i<str_stop(mp->filename_template) ) {
+ if ( mp->str_pool[i]=='%' ) {
+ CONTINUE:
+ incr(i);
+ if ( i<str_stop(mp->filename_template) ) {
+ if ( mp->str_pool[i]=='j' ) {
+ mp_print(mp, mp->job_name);
+ } else if ( mp->str_pool[i]=='d' ) {
+ cc= mp_round_unscaled(mp, mp->internal[mp_day]);
+ print_with_leading_zeroes(cc);
+ } else if ( mp->str_pool[i]=='m' ) {
+ cc= mp_round_unscaled(mp, mp->internal[mp_month]);
+ print_with_leading_zeroes(cc);
+ } else if ( mp->str_pool[i]=='y' ) {
+ cc= mp_round_unscaled(mp, mp->internal[mp_year]);
+ print_with_leading_zeroes(cc);
+ } else if ( mp->str_pool[i]=='H' ) {
+ cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
+ print_with_leading_zeroes(cc);
+ } else if ( mp->str_pool[i]=='M' ) {
+ cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
+ print_with_leading_zeroes(cc);
+ } else if ( mp->str_pool[i]=='c' ) {
+ if ( c<0 ) mp_print(mp, "ps");
+ else print_with_leading_zeroes(c);
+ } else if ( (mp->str_pool[i]>='0') &&
+ (mp->str_pool[i]<='9') ) {
+ if ( (f<10) )
+ f = (f*10) + mp->str_pool[i]-'0';
+ goto CONTINUE;
+ } else {
+ mp_print_str(mp, mp->str_pool[i]);
+ }
+ }
+ } else {
+ if ( mp->str_pool[i]=='.' )
+ if (length(n)==0)
+ n = mp_make_string(mp);
+ mp_print_str(mp, mp->str_pool[i]);
+ };
+ incr(i);
+ };
+ s = mp_make_string(mp);
+ mp->selector= old_setting;
+ if (length(n)==0) {
+ n=s;
+ s=rts("");
+ };
+ mp_pack_file_name(mp, str(n),"",str(s));
+ delete_str_ref(n);
+ ss = str(s);
+ delete_str_ref(s);
+ }
+ return ss;
+}
+
+char * mp_get_output_file_name (MP mp) {
+ char *fname; /* return value */
+ char *saved_name; /* saved |name_of_file| */
+ saved_name = mp_xstrdup(mp, mp->name_of_file);
+ (void)mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]));
+ fname = mp_xstrdup(mp, mp->name_of_file);
+ mp_pack_file_name(mp, saved_name,NULL,NULL);
+ return fname;
+}
+
+void mp_open_output_file (MP mp) {
+ char *ss; /* filename extension proposal */
+ integer c; /* \&{charcode} rounded to the nearest integer */
+ c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
+ ss = mp_set_output_file_name(mp, c);
+ while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
+ mp_prompt_file_name(mp, "file name for output",ss);
+ xfree(ss);
+ @<Store the true output file name if appropriate@>;
+}
+
+@ The file extension created here could be up to five characters long in
+extreme cases so it may have to be shortened on some systems.
+@^system dependencies@>
+
+@<Use |c| to compute the file extension |s|@>=
+{
+ s = xmalloc(7,1);
+ snprintf(s,7,".%i",(int)c);
+}
+
+@ The user won't want to see all the output file names so we only save the
+first and last ones and a count of how many there were. For this purpose
+files are ordered primarily by \&{charcode} and secondarily by order of
+creation.
+@:char_code_}{\&{charcode} primitive@>
+
+@<Store the true output file name if appropriate@>=
+if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
+ mp->first_output_code=c;
+ xfree(mp->first_file_name);
+ mp->first_file_name=xstrdup(mp->name_of_file);
+}
+if ( c>=mp->last_output_code ) {
+ mp->last_output_code=c;
+ xfree(mp->last_file_name);
+ mp->last_file_name=xstrdup(mp->name_of_file);
+}
+
+@ @<Glob...@>=
+char * first_file_name;
+char * last_file_name; /* full file names */
+integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
+@:char_code_}{\&{charcode} primitive@>
+integer total_shipped; /* total number of |ship_out| operations completed */
+
+@ @<Set init...@>=
+mp->first_file_name=xstrdup("");
+mp->last_file_name=xstrdup("");
+mp->first_output_code=32768;
+mp->last_output_code=-32768;
+mp->total_shipped=0;
+
+@ @<Dealloc variables@>=
+xfree(mp->first_file_name);
+xfree(mp->last_file_name);
+
+@ @<Begin the progress report for the output of picture~|c|@>=
+if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
+else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
+mp_print_char(mp, '[');
+if ( c>=0 ) mp_print_int(mp, c)
+
+@ @<End progress report@>=
+mp_print_char(mp, ']');
+update_terminal;
+incr(mp->total_shipped)
+
+@ @<Explain what output files were written@>=
+if ( mp->total_shipped>0 ) {
+ mp_print_nl(mp, "");
+ mp_print_int(mp, mp->total_shipped);
+ mp_print(mp, " output file");
+ if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
+ mp_print(mp, " written: ");
+ mp_print(mp, mp->first_file_name);
+ if ( mp->total_shipped>1 ) {
+ if ( 31+strlen(mp->first_file_name)+
+ strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
+ mp_print_ln(mp);
+ mp_print(mp, " .. ");
+ mp_print(mp, mp->last_file_name);
+ }
+}
+
+@ @<Internal library declarations@>=
+boolean mp_has_font_size(MP mp, font_number f );
+
+@ @c
+boolean mp_has_font_size(MP mp, font_number f ) {
+ return (mp->font_sizes[f]!=null);
+}
+
+@ The \&{special} command saves up lines of text to be printed during the next
+|ship_out| operation. The saved items are stored as a list of capsule tokens.
+
+@<Glob...@>=
+pointer last_pending; /* the last token in a list of pending specials */
+
+@ @<Set init...@>=
+mp->last_pending=spec_head;
+
+@ @<Cases of |do_statement|...@>=
+case special_command:
+ if ( mp->cur_mod==0 ) mp_do_special(mp); else
+ if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
+ mp_do_mapline(mp);
+ break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+void mp_do_special (MP mp) ;
+
+@ @c void mp_do_special (MP mp) {
+ mp_get_x_next(mp); mp_scan_expression(mp);
+ if ( mp->cur_type!=mp_string_type ) {
+ @<Complain about improper special operation@>;
+ } else {
+ link(mp->last_pending)=mp_stash_cur_exp(mp);
+ mp->last_pending=link(mp->last_pending);
+ link(mp->last_pending)=null;
+ }
+}
+
+@ @<Complain about improper special operation@>=
+{
+ exp_err("Unsuitable expression");
+ help1("Only known strings are allowed for output as specials.");
+ mp_put_get_error(mp);
+}
+
+@ On the export side, we need an extra object type for special strings.
+
+@<Graphical object codes@>=
+mp_special_code=8,
+
+@ @<Export pending specials@>=
+p=link(spec_head);
+while ( p!=null ) {
+ mp_special_object *tp;
+ tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
+ gr_pre_script(tp) = str(value(p));
+ if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
+ else gr_link(hp) = (mp_graphic_object *)tp;
+ hp = (mp_graphic_object *)tp;
+ p=link(p);
+}
+mp_flush_token_list(mp, link(spec_head));
+link(spec_head)=null;
+mp->last_pending=spec_head
+
+@ We are now ready for the main output procedure. Note that the |selector|
+setting is saved in a global variable so that |begin_diagnostic| can access it.
+
+@<Declare the \ps\ output procedures@>=
+void mp_ship_out (MP mp, pointer h) ;
+
+@ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
+
+@d export_color(q,p)
+ if ( color_model(p)==mp_uninitialized_model ) {
+ gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
+ gr_cyan_val(q) = 0;
+ gr_magenta_val(q) = 0;
+ gr_yellow_val(q) = 0;
+ gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
+ } else {
+ gr_color_model(q) = color_model(p);
+ gr_cyan_val(q) = cyan_val(p);
+ gr_magenta_val(q) = magenta_val(p);
+ gr_yellow_val(q) = yellow_val(p);
+ gr_black_val(q) = black_val(p);
+ }
+
+@d export_scripts(q,p)
+ if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
+ if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
+
+@c
+struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
+ pointer p; /* the current graphical object */
+ integer t; /* a temporary value */
+ mp_edge_object *hh; /* the first graphical object */
+ struct mp_graphic_object *hq; /* something |hp| points to */
+ struct mp_text_object *tt;
+ struct mp_fill_object *tf;
+ struct mp_stroked_object *ts;
+ struct mp_clip_object *tc;
+ struct mp_bounds_object *tb;
+ struct mp_graphic_object *hp = NULL; /* the current graphical object */
+ mp_set_bbox(mp, h, true);
+ hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
+ hh->body = NULL;
+ hh->_next = NULL;
+ hh->_parent = mp;
+ hh->_minx = minx_val(h);
+ hh->_miny = miny_val(h);
+ hh->_maxx = maxx_val(h);
+ hh->_maxy = maxy_val(h);
+ hh->_filename = mp_get_output_file_name(mp);
+ @<Export pending specials@>;
+ p=link(dummy_loc(h));
+ while ( p!=null ) {
+ hq = mp_new_graphic_object(mp,type(p));
+ switch (type(p)) {
+ case mp_fill_code:
+ tf = (mp_fill_object *)hq;
+ gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
+ if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
+ gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
+ } else {
+ pointer pc, pp;
+ pc = mp_copy_path(mp, path_p(p));
+ pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
+ gr_path_p(tf) = mp_export_knot_list(mp,pp);
+ mp_toss_knot_list(mp, pp);
+ pc = mp_htap_ypoc(mp, path_p(p));
+ pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
+ gr_htap_p(tf) = mp_export_knot_list(mp,pp);
+ mp_toss_knot_list(mp, pp);
+ }
+ export_color(tf,p) ;
+ export_scripts(tf,p);
+ gr_ljoin_val(tf) = ljoin_val(p);
+ gr_miterlim_val(tf) = miterlim_val(p);
+ break;
+ case mp_stroked_code:
+ ts = (mp_stroked_object *)hq;
+ gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
+ if (pen_is_elliptical(pen_p(p))) {
+ gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
+ } else {
+ pointer pc;
+ pc=mp_copy_path(mp, path_p(p));
+ t=lcap_val(p);
+ if ( left_type(pc)!=mp_endpoint ) {
+ left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
+ right_type(pc)=mp_endpoint;
+ pc=link(pc);
+ t=1;
+ }
+ pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
+ gr_path_p(ts) = mp_export_knot_list(mp,pc);
+ mp_toss_knot_list(mp, pc);
+ }
+ export_color(ts,p) ;
+ export_scripts(ts,p);
+ gr_ljoin_val(ts) = ljoin_val(p);
+ gr_miterlim_val(ts) = miterlim_val(p);
+ gr_lcap_val(ts) = lcap_val(p);
+ gr_dash_p(ts) = mp_export_dashes(mp,dash_p(p));
+ break;
+ case mp_text_code:
+ tt = (mp_text_object *)hq;
+ gr_text_p(tt) = str(text_p(p));
+ gr_font_n(tt) = font_n(p);
+ gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
+ gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
+ export_color(tt,p) ;
+ export_scripts(tt,p);
+ gr_width_val(tt) = width_val(p);
+ gr_height_val(tt) = height_val(p);
+ gr_depth_val(tt) = depth_val(p);
+ gr_tx_val(tt) = tx_val(p);
+ gr_ty_val(tt) = ty_val(p);
+ gr_txx_val(tt) = txx_val(p);
+ gr_txy_val(tt) = txy_val(p);
+ gr_tyx_val(tt) = tyx_val(p);
+ gr_tyy_val(tt) = tyy_val(p);
+ break;
+ case mp_start_clip_code:
+ tc = (mp_clip_object *)hq;
+ gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
+ break;
+ case mp_start_bounds_code:
+ tb = (mp_bounds_object *)hq;
+ gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
+ break;
+ case mp_stop_clip_code:
+ case mp_stop_bounds_code:
+ /* nothing to do here */
+ break;
+ }
+ if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
+ hp = hq;
+ p=link(p);
+ }
+ return hh;
+}
+
+@ @<Exported function ...@>=
+struct mp_edge_object *mp_gr_export(MP mp, int h);
+
+@ This function is now nearly trivial.
+
+@c
+void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
+ integer c; /* \&{charcode} rounded to the nearest integer */
+ c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
+ @<Begin the progress report for the output of picture~|c|@>;
+ (mp->shipout_backend) (mp, h);
+ @<End progress report@>;
+ if ( mp->internal[mp_tracing_output]>0 )
+ mp_print_edges(mp, h," (just shipped out)",true);
+}
+
+@ @<Declarations@>=
+void mp_shipout_backend (MP mp, pointer h);
+
+@ @c
+void mp_shipout_backend (MP mp, pointer h) {
+ mp_edge_object *hh; /* the first graphical object */
+ hh = mp_gr_export(mp,h);
+ mp_gr_ship_out (hh,
+ (mp->internal[mp_prologues]>>16),
+ (mp->internal[mp_procset]>>16));
+ mp_gr_toss_objects(hh);
+}
+
+@ @<Exported types@>=
+typedef void (*mp_backend_writer)(MP, int);
+
+@ @<Option variables@>=
+mp_backend_writer shipout_backend;
+
+@ @<Allocate or initialize ...@>=
+set_callback_option(shipout_backend);
+
+@ Now that we've finished |ship_out|, let's look at the other commands
+by which a user can send things to the \.{GF} file.
+
+@ @<Determine if a character has been shipped out@>=
+{
+ mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
+ if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
+ boolean_reset(mp->char_exists[mp->cur_exp]);
+ mp->cur_type=mp_boolean_type;
+}
+
+@ @<Glob...@>=
+psout_data ps;
+
+@ @<Allocate or initialize ...@>=
+mp_backend_initialize(mp);
+
+@ @<Dealloc...@>=
+mp_backend_free(mp);
+
+
+@* \[45] Dumping and undumping the tables.
+After \.{INIMP} has seen a collection of macros, it
+can write all the necessary information on an auxiliary file so
+that production versions of \MP\ are able to initialize their
+memory at high speed. The present section of the program takes
+care of such output and input. We shall consider simultaneously
+the processes of storing and restoring,
+so that the inverse relation between them is clear.
+@.INIMP@>
+
+The global variable |mem_ident| is a string that is printed right
+after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
+string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
+for example, `\.{(mem=plain 1990.4.14)}', showing the year,
+month, and day that the mem file was created. We have |mem_ident=0|
+before \MP's tables are loaded.
+
+@<Glob...@>=
+char * mem_ident;
+
+@ @<Set init...@>=
+mp->mem_ident=NULL;
+
+@ @<Initialize table entries...@>=
+mp->mem_ident=xstrdup(" (INIMP)");
+
+@ @<Declare act...@>=
+void mp_store_mem_file (MP mp) ;
+
+@ @c void mp_store_mem_file (MP mp) {
+ integer k; /* all-purpose index */
+ pointer p,q; /* all-purpose pointers */
+ integer x; /* something to dump */
+ four_quarters w; /* four ASCII codes */
+ memory_word WW;
+ @<Create the |mem_ident|, open the mem file,
+ and inform the user that dumping has begun@>;
+ @<Dump constants for consistency check@>;
+ @<Dump the string pool@>;
+ @<Dump the dynamic memory@>;
+ @<Dump the table of equivalents and the hash table@>;
+ @<Dump a few more things and the closing check word@>;
+ @<Close the mem file@>;
+}
+
+@ Corresponding to the procedure that dumps a mem file, we also have a function
+that reads~one~in. The function returns |false| if the dumped mem is
+incompatible with the present \MP\ table sizes, etc.
+
+@d off_base 6666 /* go here if the mem file is unacceptable */
+@d too_small(A) { wake_up_terminal;
+ wterm_ln("---! Must increase the "); wterm((A));
+@.Must increase the x@>
+ goto OFF_BASE;
+ }
+
+@c
+boolean mp_load_mem_file (MP mp) {
+ integer k; /* all-purpose index */
+ pointer p,q; /* all-purpose pointers */
+ integer x; /* something undumped */
+ str_number s; /* some temporary string */
+ four_quarters w; /* four ASCII codes */
+ memory_word WW;
+ @<Undump constants for consistency check@>;
+ @<Undump the string pool@>;
+ @<Undump the dynamic memory@>;
+ @<Undump the table of equivalents and the hash table@>;
+ @<Undump a few more things and the closing check word@>;
+ return true; /* it worked! */
+OFF_BASE:
+ wake_up_terminal;
+ wterm_ln("(Fatal mem file error; I'm stymied)\n");
+@.Fatal mem file error@>
+ return false;
+}
+
+@ @<Declarations@>=
+boolean mp_load_mem_file (MP mp) ;
+
+@ Mem files consist of |memory_word| items, and we use the following
+macros to dump words of different types:
+
+@d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
+@d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
+@d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
+@d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
+@d dump_string(A) { dump_int(strlen(A)+1);
+ (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
+
+@<Glob...@>=
+void * mem_file; /* for input or output of mem information */
+
+@ The inverse macros are slightly more complicated, since we need to check
+the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
+read an integer value |x| that is supposed to be in the range |a<=x<=b|.
+
+@d mgeti(A) do {
+ size_t wanted = sizeof(A);
+ void *A_ptr = &A;
+ (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
+ if (wanted!=sizeof(A)) goto OFF_BASE;
+} while (0)
+
+@d mgetw(A) do {
+ size_t wanted = sizeof(A);
+ void *A_ptr = &A;
+ (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
+ if (wanted!=sizeof(A)) goto OFF_BASE;
+} while (0)
+
+@d undump_wd(A) { mgetw(WW); A=WW; }
+@d undump_int(A) { int cint; mgeti(cint); A=cint; }
+@d undump_hh(A) { mgetw(WW); A=WW.hh; }
+@d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
+@d undump_strings(A,B,C) {
+ undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
+@d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
+@d undump_size(A,B,C,D) { undump_int(x);
+ if (x<(A)) goto OFF_BASE;
+ if (x>(B)) { too_small((C)); } else { D=x;} }
+@d undump_string(A) do {
+ size_t the_wanted;
+ void *the_string;
+ integer XX=0;
+ undump_int(XX);
+ the_wanted = XX;
+ the_string = xmalloc(XX,sizeof(char));
+ (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
+ A = (char *)the_string;
+ if (the_wanted!=(size_t)XX) goto OFF_BASE;
+} while (0)
+
+@ The next few sections of the program should make it clear how we use the
+dump/undump macros.
+
+@<Dump constants for consistency check@>=
+dump_int(mp->mem_top);
+dump_int(mp->hash_size);
+dump_int(mp->hash_prime)
+dump_int(mp->param_size);
+dump_int(mp->max_in_open);
+
+@ Sections of a \.{WEB} program that are ``commented out'' still contribute
+strings to the string pool; therefore \.{INIMP} and \MP\ will have
+the same strings. (And it is, of course, a good thing that they do.)
+@.WEB@>
+@^string pool@>
+
+@<Undump constants for consistency check@>=
+undump_int(x); mp->mem_top = x;
+undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
+undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
+undump_int(x); if (mp->param_size != x) goto OFF_BASE;
+undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
+
+@ We do string pool compaction to avoid dumping unused strings.
+
+@d dump_four_ASCII
+ w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
+ w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
+ dump_qqqq(w)
+
+@<Dump the string pool@>=
+mp_do_compaction(mp, mp->pool_size);
+dump_int(mp->pool_ptr);
+dump_int(mp->max_str_ptr);
+dump_int(mp->str_ptr);
+k=0;
+while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
+ incr(k);
+dump_int(k);
+while ( k<=mp->max_str_ptr ) {
+ dump_int(mp->next_str[k]); incr(k);
+}
+k=0;
+while (1) {
+ dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
+ if ( k==mp->str_ptr ) {
+ break;
+ } else {
+ k=mp->next_str[k];
+ }
+}
+k=0;
+while (k+4<mp->pool_ptr ) {
+ dump_four_ASCII; k=k+4;
+}
+k=mp->pool_ptr-4; dump_four_ASCII;
+mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
+mp_print(mp, " strings of total length ");
+mp_print_int(mp, mp->pool_ptr)
+
+@ @d undump_four_ASCII
+ undump_qqqq(w);
+ mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
+ mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
+
+@<Undump the string pool@>=
+undump_int(mp->pool_ptr);
+mp_reallocate_pool(mp, mp->pool_ptr) ;
+undump_int(mp->max_str_ptr);
+mp_reallocate_strings (mp,mp->max_str_ptr) ;
+undump(0,mp->max_str_ptr,mp->str_ptr);
+undump(0,mp->max_str_ptr+1,s);
+for (k=0;k<=s-1;k++)
+ mp->next_str[k]=k+1;
+for (k=s;k<=mp->max_str_ptr;k++)
+ undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
+mp->fixed_str_use=0;
+k=0;
+while (1) {
+ undump(0,mp->pool_ptr,mp->str_start[k]);
+ if ( k==mp->str_ptr ) break;
+ mp->str_ref[k]=max_str_ref;
+ incr(mp->fixed_str_use);
+ mp->last_fixed_str=k; k=mp->next_str[k];
+}
+k=0;
+while ( k+4<mp->pool_ptr ) {
+ undump_four_ASCII; k=k+4;
+}
+k=mp->pool_ptr-4; undump_four_ASCII;
+mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
+mp->max_pool_ptr=mp->pool_ptr;
+mp->strs_used_up=mp->fixed_str_use;
+mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
+mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
+mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
+
+@ By sorting the list of available spaces in the variable-size portion of
+|mem|, we are usually able to get by without having to dump very much
+of the dynamic memory.
+
+We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
+information even when it has not been gathering statistics.
+
+@<Dump the dynamic memory@>=
+mp_sort_avail(mp); mp->var_used=0;
+dump_int(mp->lo_mem_max); dump_int(mp->rover);
+p=0; q=mp->rover; x=0;
+do {
+ for (k=p;k<= q+1;k++)
+ dump_wd(mp->mem[k]);
+ x=x+q+2-p; mp->var_used=mp->var_used+q-p;
+ p=q+node_size(q); q=rlink(q);
+} while (q!=mp->rover);
+mp->var_used=mp->var_used+mp->lo_mem_max-p;
+mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
+for (k=p;k<= mp->lo_mem_max;k++ )
+ dump_wd(mp->mem[k]);
+x=x+mp->lo_mem_max+1-p;
+dump_int(mp->hi_mem_min); dump_int(mp->avail);
+for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
+ dump_wd(mp->mem[k]);
+x=x+mp->mem_end+1-mp->hi_mem_min;
+p=mp->avail;
+while ( p!=null ) {
+ decr(mp->dyn_used); p=link(p);
+}
+dump_int(mp->var_used); dump_int(mp->dyn_used);
+mp_print_ln(mp); mp_print_int(mp, x);
+mp_print(mp, " memory locations dumped; current usage is ");
+mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
+
+@ @<Undump the dynamic memory@>=
+undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
+undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
+p=0; q=mp->rover;
+do {
+ for (k=p;k<= q+1; k++)
+ undump_wd(mp->mem[k]);
+ p=q+node_size(q);
+ if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
+ goto OFF_BASE;
+ q=rlink(q);
+} while (q!=mp->rover);
+for (k=p;k<=mp->lo_mem_max;k++ )
+ undump_wd(mp->mem[k]);
+undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
+undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
+for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
+ undump_wd(mp->mem[k]);
+undump_int(mp->var_used); undump_int(mp->dyn_used)
+
+@ A different scheme is used to compress the hash table, since its lower region
+is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
+words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
+packed for |p>=hash_used|, so the remaining entries are output in~a~block.
+
+@<Dump the table of equivalents and the hash table@>=
+dump_int(mp->hash_used);
+mp->st_count=frozen_inaccessible-1-mp->hash_used;
+for (p=1;p<=mp->hash_used;p++) {
+ if ( text(p)!=0 ) {
+ dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
+ }
+}
+for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
+ dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
+}
+dump_int(mp->st_count);
+mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
+
+@ @<Undump the table of equivalents and the hash table@>=
+undump(1,frozen_inaccessible,mp->hash_used);
+p=0;
+do {
+ undump(p+1,mp->hash_used,p);
+ undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
+} while (p!=mp->hash_used);
+for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
+ undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
+}
+undump_int(mp->st_count)
+
+@ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
+to prevent them appearing again.
+
+@<Dump a few more things and the closing check word@>=
+dump_int(mp->max_internal);
+dump_int(mp->int_ptr);
+for (k=1;k<= mp->int_ptr;k++ ) {
+ dump_int(mp->internal[k]);
+ dump_string(mp->int_name[k]);
+}
+dump_int(mp->start_sym);
+dump_int(mp->interaction);
+dump_string(mp->mem_ident);
+dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
+mp->internal[mp_tracing_stats]=0
+
+@ @<Undump a few more things and the closing check word@>=
+undump_int(x);
+if (x>mp->max_internal) mp_grow_internals(mp,x);
+undump_int(mp->int_ptr);
+for (k=1;k<= mp->int_ptr;k++) {
+ undump_int(mp->internal[k]);
+ undump_string(mp->int_name[k]);
+}
+undump(0,frozen_inaccessible,mp->start_sym);
+if (mp->interaction==mp_unspecified_mode) {
+ undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
+} else {
+ undump(mp_unspecified_mode,mp_error_stop_mode,x);
+}
+undump_string(mp->mem_ident);
+undump(1,hash_end,mp->bg_loc);
+undump(1,hash_end,mp->eg_loc);
+undump_int(mp->serial_no);
+undump_int(x);
+if (x!=69073) goto OFF_BASE
+
+@ @<Create the |mem_ident|...@>=
+{
+ xfree(mp->mem_ident);
+ mp->mem_ident = xmalloc(256,1);
+ snprintf(mp->mem_ident,256," (mem=%s %i.%i.%i)",
+ mp->job_name,
+ (int)(mp_round_unscaled(mp, mp->internal[mp_year]) % 100),
+ (int)mp_round_unscaled(mp, mp->internal[mp_month]),
+ (int)mp_round_unscaled(mp, mp->internal[mp_day]));
+ mp_pack_job_name(mp, mem_extension);
+ while (! mp_w_open_out(mp, &mp->mem_file) )
+ mp_prompt_file_name(mp, "mem file name", mem_extension);
+ mp_print_nl(mp, "Beginning to dump on file ");
+@.Beginning to dump...@>
+ mp_print(mp, mp->name_of_file);
+ mp_print_nl(mp, mp->mem_ident);
+}
+
+@ @<Dealloc variables@>=
+xfree(mp->mem_ident);
+
+@ @<Close the mem file@>=
+(mp->close_file)(mp,mp->mem_file)
+
+@* \[46] The main program.
+This is it: the part of \MP\ that executes all those procedures we have
+written.
+
+Well---almost. We haven't put the parsing subroutines into the
+program yet; and we'd better leave space for a few more routines that may
+have been forgotten.
+
+@c @<Declare the basic parsing subroutines@>
+@<Declare miscellaneous procedures that were declared |forward|@>
+@<Last-minute procedures@>
+
+@ We've noted that there are two versions of \MP. One, called \.{INIMP},
+@.INIMP@>
+has to be run first; it initializes everything from scratch, without
+reading a mem file, and it has the capability of dumping a mem file.
+The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
+@.VIRMP@>
+to input a mem file in order to get started. \.{VIRMP} typically has
+a bit more memory capacity than \.{INIMP}, because it does not need the
+space consumed by the dumping/undumping routines and the numerous calls on
+|primitive|, etc.
+
+The \.{VIRMP} program cannot read a mem file instantaneously, of course;
+the best implementations therefore allow for production versions of \MP\ that
+not only avoid the loading routine for object code, they also have
+a mem file pre-loaded.
+
+@ @<Option variables@>=
+int ini_version; /* are we iniMP? */
+
+@ @<Set |ini_version|@>=
+mp->ini_version = (opt->ini_version ? true : false);
+
+@ Here we do whatever is needed to complete \MP's job gracefully on the
+local operating system. The code here might come into play after a fatal
+error; it must therefore consist entirely of ``safe'' operations that
+cannot produce error messages. For example, it would be a mistake to call
+|str_room| or |make_string| at this time, because a call on |overflow|
+might lead to an infinite loop.
+@^system dependencies@>
+
+This program doesn't bother to close the input files that may still be open.
+
+@<Last-minute...@>=
+void mp_close_files_and_terminate (MP mp) {
+ integer k; /* all-purpose index */
+ integer LH; /* the length of the \.{TFM} header, in words */
+ int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
+ pointer p; /* runs through a list of \.{TFM} dimensions */
+ @<Close all open files in the |rd_file| and |wr_file| arrays@>;
+ if ( mp->internal[mp_tracing_stats]>0 )
+ @<Output statistics about this job@>;
+ wake_up_terminal;
+ @<Do all the finishing work on the \.{TFM} file@>;
+ @<Explain what output files were written@>;
+ if ( mp->log_opened ){
+ wlog_cr;
+ (mp->close_file)(mp,mp->log_file);
+ mp->selector=mp->selector-2;
+ if ( mp->selector==term_only ) {
+ mp_print_nl(mp, "Transcript written on ");
+@.Transcript written...@>
+ mp_print(mp, mp->log_name); mp_print_char(mp, '.');
+ }
+ }
+ mp_print_ln(mp);
+ t_close_out;
+ t_close_in;
+}
+
+@ @<Declarations@>=
+void mp_close_files_and_terminate (MP mp) ;
+
+@ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
+if (mp->rd_fname!=NULL) {
+ for (k=0;k<=(int)mp->read_files-1;k++ ) {
+ if ( mp->rd_fname[k]!=NULL ) {
+ (mp->close_file)(mp,mp->rd_file[k]);
+ }
+ }
+}
+if (mp->wr_fname!=NULL) {
+ for (k=0;k<=(int)mp->write_files-1;k++) {
+ if ( mp->wr_fname[k]!=NULL ) {
+ (mp->close_file)(mp,mp->wr_file[k]);
+ }
+ }
+}
+
+@ @<Dealloc ...@>=
+for (k=0;k<(int)mp->max_read_files;k++ ) {
+ if ( mp->rd_fname[k]!=NULL ) {
+ (mp->close_file)(mp,mp->rd_file[k]);
+ mp_xfree(mp->rd_fname[k]);
+ }
+}
+mp_xfree(mp->rd_file);
+mp_xfree(mp->rd_fname);
+for (k=0;k<(int)mp->max_write_files;k++) {
+ if ( mp->wr_fname[k]!=NULL ) {
+ (mp->close_file)(mp,mp->wr_file[k]);
+ mp_xfree(mp->wr_fname[k]);
+ }
+}
+mp_xfree(mp->wr_file);
+mp_xfree(mp->wr_fname);
+
+
+@ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
+
+We reclaim all of the variable-size memory at this point, so that
+there is no chance of another memory overflow after the memory capacity
+has already been exceeded.
+
+@<Do all the finishing work on the \.{TFM} file@>=
+if ( mp->internal[mp_fontmaking]>0 ) {
+ @<Make the dynamic memory into one big available node@>;
+ @<Massage the \.{TFM} widths@>;
+ mp_fix_design_size(mp); mp_fix_check_sum(mp);
+ @<Massage the \.{TFM} heights, depths, and italic corrections@>;
+ mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
+ @<Finish the \.{TFM} file@>;
+}
+
+@ @<Make the dynamic memory into one big available node@>=
+mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
+if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
+node_size(mp->rover)=mp->lo_mem_max-mp->rover;
+llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
+link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
+
+@ The present section goes directly to the log file instead of using
+|print| commands, because there's no need for these strings to take
+up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
+
+@<Output statistics...@>=
+if ( mp->log_opened ) {
+ char s[128];
+ wlog_ln(" ");
+ wlog_ln("Here is how much of MetaPost's memory you used:");
+@.Here is how much...@>
+ snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
+ (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
+ (int)(mp->max_strings-1-mp->init_str_use));
+ wlog_ln(s);
+ snprintf(s,128," %i string characters out of %i",
+ (int)mp->max_pl_used-mp->init_pool_ptr,
+ (int)mp->pool_size-mp->init_pool_ptr);
+ wlog_ln(s);
+ snprintf(s,128," %i words of memory out of %i",
+ (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
+ (int)mp->mem_end);
+ wlog_ln(s);
+ snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
+ wlog_ln(s);
+ snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
+ (int)mp->max_in_stack,(int)mp->int_ptr,
+ (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
+ (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
+ wlog_ln(s);
+ snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
+ (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
+ wlog_ln(s);
+}
+
+@ It is nice to have have some of the stats available from the API.
+
+@<Exported function ...@>=
+int mp_memory_usage (MP mp );
+int mp_hash_usage (MP mp );
+int mp_param_usage (MP mp );
+int mp_open_usage (MP mp );
+
+@ @c
+int mp_memory_usage (MP mp ) {
+ return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
+}
+int mp_hash_usage (MP mp ) {
+ return (int)mp->st_count;
+}
+int mp_param_usage (MP mp ) {
+ return (int)mp->max_param_stack;
+}
+int mp_open_usage (MP mp ) {
+ return (int)mp->max_in_stack;
+}
+
+@ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
+been scanned.
+
+@<Last-minute...@>=
+void mp_final_cleanup (MP mp) {
+ small_number c; /* 0 for \&{end}, 1 for \&{dump} */
+ c=mp->cur_mod;
+ if ( mp->job_name==NULL ) mp_open_log_file(mp);
+ while ( mp->input_ptr>0 ) {
+ if ( token_state ) mp_end_token_list(mp);
+ else mp_end_file_reading(mp);
+ }
+ while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
+ while ( mp->open_parens>0 ) {
+ mp_print(mp, " )"); decr(mp->open_parens);
+ };
+ while ( mp->cond_ptr!=null ) {
+ mp_print_nl(mp, "(end occurred when ");
+@.end occurred...@>
+ mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
+ /* `\.{if}' or `\.{elseif}' or `\.{else}' */
+ if ( mp->if_line!=0 ) {
+ mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
+ }
+ mp_print(mp, " was incomplete)");
+ mp->if_line=if_line_field(mp->cond_ptr);
+ mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
+ }
+ if ( mp->history!=mp_spotless )
+ if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
+ if ( mp->selector==term_and_log ) {
+ mp->selector=term_only;
+ mp_print_nl(mp, "(see the transcript file for additional information)");
+@.see the transcript file...@>
+ mp->selector=term_and_log;
+ }
+ if ( c==1 ) {
+ if (mp->ini_version) {
+ mp_store_mem_file(mp); return;
+ }
+ mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
+@.dump...only by INIMP@>
+ }
+}
+
+@ @<Declarations@>=
+void mp_final_cleanup (MP mp) ;
+void mp_init_prim (MP mp) ;
+void mp_init_tab (MP mp) ;
+
+@ @<Last-minute...@>=
+void mp_init_prim (MP mp) { /* initialize all the primitives */
+ @<Put each...@>;
+}
+@#
+void mp_init_tab (MP mp) { /* initialize other tables */
+ integer k; /* all-purpose index */
+ @<Initialize table entries (done by \.{INIMP} only)@>;
+}
+
+
+@ When we begin the following code, \MP's tables may still contain garbage;
+the strings might not even be present. Thus we must proceed cautiously to get
+bootstrapped in.
+
+But when we finish this part of the program, \MP\ is ready to call on the
+|main_control| routine to do its work.
+
+@<Get the first line...@>=
+{
+ @<Initialize the input routines@>;
+ if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
+ if ( mp->mem_ident!=NULL ) {
+ mp_do_initialize(mp); /* erase preloaded mem */
+ }
+ if ( ! mp_open_mem_file(mp) ) return mp_fatal_error_stop;
+ if ( ! mp_load_mem_file(mp) ) {
+ (mp->close_file)(mp, mp->mem_file);
+ return mp_fatal_error_stop;
+ }
+ (mp->close_file)(mp, mp->mem_file);
+ while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
+ }
+ mp->buffer[limit]='%';
+ mp_fix_date_and_time(mp);
+ if (mp->random_seed==0)
+ mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
+ mp_init_randoms(mp, mp->random_seed);
+ @<Initialize the print |selector|...@>;
+ if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
+ mp_start_input(mp); /* \&{input} assumed */
+}
+
+@ @<Run inimpost commands@>=
+{
+ mp_get_strings_started(mp);
+ mp_init_tab(mp); /* initialize the tables */
+ mp_init_prim(mp); /* call |primitive| for each primitive */
+ mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
+ mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
+ mp_fix_date_and_time(mp);
+}
+
+
+@* \[47] Debugging.
+Once \MP\ is working, you should be able to diagnose most errors with
+the \.{show} commands and other diagnostic features. But for the initial
+stages of debugging, and for the revelation of really deep mysteries, you
+can compile \MP\ with a few more aids. An additional routine called |debug_help|
+will also come into play when you type `\.D' after an error message;
+|debug_help| also occurs just before a fatal error causes \MP\ to succumb.
+@^debugging@>
+@^system dependencies@>
+
+The interface to |debug_help| is primitive, but it is good enough when used
+with a debugger that allows you to set breakpoints and to read
+variables and change their values. After getting the prompt `\.{debug \#}', you
+type either a negative number (this exits |debug_help|), or zero (this
+goes to a location where you can set a breakpoint, thereby entering into
+dialog with the debugger), or a positive number |m| followed by
+an argument |n|. The meaning of |m| and |n| will be clear from the
+program below. (If |m=13|, there is an additional argument, |l|.)
+@.debug \#@>
+
+@<Last-minute...@>=
+void mp_debug_help (MP mp) { /* routine to display various things */
+ integer k;
+ int l,m,n;
+ char *aline;
+ size_t len;
+ while (1) {
+ wake_up_terminal;
+ mp_print_nl(mp, "debug # (-1 to exit):"); update_terminal;
+@.debug \#@>
+ m = 0;
+ aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
+ if (len) { sscanf(aline,"%i",&m); xfree(aline); }
+ if ( m<=0 )
+ return;
+ n = 0 ;
+ aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
+ if (len) { sscanf(aline,"%i",&n); xfree(aline); }
+ switch (m) {
+ @<Numbered cases for |debug_help|@>;
+ default: mp_print(mp, "?"); break;
+ }
+ }
+}
+
+@ @<Numbered cases...@>=
+case 1: mp_print_word(mp, mp->mem[n]); /* display |mem[n]| in all forms */
+ break;
+case 2: mp_print_int(mp, info(n));
+ break;
+case 3: mp_print_int(mp, link(n));
+ break;
+case 4: mp_print_int(mp, eq_type(n)); mp_print_char(mp, ':'); mp_print_int(mp, equiv(n));
+ break;
+case 5: mp_print_variable_name(mp, n);
+ break;
+case 6: mp_print_int(mp, mp->internal[n]);
+ break;
+case 7: mp_do_show_dependencies(mp);
+ break;
+case 9: mp_show_token_list(mp, n,null,100000,0);
+ break;
+case 10: mp_print_str(mp, n);
+ break;
+case 11: mp_check_mem(mp, n>0); /* check wellformedness; print new busy locations if |n>0| */
+ break;
+case 12: mp_search_mem(mp, n); /* look for pointers to |n| */
+ break;
+case 13:
+ l = 0;
+ aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
+ if (len) { sscanf(aline,"%i",&l); xfree(aline); }
+ mp_print_cmd_mod(mp, n,l);
+ break;
+case 14: for (k=0;k<=n;k++) mp_print_str(mp, mp->buffer[k]);
+ break;
+case 15: mp->panicking=! mp->panicking;
+ break;
+
+
+@ Saving the filename template
+
+@<Save the filename template@>=
+{
+ if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
+ if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
+ else {
+ mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
+ }
+}
+
+@* \[48] System-dependent changes.
+This section should be replaced, if necessary, by any special
+modification of the program
+that are necessary to make \MP\ work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the published program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* \[49] Index.
+Here is where you can find all uses of each identifier in the program,
+with underlined entries pointing to where the identifier was defined.
+If the identifier is only one letter long, however, you get to see only
+the underlined entries. {\sl All references are to section numbers instead of
+page numbers.}
+
+This index also lists error messages and other aspects of the program
+that you might want to look up some day. For example, the entry
+for ``system dependencies'' lists all sections that should receive
+special attention from people who are installing \MP\ in a new
+operating environment. A list of various things that can't happen appears
+under ``this can't happen''.
+Approximately 25 sections are listed under ``inner loop''; these account
+for more than 60\pct! of \MP's running time, exclusive of input and output.
diff --git a/Build/source/texk/web2c/luatexdir/lua/psout.w b/Build/source/texk/web2c/luatexdir/lua/psout.w
new file mode 100644
index 00000000000..4a3f588ef7f
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/psout.w
@@ -0,0 +1,5697 @@
+% $Id: mp.web,v 1.8 2005/08/24 10:54:02 taco Exp $
+% MetaPost, by John Hobby. Public domain.
+
+% Much of this program was copied with permission from MF.web Version 1.9
+% It interprets a language very similar to D.E. Knuth's METAFONT, but with
+% changes designed to make it more suitable for PostScript output.
+
+% TeX is a trademark of the American Mathematical Society.
+% METAFONT is a trademark of Addison-Wesley Publishing Company.
+% PostScript is a trademark of Adobe Systems Incorporated.
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\noindent\ignorespaces}
+\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
+\def\PASCAL{Pascal}
+\def\ps{PostScript}
+\def\ph{\hbox{Pascal-H}}
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+\def\k{_{k+1}}
+\def\pct!{{\char`\%}} % percent sign in ordinary text
+\font\tenlogo=logo10 % font used for the METAFONT logo
+\font\logos=logosl10
+\def\MF{{\tenlogo META}\-{\tenlogo FONT}}
+\def\MP{{\tenlogo META}\-{\tenlogo POST}}
+\def\<#1>{$\langle#1\rangle$}
+\def\section{\mathhexbox278}
+\let\swap=\leftrightarrow
+\def\round{\mathop{\rm round}\nolimits}
+\mathchardef\vb="026A % synonym for `\|'
+\def\[#1]{} % from pascal web
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+
+\let\?=\relax % we want to be able to \write a \?
+
+\def\title{MetaPost \ps\ output}
+\def\topofcontents{\hsize 5.5in
+ \vglue -30pt plus 1fil minus 1.5in
+ \def\?##1]{\hbox to 1in{\hfil##1.\ }}
+ }
+\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
+\pdfoutput=1
+\pageno=3
+
+@
+@d true 1
+@d false 0
+@d null_font 0
+@d null 0
+@d unity 0200000 /* $2^{16}$, represents 1.00000 */
+@d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+@d negate(A) (A)=-(A) /* change the sign of a variable */
+@d odd(A) ((A)%2==1)
+@d half(A) ((A)/2)
+@d print_err(A) mp_print_err(mp,(A))
+@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
+
+@c
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#include "avl.h"
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+@h
+@<Declarations@>
+@<Static variables in the outer block@>
+
+@ There is a small bit of code from the backend that bleads through
+to the frontend because I do not know how to set up the includes
+properly. Those are the definitions of |struct libavl_allocator|
+and |typedef struct psout_data_struct * psout_data|.
+
+The |libavl_allocator| is a trick that makes sure that frontends
+do not need |avl.h|, and the |psout_data| is needed for the backend
+data structure.
+
+@ @(mppsout.h@>=
+@<Types...@>
+typedef struct psout_data_struct {
+ @<Globals@>
+} psout_data_struct ;
+@<Exported function headers@>
+
+@ @<Exported function headers@>=
+void mp_backend_initialize (MP mp) ;
+void mp_backend_free (MP mp) ;
+
+@
+@c void mp_backend_initialize (MP mp) {
+ mp->ps = mp_xmalloc(mp,1,sizeof(psout_data_struct));
+ @<Set initial values@>;
+}
+void mp_backend_free (MP mp) {
+ @<Dealloc variables@>;
+ enc_free(mp);
+ t1_free(mp);
+ fm_free(mp);
+ mp_xfree(mp->ps);
+ mp->ps = NULL;
+}
+
+@ Writing to ps files
+
+@<Globals@>=
+integer ps_offset;
+ /* the number of characters on the current \ps\ file line */
+
+@ @<Set initial values@>=
+mp->ps->ps_offset = 0;
+
+@
+
+@d wps(A) (mp->write_ascii_file)(mp,mp->ps_file,(A))
+@d wps_chr(A) do {
+ char ss[2];
+ ss[0]=(A); ss[1]=0;
+ (mp->write_ascii_file)(mp,mp->ps_file,(char *)ss);
+} while (0)
+@d wps_cr (mp->write_ascii_file)(mp,mp->ps_file,"\n")
+@d wps_ln(A) { wterm_cr; (mp->write_ascii_file)(mp,mp->ps_file,(A)); }
+
+@c
+void mp_ps_print_ln (MP mp) { /* prints an end-of-line */
+ wps_cr;
+ mp->ps->ps_offset=0;
+}
+
+@ @c
+void mp_ps_print_char (MP mp, ASCII_code s) { /* prints a single character */
+ if ( s==13 ) {
+ wps_cr; mp->ps->ps_offset=0;
+ } else {
+ wps_chr(s); incr(mp->ps->ps_offset);
+ }
+}
+
+@ @c
+void mp_ps_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
+ unsigned int j = 0;
+ while ( j<len ){
+ mp_ps_print_char(mp, ss[j]); incr(j);
+ }
+}
+
+@ Deciding where to break the ps output line.
+
+@d ps_room(A) if ( (mp->ps->ps_offset+(int)(A))>mp->max_print_line ) {
+ mp_ps_print_ln(mp); /* optional line break */
+}
+
+@c
+void mp_ps_print (MP mp, const char *ss) {
+ ps_room(strlen(ss));
+ mp_ps_do_print(mp, ss, strlen(ss));
+}
+
+@ The procedure |print_nl| is like |print|, but it makes sure that the
+string appears at the beginning of a new line.
+
+@c
+void mp_ps_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
+ if ( mp->ps->ps_offset>0 ) mp_ps_print_ln(mp);
+ mp_ps_print(mp, s);
+}
+
+@ An array of digits in the range |0..9| is printed by |print_the_digs|.
+
+@c
+void mp_ps_print_the_digs (MP mp, eight_bits k) {
+ /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
+ while ( k-->0 ){
+ mp_ps_print_char(mp, '0'+mp->dig[k]);
+ }
+}
+
+@ The following procedure, which prints out the decimal representation of a
+given integer |n|, has been written carefully so that it works properly
+if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div|
+to negative arguments, since such operations are not implemented consistently
+by all \PASCAL\ compilers.
+
+@c
+void mp_ps_print_int (MP mp,integer n) { /* prints an integer in decimal form */
+ integer m; /* used to negate |n| in possibly dangerous cases */
+ int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
+ if ( n<0 ) {
+ mp_ps_print_char(mp, '-');
+ if ( n>-100000000 ) {
+ negate(n);
+ } else {
+ m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
+ if ( m<10 ) {
+ mp->dig[0]=m;
+ } else {
+ mp->dig[0]=0; incr(n);
+ }
+ }
+ }
+ do {
+ mp->dig[k]=n % 10; n=n / 10; incr(k);
+ } while (n!=0);
+ mp_ps_print_the_digs(mp, k);
+}
+
+@ @<Internal ...@>=
+void mp_ps_print_int (MP mp,integer n);
+
+@ \MP\ also makes use of a trivial procedure to print two digits. The
+following subroutine is usually called with a parameter in the range |0<=n<=99|.
+
+@c
+void mp_ps_print_dd (MP mp,integer n) { /* prints two least significant digits */
+ n=abs(n) % 100;
+ mp_ps_print_char(mp, '0'+(n / 10));
+ mp_ps_print_char(mp, '0'+(n % 10));
+}
+
+@ Conversely, here is a procedure analogous to |print_int|. If the output
+of this procedure is subsequently read by \MP\ and converted by the
+|round_decimals| routine above, it turns out that the original value will
+be reproduced exactly. A decimal point is printed only if the value is
+not an integer. If there is more than one way to print the result with
+the optimum number of digits following the decimal point, the closest
+possible value is given.
+
+The invariant relation in the \&{repeat} loop is that a sequence of
+decimal digits yet to be printed will yield the original number if and only if
+they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
+We can stop if and only if $f=0$ satisfies this condition; the loop will
+terminate before $s$ can possibly become zero.
+
+@c
+void mp_ps_print_scaled (MP mp,scaled s) {
+ scaled delta; /* amount of allowable inaccuracy */
+ if ( s<0 ) {
+ mp_ps_print_char(mp, '-');
+ negate(s); /* print the sign, if negative */
+ }
+ mp_ps_print_int(mp, s / unity); /* print the integer part */
+ s=10*(s % unity)+5;
+ if ( s!=5 ) {
+ delta=10;
+ mp_ps_print_char(mp, '.');
+ do {
+ if ( delta>unity )
+ s=s+0100000-(delta / 2); /* round the final digit */
+ mp_ps_print_char(mp, '0'+(s / unity));
+ s=10*(s % unity);
+ delta=delta*10;
+ } while (s>delta);
+ }
+}
+
+
+@* \[44a] Dealing with font encodings.
+
+First, here are a few helpers for parsing files
+
+@d check_buf(size, buf_size)
+ if ((unsigned)(size) > (unsigned)(buf_size)) {
+ char S[128];
+ snprintf(S,128,"buffer overflow: (%d,%d) at file %s, line %d",
+ size,buf_size, __FILE__, __LINE__ );
+ mp_fatal_error(mp,S);
+ }
+
+@d append_char_to_buf(c, p, buf, buf_size) do {
+ if (c == 9)
+ c = 32;
+ if (c == 13 || c == EOF)
+ c = 10;
+ if (c != ' ' || (p > buf && p[-1] != 32)) {
+ check_buf(p - buf + 1, (buf_size));
+ *p++ = c;
+ }
+} while (0)
+
+@d append_eol(p, buf, buf_size) do {
+ check_buf(p - buf + 2, (buf_size));
+ if (p - buf > 1 && p[-1] != 10)
+ *p++ = 10;
+ if (p - buf > 2 && p[-2] == 32) {
+ p[-2] = 10;
+ p--;
+ }
+ *p = 0;
+} while (0)
+
+@d remove_eol(p, buf) do {
+ p = strend(buf) - 1;
+ if (*p == 10)
+ *p = 0;
+} while (0)
+
+@d skip(p, c) if (*p == c) p++
+@d strend(s) strchr(s, 0)
+@d str_prefix(s1, s2) (strncmp((s1), (s2), strlen(s2)) == 0)
+
+
+@ @<Types...@>=
+typedef struct {
+ boolean loaded; /* the encoding has been loaded? */
+ char *file_name; /* encoding file name */
+ char *enc_name; /* encoding true name */
+ integer objnum; /* object number */
+ char **glyph_names;
+ integer tounicode; /* object number of associated ToUnicode entry */
+} enc_entry;
+
+
+@
+
+@d ENC_STANDARD 0
+@d ENC_BUILTIN 1
+
+@<Glob...@>=
+#define ENC_BUF_SIZE 0x1000
+char enc_line[ENC_BUF_SIZE];
+void * enc_file;
+
+@
+@d enc_eof() (mp->eof_file)(mp,mp->ps->enc_file)
+@d enc_close() (mp->close_file)(mp,mp->ps->enc_file)
+
+@c
+int enc_getchar(MP mp) {
+ size_t len = 1;
+ unsigned char abyte=0;
+ void *byte_ptr = &abyte;
+ (mp->read_binary_file)(mp,mp->ps->enc_file,&byte_ptr,&len);
+ return abyte;
+}
+
+@ @c
+static boolean mp_enc_open (MP mp, char *n) {
+ mp->ps->enc_file=(mp->open_file)(mp,n, "r", mp_filetype_encoding);
+ if (mp->ps->enc_file!=NULL)
+ return true;
+ else
+ return false;
+}
+static void mp_enc_getline (MP mp) {
+ char *p;
+ int c;
+RESTART:
+ if (enc_eof ()) {
+ print_err("unexpected end of file");
+ mp_error(mp);
+ }
+ p = mp->ps->enc_line;
+ do {
+ c = enc_getchar (mp);
+ append_char_to_buf (c, p, mp->ps->enc_line, ENC_BUF_SIZE);
+ } while (c != 10);
+ append_eol (p, mp->ps->enc_line, ENC_BUF_SIZE);
+ if (p - mp->ps->enc_line < 2 || *mp->ps->enc_line == '%')
+ goto RESTART;
+}
+static void mp_load_enc (MP mp, char *enc_name,
+ char **enc_encname, char **glyph_names){
+ char buf[ENC_BUF_SIZE], *p, *r;
+ int names_count;
+ char *myname;
+ int save_selector = mp->selector;
+ if (!mp_enc_open (mp,enc_name)) {
+ mp_print (mp,"cannot open encoding file for reading");
+ return;
+ }
+ mp_normalize_selector(mp);
+ mp_print (mp,"{");
+ mp_print (mp, enc_name);
+ mp_enc_getline (mp);
+ if (*mp->ps->enc_line != '/' || (r = strchr (mp->ps->enc_line, '[')) == NULL) {
+ remove_eol (r, mp->ps->enc_line);
+ print_err ("invalid encoding vector (a name or `[' missing): `");
+ mp_print(mp,mp->ps->enc_line);
+ mp_print(mp,"'");
+ mp_error(mp);
+ }
+ while (*(r-1)==' ') r--; /* strip trailing spaces from encoding name */
+ myname = mp_xmalloc(mp,r-mp->ps->enc_line,1);
+ memcpy(myname,mp->ps->enc_line+1,(r-mp->ps->enc_line)-1);
+ *(myname+(r-mp->ps->enc_line-1))=0;
+ *enc_encname = myname;
+ while (*r!='[') r++;
+ r++; /* skip '[' */
+ names_count = 0;
+ skip (r, ' ');
+ for (;;) {
+ while (*r == '/') {
+ for (p = buf, r++;
+ *r != ' ' && *r != 10 && *r != ']' && *r != '/'; *p++ = *r++);
+ *p = 0;
+ skip (r, ' ');
+ if (names_count > 256) {
+ print_err ("encoding vector contains more than 256 names");
+ mp_error(mp);
+ }
+ if (mp_xstrcmp (buf, notdef) != 0)
+ glyph_names[names_count] = mp_xstrdup (mp,buf);
+ names_count++;
+ }
+ if (*r != 10 && *r != '%') {
+ if (str_prefix (r, "] def"))
+ goto DONE;
+ else {
+ remove_eol (r, mp->ps->enc_line);
+ print_err
+ ("invalid encoding vector: a name or `] def' expected: `");
+ mp_print(mp,mp->ps->enc_line);
+ mp_print(mp,"'");
+ mp_error(mp);
+ }
+ }
+ mp_enc_getline (mp);
+ r = mp->ps->enc_line;
+ }
+DONE:
+ enc_close ();
+ mp_print (mp,"}");
+ mp->selector = save_selector;
+}
+static void mp_read_enc (MP mp, enc_entry * e) {
+ if (e->loaded)
+ return;
+ e->enc_name = NULL;
+ mp_load_enc (mp,e->file_name, &e->enc_name, e->glyph_names);
+ e->loaded = true;
+}
+
+@ |write_enc| is used to write either external encoding (given in map file) or
+ internal encoding (read from the font file);
+ the 2nd argument is a pointer to the encoding entry;
+
+@c
+static void mp_write_enc (MP mp, enc_entry * e) {
+ int i;
+ int s;
+ int foffset;
+ char **g;
+ if (e->objnum != 0) /* the encoding has been written already */
+ return;
+ e->objnum = 1;
+ g = e->glyph_names;
+
+ mp_ps_print(mp,"\n%%%%BeginResource: encoding ");
+ mp_ps_print(mp, e->enc_name);
+ mp_ps_print_nl(mp, "/");
+ mp_ps_print(mp, e->enc_name);
+ mp_ps_print(mp, " [ ");
+ foffset = strlen(e->file_name)+3;
+ for (i = 0; i < 256; i++) {
+ s = strlen(g[i]);
+ if (s+1+foffset>=80) {
+ mp_ps_print_ln (mp);
+ foffset = 0;
+ }
+ foffset += s+2;
+ mp_ps_print_char(mp,'/');
+ mp_ps_print(mp, g[i]);
+ mp_ps_print_char(mp,' ');
+ }
+ if (foffset>75)
+ mp_ps_print_ln (mp);
+ mp_ps_print_nl (mp,"] def\n");
+ mp_ps_print(mp,"%%%%EndResource");
+}
+
+
+@ All encoding entries go into AVL tree for fast search by name.
+
+@<Glob...@>=
+struct avl_table *enc_tree;
+
+@ Memory management functions for avl
+
+@<Static variables in the outer block@>=
+static const char notdef[] = ".notdef";
+
+@ @<Declarations@>=
+static void *avl_xmalloc (struct libavl_allocator *allocator, size_t size);
+static void avl_xfree (struct libavl_allocator *allocator, void *block);
+
+@ @c
+static void *avl_xmalloc (struct libavl_allocator *allocator, size_t size) {
+ (void)allocator;
+ return malloc (size);
+}
+static void avl_xfree (struct libavl_allocator *allocator, void *block) {
+ (void)allocator;
+ free (block);
+}
+
+@ @<Glob...@>=
+struct libavl_allocator avl_xallocator;
+
+@ @<Set initial...@>=
+mp->ps->avl_xallocator.libavl_malloc=avl_xmalloc;
+mp->ps->avl_xallocator.libavl_free= avl_xfree;
+mp->ps->enc_tree = NULL;
+
+@ @c
+static int comp_enc_entry (const void *pa, const void *pb, void *p) {
+ (void)p;
+ return strcmp (((const enc_entry *) pa)->file_name,
+ ((const enc_entry *) pb)->file_name);
+}
+static enc_entry * mp_add_enc (MP mp, char *s) {
+ int i;
+ enc_entry tmp, *p;
+ void **aa;
+ if (mp->ps->enc_tree == NULL) {
+ mp->ps->enc_tree = avl_create (comp_enc_entry, NULL, &mp->ps->avl_xallocator);
+ }
+ tmp.file_name = s;
+ p = (enc_entry *) avl_find (mp->ps->enc_tree, &tmp);
+ if (p != NULL) /* encoding already registered */
+ return p;
+ p = mp_xmalloc (mp,1,sizeof (enc_entry));
+ p->loaded = false;
+ p->file_name = mp_xstrdup (mp,s);
+ p->objnum = 0;
+ p->tounicode = 0;
+ p->glyph_names = mp_xmalloc (mp,256,sizeof (char *));
+ for (i = 0; i < 256; i++)
+ p->glyph_names[i] = (char *) notdef;
+ aa = avl_probe (mp->ps->enc_tree, p);
+ return p;
+}
+
+@ cleaning up...
+
+@c
+static void mp_destroy_enc_entry (void *pa, void *pb) {
+ enc_entry *p;
+ int i;
+ p = (enc_entry *) pa;
+ (void)pb;
+ mp_xfree (p->file_name);
+ if (p->glyph_names != NULL)
+ for (i = 0; i < 256; i++)
+ if (p->glyph_names[i] != notdef)
+ mp_xfree (p->glyph_names[i]);
+ mp_xfree (p->glyph_names);
+ mp_xfree (p);
+}
+
+@ @<Declarations@>=
+static void enc_free (MP mp);
+
+@ @c static void enc_free (MP mp) {
+ if (mp->ps->enc_tree != NULL)
+ avl_destroy (mp->ps->enc_tree, mp_destroy_enc_entry);
+}
+
+@ @<Exported function headers@>=
+void mp_reload_encodings (MP mp) ;
+
+@ @<Declarations@>=
+static void mp_font_encodings (MP mp, int lastfnum, int encodings_only) ;
+
+@ @c void mp_reload_encodings (MP mp) {
+ int f;
+ enc_entry *e;
+ fm_entry *fm_cur;
+ int lastfnum = mp->last_fnum;
+ for (f=null_font+1;f<=lastfnum;f++) {
+ if (mp->font_enc_name[f]!=NULL ) {
+ mp_xfree(mp->font_enc_name[f]);
+ mp->font_enc_name[f]=NULL;
+ }
+ if (mp_has_fm_entry (mp,f,&fm_cur)) {
+ if (fm_cur != NULL && fm_cur->ps_name != NULL &&is_reencoded (fm_cur)) {
+ e = fm_cur->encoding;
+ mp_read_enc (mp,e);
+ }
+ }
+ }
+}
+static void mp_font_encodings (MP mp, int lastfnum, int encodings_only) {
+ int f;
+ enc_entry *e;
+ fm_entry *fm;
+ for (f=null_font+1;f<=lastfnum;f++) {
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp,f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (is_reencoded (fm)) {
+ if (encodings_only || (!is_subsetted (fm))) {
+ e = fm->encoding;
+ mp_write_enc (mp, e);
+ /* clear for next run */
+ e->objnum = 0;
+ }
+ }
+ }
+ }
+ }
+}
+
+@* \[44b] Parsing font map files.
+
+@d FM_BUF_SIZE 1024
+
+@<Glob...@>=
+void * fm_file;
+
+@
+@d fm_close() (mp->close_file)(mp,mp->ps->fm_file)
+@d fm_eof() (mp->eof_file)(mp,mp->ps->fm_file)
+
+@c
+int fm_getchar(MP mp) {
+ size_t len = 1;
+ unsigned char abyte=0;
+ void *byte_ptr = &abyte;
+ (mp->read_binary_file)(mp,mp->ps->fm_file,&byte_ptr,&len);
+ if (len==0)
+ return EOF;
+ return abyte;
+}
+
+
+@ @<Types...@>=
+enum _mode { FM_DUPIGNORE, FM_REPLACE, FM_DELETE };
+enum _ltype { MAPFILE, MAPLINE };
+enum _tfmavail { TFM_UNCHECKED, TFM_FOUND, TFM_NOTFOUND };
+typedef struct mitem {
+ int mode; /* |FM_DUPIGNORE| or |FM_REPLACE| or |FM_DELETE| */
+ int type; /* map file or map line */
+ char *map_line; /* pointer to map file name or map line */
+ int lineno; /* line number in map file */
+} mapitem;
+
+@ @<Glob...@>=
+mapitem *mitem;
+fm_entry *fm_cur;
+fm_entry *loaded_tfm_found;
+fm_entry *avail_tfm_found;
+fm_entry *non_tfm_found;
+fm_entry *not_avail_tfm_found;
+
+@ @<Set initial...@>=
+mp->ps->mitem = NULL;
+
+@ @<Declarations@>=
+static const char nontfm[] = "<nontfm>";
+
+@
+@d read_field(r, q, buf) do {
+ q = buf;
+ while (*r != ' ' && *r != '\0')
+ *q++ = *r++;
+ *q = '\0';
+ skip (r, ' ');
+} while (0)
+
+@d set_field(F) do {
+ if (q > buf)
+ fm->F = mp_xstrdup(mp,buf);
+ if (*r == '\0')
+ goto DONE;
+} while (0)
+
+@d cmp_return(a, b)
+ if (a > b)
+ return 1;
+ if (a < b)
+ return -1
+
+@c
+static fm_entry *new_fm_entry (MP mp) {
+ fm_entry *fm;
+ fm = mp_xmalloc (mp,1,sizeof(fm_entry));
+ fm->tfm_name = NULL;
+ fm->ps_name = NULL;
+ fm->flags = 4;
+ fm->ff_name = NULL;
+ fm->subset_tag = NULL;
+ fm->encoding = NULL;
+ fm->tfm_num = null_font;
+ fm->tfm_avail = TFM_UNCHECKED;
+ fm->type = 0;
+ fm->slant = 0;
+ fm->extend = 0;
+ fm->ff_objnum = 0;
+ fm->fn_objnum = 0;
+ fm->fd_objnum = 0;
+ fm->charset = NULL;
+ fm->all_glyphs = false;
+ fm->links = 0;
+ fm->pid = -1;
+ fm->eid = -1;
+ return fm;
+}
+
+static void delete_fm_entry (fm_entry * fm) {
+ mp_xfree (fm->tfm_name);
+ mp_xfree (fm->ps_name);
+ mp_xfree (fm->ff_name);
+ mp_xfree (fm->subset_tag);
+ mp_xfree (fm->charset);
+ mp_xfree (fm);
+}
+
+static ff_entry *new_ff_entry (MP mp) {
+ ff_entry *ff;
+ ff = mp_xmalloc (mp,1,sizeof(ff_entry));
+ ff->ff_name = NULL;
+ ff->ff_path = NULL;
+ return ff;
+}
+
+static void delete_ff_entry (ff_entry * ff) {
+ mp_xfree (ff->ff_name);
+ mp_xfree (ff->ff_path);
+ mp_xfree (ff);
+}
+
+static char *mk_base_tfm (MP mp, char *tfmname, int *i) {
+ static char buf[SMALL_BUF_SIZE];
+ char *p = tfmname, *r = strend (p) - 1, *q = r;
+ while (q > p && isdigit (*q))
+ --q;
+ if (!(q > p) || q == r || (*q != '+' && *q != '-'))
+ return NULL;
+ check_buf (q - p + 1, SMALL_BUF_SIZE);
+ strncpy (buf, p, (size_t) (q - p));
+ buf[q - p] = '\0';
+ *i = atoi (q);
+ return buf;
+}
+
+@ @<Exported function headers@>=
+boolean mp_has_fm_entry (MP mp,font_number f, fm_entry **fm);
+
+@ @c
+boolean mp_has_fm_entry (MP mp,font_number f, fm_entry **fm) {
+ fm_entry *res = NULL;
+ res = mp_fm_lookup (mp, f);
+ if (fm != NULL) {
+ *fm =res;
+ }
+ return (res != NULL);
+}
+
+@ @<Glob...@>=
+struct avl_table *tfm_tree;
+struct avl_table *ps_tree;
+struct avl_table *ff_tree;
+
+@ @<Set initial...@>=
+mp->ps->tfm_tree = NULL;
+mp->ps->ps_tree = NULL;
+mp->ps->ff_tree = NULL;
+
+@ AVL sort |fm_entry| into |tfm_tree| by |tfm_name |
+
+@c
+static int comp_fm_entry_tfm (const void *pa, const void *pb, void *p) {
+ (void)p;
+ return strcmp (((const fm_entry *) pa)->tfm_name,
+ ((const fm_entry *) pb)->tfm_name);
+}
+
+@ AVL sort |fm_entry| into |ps_tree| by |ps_name|, |slant|, and |extend|
+
+@c static int comp_fm_entry_ps (const void *pa, const void *pb, void *p) {
+ int i;
+ const fm_entry *p1 = (const fm_entry *) pa;
+ const fm_entry *p2 = (const fm_entry *) pb;
+ (void)p;
+ assert (p1->ps_name != NULL && p2->ps_name != NULL);
+ if ((i = strcmp (p1->ps_name, p2->ps_name)))
+ return i;
+ cmp_return (p1->slant, p2->slant);
+ cmp_return (p1->extend, p2->extend);
+ if (p1->tfm_name != NULL && p2->tfm_name != NULL &&
+ (i = strcmp (p1->tfm_name, p2->tfm_name)))
+ return i;
+ return 0;
+}
+
+@ AVL sort |ff_entry| into |ff_tree| by |ff_name|
+
+@c static int comp_ff_entry (const void *pa, const void *pb, void *p) {
+ (void)p;
+ return strcmp (((const ff_entry *) pa)->ff_name,
+ ((const ff_entry *) pb)->ff_name);
+}
+
+@ @c static void create_avl_trees (MP mp) {
+ if (mp->ps->tfm_tree == NULL) {
+ mp->ps->tfm_tree = avl_create (comp_fm_entry_tfm, NULL, &mp->ps->avl_xallocator);
+ assert (mp->ps->tfm_tree != NULL);
+ }
+ if (mp->ps->ps_tree == NULL) {
+ mp->ps->ps_tree = avl_create (comp_fm_entry_ps, NULL, &mp->ps->avl_xallocator);
+ assert (mp->ps->ps_tree != NULL);
+ }
+ if (mp->ps->ff_tree == NULL) {
+ mp->ps->ff_tree = avl_create (comp_ff_entry, NULL, &mp->ps->avl_xallocator);
+ assert (mp->ps->ff_tree != NULL);
+ }
+}
+
+@ The function |avl_do_entry| is not completely symmetrical with regards
+to |tfm_name| and |ps_name handling|, e. g. a duplicate |tfm_name| gives a
+|goto exit|, and no |ps_name| link is tried. This is to keep it compatible
+with the original version.
+
+@d LINK_TFM 0x01
+@d LINK_PS 0x02
+@d set_tfmlink(fm) ((fm)->links |= LINK_TFM)
+@d set_pslink(fm) ((fm)->links |= LINK_PS)
+@d unset_tfmlink(fm) ((fm)->links &= ~LINK_TFM)
+@d unset_pslink(fm) ((fm)->links &= ~LINK_PS)
+@d has_tfmlink(fm) ((fm)->links & LINK_TFM)
+@d has_pslink(fm) ((fm)->links & LINK_PS)
+
+@c
+static int avl_do_entry (MP mp, fm_entry * fp, int mode) {
+ fm_entry *p;
+ void *a;
+ void **aa;
+ char s[128];
+
+ /* handle |tfm_name| link */
+
+ if (strcmp (fp->tfm_name, nontfm)) {
+ p = (fm_entry *) avl_find (mp->ps->tfm_tree, fp);
+ if (p != NULL) {
+ if (mode == FM_DUPIGNORE) {
+ snprintf(s,128,"fontmap entry for `%s' already exists, duplicates ignored",
+ fp->tfm_name);
+ mp_warn(mp,s);
+ goto exit;
+ } else { /* mode == |FM_REPLACE| / |FM_DELETE| */
+ if (mp_has_font_size(mp,p->tfm_num)) {
+ snprintf(s,128,
+ "fontmap entry for `%s' has been used, replace/delete not allowed",
+ fp->tfm_name);
+ mp_warn(mp,s);
+ goto exit;
+ }
+ a = avl_delete (mp->ps->tfm_tree, p);
+ assert (a != NULL);
+ unset_tfmlink (p);
+ if (!has_pslink (p))
+ delete_fm_entry (p);
+ }
+ }
+ if (mode != FM_DELETE) {
+ aa = avl_probe (mp->ps->tfm_tree, fp);
+ assert (aa != NULL);
+ set_tfmlink (fp);
+ }
+ }
+
+ /* handle |ps_name| link */
+
+ if (fp->ps_name != NULL) {
+ assert (fp->tfm_name != NULL);
+ p = (fm_entry *) avl_find (mp->ps->ps_tree, fp);
+ if (p != NULL) {
+ if (mode == FM_DUPIGNORE) {
+ snprintf(s,128,
+ "ps_name entry for `%s' already exists, duplicates ignored",
+ fp->ps_name);
+ mp_warn(mp,s);
+ goto exit;
+ } else { /* mode == |FM_REPLACE| / |FM_DELETE| */
+ if (mp_has_font_size(mp,p->tfm_num)) {
+ /* REPLACE/DELETE not allowed */
+ snprintf(s,128,
+ "fontmap entry for `%s' has been used, replace/delete not allowed",
+ p->tfm_name);
+ mp_warn(mp,s);
+ goto exit;
+ }
+ a = avl_delete (mp->ps->ps_tree, p);
+ assert (a != NULL);
+ unset_pslink (p);
+ if (!has_tfmlink (p))
+ delete_fm_entry (p);
+ }
+ }
+ if (mode != FM_DELETE) {
+ aa = avl_probe (mp->ps->ps_tree, fp);
+ assert (aa != NULL);
+ set_pslink (fp);
+ }
+ }
+ exit:
+ if (!has_tfmlink (fp) && !has_pslink (fp)) /* e. g. after |FM_DELETE| */
+ return 1; /* deallocation of |fm_entry| structure required */
+ else
+ return 0;
+}
+
+@ consistency check for map entry, with warn flag
+
+@c
+static int check_fm_entry (MP mp, fm_entry * fm, boolean warn) {
+ int a = 0;
+ char s[128];
+ assert (fm != NULL);
+ if (fm->ps_name != NULL) {
+ if (is_basefont (fm)) {
+ if (is_fontfile (fm) && !is_included (fm)) {
+ if (warn) {
+ snprintf(s,128, "invalid entry for `%s': "
+ "font file must be included or omitted for base fonts",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 1;
+ }
+ } else { /* not a base font */
+ /* if no font file given, drop this entry */
+ /* |if (!is_fontfile (fm)) {
+ if (warn) {
+ snprintf(s,128,
+ "invalid entry for `%s': font file missing",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 2;
+ }|
+ */
+ }
+ }
+ if (is_truetype (fm) && is_reencoded (fm) && !is_subsetted (fm)) {
+ if (warn) {
+ snprintf(s,128,
+ "invalid entry for `%s': only subsetted TrueType font can be reencoded",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 4;
+ }
+ if ((fm->slant != 0 || fm->extend != 0) &&
+ (is_truetype (fm))) {
+ if (warn) {
+ snprintf(s,128,
+ "invalid entry for `%s': "
+ "SlantFont/ExtendFont can be used only with embedded T1 fonts",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 8;
+ }
+ if (abs (fm->slant) > 1000) {
+ if (warn) {
+ snprintf(s,128,
+ "invalid entry for `%s': too big value of SlantFont (%g)",
+ fm->tfm_name, fm->slant / 1000.0);
+ mp_warn(mp,s);
+ }
+ a += 16;
+ }
+ if (abs (fm->extend) > 2000) {
+ if (warn) {
+ snprintf(s,128,
+ "invalid entry for `%s': too big value of ExtendFont (%g)",
+ fm->tfm_name, fm->extend / 1000.0);
+ mp_warn(mp,s);
+ }
+ a += 32;
+ }
+ if (fm->pid != -1 &&
+ !(is_truetype (fm) && is_included (fm) &&
+ is_subsetted (fm) && !is_reencoded (fm))) {
+ if (warn) {
+ snprintf(s,128,
+ "invalid entry for `%s': "
+ "PidEid can be used only with subsetted non-reencoded TrueType fonts",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 64;
+ }
+ return a;
+}
+
+@ returns true if s is one of the 14 std. font names; speed-trimmed.
+
+@c static boolean check_basefont (char *s) {
+ static const char *basefont_names[] = {
+ "Courier", /* 0:7 */
+ "Courier-Bold", /* 1:12 */
+ "Courier-Oblique", /* 2:15 */
+ "Courier-BoldOblique", /* 3:19 */
+ "Helvetica", /* 4:9 */
+ "Helvetica-Bold", /* 5:14 */
+ "Helvetica-Oblique", /* 6:17 */
+ "Helvetica-BoldOblique", /* 7:21 */
+ "Symbol", /* 8:6 */
+ "Times-Roman", /* 9:11 */
+ "Times-Bold", /* 10:10 */
+ "Times-Italic", /* 11:12 */
+ "Times-BoldItalic", /* 12:16 */
+ "ZapfDingbats" /* 13:12 */
+ };
+ static const int Index[] =
+ { -1, -1, -1, -1, -1, -1, 8, 0, -1, 4, 10, 9, -1, -1, 5, 2, 12, 6,
+ -1, 3, -1, 7
+ };
+ const size_t n = strlen (s);
+ int k = -1;
+ if (n > 21)
+ return false;
+ if (n == 12) { /* three names have length 12 */
+ switch (*s) {
+ case 'C':
+ k = 1; /* Courier-Bold */
+ break;
+ case 'T':
+ k = 11; /* Times-Italic */
+ break;
+ case 'Z':
+ k = 13; /* ZapfDingbats */
+ break;
+ default:
+ return false;
+ }
+ } else
+ k = Index[n];
+ if (k > -1 && !strcmp (basefont_names[k], s))
+ return true;
+ return false;
+}
+
+@
+@d is_cfg_comment(c) (c == 10 || c == '*' || c == '#' || c == ';' || c == '%')
+
+@c static void fm_scan_line (MP mp) {
+ int a, b, c, j, u = 0, v = 0;
+ float d;
+ fm_entry *fm;
+ char fm_line[FM_BUF_SIZE], buf[FM_BUF_SIZE];
+ char *p, *q, *r, *s;
+ char warn_s[128];
+ switch (mp->ps->mitem->type) {
+ case MAPFILE:
+ p = fm_line;
+ do {
+ c = fm_getchar (mp);
+ append_char_to_buf (c, p, fm_line, FM_BUF_SIZE);
+ } while (c != 10);
+ *(--p) = '\0';
+ r = fm_line;
+ break;
+ case MAPLINE:
+ r = mp->ps->mitem->map_line;
+ break;
+ default:
+ assert (0);
+ }
+ if (*r == '\0' || is_cfg_comment (*r))
+ return;
+ fm = new_fm_entry (mp);
+ read_field (r, q, buf);
+ set_field (tfm_name);
+ p = r;
+ read_field (r, q, buf);
+ if (*buf != '<' && *buf != '"')
+ set_field (ps_name);
+ else
+ r = p; /* unget the field */
+ if (isdigit (*r)) { /* font flags given */
+ fm->flags = atoi (r);
+ while (isdigit (*r))
+ r++;
+ }
+ while (1) { /* loop through "specials", encoding, font file */
+ skip (r, ' ');
+ switch (*r) {
+ case '\0':
+ goto DONE;
+ case '"': /* opening quote */
+ r++;
+ u = v = 0;
+ do {
+ skip (r, ' ');
+ if (sscanf (r, "%f %n", &d, &j) > 0) {
+ s = r + j; /* jump behind number, eat also blanks, if any */
+ if (*(s - 1) == 'E' || *(s - 1) == 'e')
+ s--; /* e. g. 0.5ExtendFont: \%f = 0.5E */
+ if (str_prefix (s, "SlantFont")) {
+ d *= 1000.0; /* correct rounding also for neg. numbers */
+ fm->slant = (integer) (d > 0 ? d + 0.5 : d - 0.5);
+ r = s + strlen ("SlantFont");
+ } else if (str_prefix (s, "ExtendFont")) {
+ d *= 1000.0;
+ fm->extend = (integer) (d > 0 ? d + 0.5 : d - 0.5);
+ if (fm->extend == 1000)
+ fm->extend = 0;
+ r = s + strlen ("ExtendFont");
+ } else { /* unknown name */
+ for (r = s;
+ *r != ' ' && *r != '"' && *r != '\0';
+ r++); /* jump over name */
+ c = *r; /* remember char for temporary end of string */
+ *r = '\0';
+ snprintf(warn_s,128,
+ "invalid entry for `%s': unknown name `%s' ignored",
+ fm->tfm_name, s);
+ mp_warn(mp,warn_s);
+ *r = c;
+ }
+ } else
+ for (; *r != ' ' && *r != '"' && *r != '\0'; r++);
+ }
+ while (*r == ' ');
+ if (*r == '"') /* closing quote */
+ r++;
+ else {
+ snprintf(warn_s,128,
+ "invalid entry for `%s': closing quote missing",
+ fm->tfm_name);
+ mp_warn(mp,warn_s);
+ goto bad_line;
+ }
+ break;
+ case 'P': /* handle cases for subfonts like 'PidEid=3,1' */
+ if (sscanf (r, "PidEid=%i, %i %n", &a, &b, &c) >= 2) {
+ fm->pid = a;
+ fm->eid = b;
+ r += c;
+ break;
+ }
+ default: /* encoding or font file specification */
+ a = b = 0;
+ if (*r == '<') {
+ a = *r++;
+ if (*r == '<' || *r == '[')
+ b = *r++;
+ }
+ read_field (r, q, buf);
+ /* encoding, formats: '8r.enc' or '<8r.enc' or '<[8r.enc' */
+ if (strlen (buf) > 4 && strcasecmp (strend (buf) - 4, ".enc") == 0) {
+ fm->encoding = mp_add_enc (mp, buf);
+ u = v = 0; /* u, v used if intervening blank: "<< foo" */
+ } else if (strlen (buf) > 0) { /* file name given */
+ /* font file, formats:
+ * subsetting: '<cmr10.pfa'
+ * no subsetting: '<<cmr10.pfa'
+ * no embedding: 'cmr10.pfa'
+ */
+ if (a == '<' || u == '<') {
+ set_included (fm);
+ if ((a == '<' && b == 0) || (a == 0 && v == 0))
+ set_subsetted (fm);
+ /* otherwise b == '<' (or '[') => no subsetting */
+ }
+ set_field (ff_name);
+ u = v = 0;
+ } else {
+ u = a;
+ v = b;
+ }
+ }
+ }
+ DONE:
+ if (fm->ps_name != NULL && check_basefont (fm->ps_name))
+ set_basefont (fm);
+ if (is_fontfile (fm)
+ && strcasecmp (strend (fm_fontfile (fm)) - 4, ".ttf") == 0)
+ set_truetype (fm);
+ if (check_fm_entry (mp,fm, true) != 0)
+ goto bad_line;
+ /*
+ Until here the map line has been completely scanned without errors;
+ fm points to a valid, freshly filled-out |fm_entry| structure.
+ Now follows the actual work of registering/deleting.
+ */
+ if (avl_do_entry (mp, fm, mp->ps->mitem->mode) == 0) /* if success */
+ return;
+ bad_line:
+ delete_fm_entry (fm);
+}
+
+@
+@c static void fm_read_info (MP mp) {
+ char *n;
+ char s[256];
+ if (mp->ps->tfm_tree == NULL)
+ create_avl_trees (mp);
+ if (mp->ps->mitem->map_line == NULL) /* nothing to do */
+ return;
+ mp->ps->mitem->lineno = 1;
+ switch (mp->ps->mitem->type) {
+ case MAPFILE:
+ n = mp->ps->mitem->map_line;
+ mp->ps->fm_file = (mp->open_file)(mp, n, "r", mp_filetype_fontmap);
+ if (!mp->ps->fm_file) {
+ snprintf(s,256,"cannot open font map file %s",n);
+ mp_warn(mp,s);
+ } else {
+ int save_selector = mp->selector;
+ mp_normalize_selector(mp);
+ mp_print (mp, "{");
+ mp_print (mp, n);
+ while (!fm_eof ()) {
+ fm_scan_line (mp);
+ mp->ps->mitem->lineno++;
+ }
+ fm_close ();
+ mp_print (mp,"}");
+ mp->selector = save_selector;
+ mp->ps->fm_file = NULL;
+ }
+ mp_xfree(n);
+ break;
+ case MAPLINE:
+ fm_scan_line (mp);
+ break;
+ default:
+ assert (0);
+ }
+ mp->ps->mitem->map_line = NULL; /* done with this line */
+ return;
+}
+
+@ @c static void init_fm (fm_entry * fm, font_number f) {
+ if (fm->tfm_num == null_font ) {
+ fm->tfm_num = f;
+ fm->tfm_avail = TFM_FOUND;
+ }
+}
+
+@ @<Declarations@>=
+static fm_entry * mp_fm_lookup (MP mp, font_number f);
+
+@ @c
+static fm_entry * mp_fm_lookup (MP mp, font_number f) {
+ char *tfm;
+ fm_entry *fm;
+ fm_entry tmp;
+ int e;
+ if (mp->ps->tfm_tree == NULL)
+ fm_read_info (mp); /* only to read default map file */
+ tfm = mp->font_name[f];
+ assert (strcmp (tfm, nontfm));
+ /* Look up for full <tfmname>[+-]<expand> */
+ tmp.tfm_name = tfm;
+ fm = (fm_entry *) avl_find (mp->ps->tfm_tree, &tmp);
+ if (fm != NULL) {
+ init_fm (fm, f);
+ return (fm_entry *) fm;
+ }
+ tfm = mk_base_tfm (mp, mp->font_name[f], &e);
+ if (tfm == NULL) /* not an expanded font, nothing to do */
+ return NULL;
+
+ tmp.tfm_name = tfm;
+ fm = (fm_entry *) avl_find (mp->ps->tfm_tree, &tmp);
+ if (fm != NULL) { /* found an entry with the base tfm name, e.g. cmr10 */
+ return (fm_entry *) fm; /* font expansion uses the base font */
+ }
+ return NULL;
+}
+
+@ Early check whether a font file exists. Used e. g. for replacing fonts
+ of embedded PDF files: Without font file, the font within the embedded
+ PDF-file is used. Search tree |ff_tree| is used in 1st instance, as it
+ may be faster than the |kpse_find_file()|, and |kpse_find_file()| is called
+ only once per font file name + expansion parameter. This might help
+ keeping speed, if many PDF pages with same fonts are to be embedded.
+
+ The |ff_tree| contains only font files, which are actually needed,
+ so this tree typically is much smaller than the |tfm_tree| or |ps_tree|.
+
+@c
+static ff_entry *check_ff_exist (MP mp, fm_entry * fm) {
+ ff_entry *ff;
+ ff_entry tmp;
+ void **aa;
+
+ assert (fm->ff_name != NULL);
+ tmp.ff_name = fm->ff_name;
+ ff = (ff_entry *) avl_find (mp->ps->ff_tree, &tmp);
+ if (ff == NULL) { /* not yet in database */
+ ff = new_ff_entry (mp);
+ ff->ff_name = mp_xstrdup (mp,fm->ff_name);
+ ff->ff_path = mp_xstrdup (mp,fm->ff_name);
+ aa = avl_probe (mp->ps->ff_tree, ff);
+ assert (aa != NULL);
+ }
+ return ff;
+}
+
+@ Process map file given by its name or map line contents. Items not
+beginning with [+-=] flush default map file, if it has not yet been
+read. Leading blanks and blanks immediately following [+-=] are ignored.
+
+
+@c static void mp_process_map_item (MP mp, char *s, int type) {
+ char *p;
+ int mode;
+ if (*s == ' ')
+ s++; /* ignore leading blank */
+ switch (*s) {
+ case '+': /* +mapfile.map, +mapline */
+ mode = FM_DUPIGNORE; /* insert entry, if it is not duplicate */
+ s++;
+ break;
+ case '=': /* =mapfile.map, =mapline */
+ mode = FM_REPLACE; /* try to replace earlier entry */
+ s++;
+ break;
+ case '-': /* -mapfile.map, -mapline */
+ mode = FM_DELETE; /* try to delete entry */
+ s++;
+ break;
+ default:
+ mode = FM_DUPIGNORE; /* like +, but also: */
+ mp_xfree(mp->ps->mitem->map_line);
+ mp->ps->mitem->map_line = NULL; /* flush default map file name */
+ }
+ if (*s == ' ')
+ s++; /* ignore blank after [+-=] */
+ p = s; /* map item starts here */
+ switch (type) {
+ case MAPFILE: /* remove blank at end */
+ while (*p != '\0' && *p != ' ')
+ p++;
+ *p = '\0';
+ break;
+ case MAPLINE: /* blank at end allowed */
+ break;
+ default:
+ assert (0);
+ }
+ if (mp->ps->mitem->map_line != NULL) /* read default map file first */
+ fm_read_info (mp);
+ if (*s != '\0') { /* only if real item to process */
+ mp->ps->mitem->mode = mode;
+ mp->ps->mitem->type = type;
+ mp->ps->mitem->map_line = s;
+ fm_read_info (mp);
+ }
+}
+
+@ @<Exported function headers@>=
+void mp_map_file (MP mp, str_number t);
+void mp_map_line (MP mp, str_number t);
+void mp_init_map_file (MP mp, int is_troff);
+
+@ @c
+void mp_map_file (MP mp, str_number t) {
+ char *s = mp_xstrdup(mp,mp_str (mp,t));
+ mp_process_map_item (mp, s, MAPFILE);
+ mp_xfree (s);
+}
+void mp_map_line (MP mp, str_number t) {
+ char *s = mp_xstrdup(mp,mp_str (mp,t));
+ mp_process_map_item (mp, s, MAPLINE);
+ mp_xfree (s);
+}
+
+@
+@c void mp_init_map_file (MP mp, int is_troff) {
+ char *r;
+ mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem));
+ mp->ps->mitem->mode = FM_DUPIGNORE;
+ mp->ps->mitem->type = MAPFILE;
+ mp->ps->mitem->map_line = NULL;
+ r = (mp->find_file)(mp,"mpost.map", "r", mp_filetype_fontmap);
+ if (r != NULL) {
+ mp_xfree(r);
+ mp->ps->mitem->map_line = mp_xstrdup (mp,"mpost.map");
+ } else {
+ if (is_troff) {
+ mp->ps->mitem->map_line = mp_xstrdup (mp,"troff.map");
+ } else {
+ mp->ps->mitem->map_line = mp_xstrdup (mp,"pdftex.map");
+ }
+ }
+}
+
+@ @<Dealloc variables@>=
+if (mp->ps->mitem!=NULL) {
+ mp_xfree(mp->ps->mitem->map_line);
+ mp_xfree(mp->ps->mitem);
+}
+
+@ cleaning up...
+
+@c
+static void destroy_fm_entry_tfm (void *pa, void *pb) {
+ fm_entry *fm;
+ (void)pb;
+ fm = (fm_entry *) pa;
+ if (!has_pslink (fm))
+ delete_fm_entry (fm);
+ else
+ unset_tfmlink (fm);
+}
+static void destroy_fm_entry_ps (void *pa, void *pb) {
+ fm_entry *fm;
+ (void)pb;
+ fm = (fm_entry *) pa;
+ if (!has_tfmlink (fm))
+ delete_fm_entry (fm);
+ else
+ unset_pslink (fm);
+}
+static void destroy_ff_entry (void *pa, void *pb) {
+ ff_entry *ff;
+ (void)pb;
+ ff = (ff_entry *) pa;
+ delete_ff_entry (ff);
+}
+
+@ @<Declarations@>=
+static void fm_free (MP mp);
+
+@ @c
+static void fm_free (MP mp) {
+ if (mp->ps->tfm_tree != NULL)
+ avl_destroy (mp->ps->tfm_tree, destroy_fm_entry_tfm);
+ if (mp->ps->ps_tree != NULL)
+ avl_destroy (mp->ps->ps_tree, destroy_fm_entry_ps);
+ if (mp->ps->ff_tree != NULL)
+ avl_destroy (mp->ps->ff_tree, destroy_ff_entry);
+}
+
+@ The file |ps_tab_file| gives a table of \TeX\ font names and corresponding
+PostScript names for fonts that do not have to be downloaded, i.e., fonts that
+can be used when |internal[prologues]>0|. Each line consists of a \TeX\ name,
+one or more spaces, a PostScript name, and possibly a space and some other junk.
+This routine reads the table, updates |font_ps_name| entries starting after
+|last_ps_fnum|, and sets |last_ps_fnum:=last_fnum|.
+
+@d ps_tab_name "psfonts.map" /* locates font name translation table */
+
+@<Declarations@>=
+static void mp_read_psname_table (MP mp) ;
+
+@ @c
+static void mp_read_psname_table (MP mp) {
+ font_number k;
+ if (mp->ps->mitem == NULL) {
+ mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem));
+ mp->ps->mitem->mode = FM_DUPIGNORE;
+ mp->ps->mitem->type = MAPFILE;
+ mp->ps->mitem->map_line = NULL;
+ }
+ mp->ps->mitem->map_line = mp_xstrdup (mp,ps_tab_name);
+ fm_read_info (mp);
+ for (k=mp->last_ps_fnum+1;k<=mp->last_fnum;k++) {
+ if (mp_has_fm_entry(mp, k, NULL)) {
+ mp->font_ps_name[k] = mp_fm_font_name(mp,k);
+ }
+ }
+ mp->last_ps_fnum=mp->last_fnum;
+}
+
+
+@ The traditional function is a lot shorter now.
+
+
+
+@* \[44c] Helper functions for Type1 fonts.
+
+@<Types...@>=
+typedef char char_entry;
+typedef unsigned char Byte;
+typedef Byte Bytef;
+
+@ @<Glob...@>=
+char_entry *char_ptr, *char_array;
+size_t char_limit;
+char *job_id_string;
+
+@ @<Set initial...@>=
+mp->ps->char_array = NULL;
+mp->ps->job_id_string = NULL;
+
+@
+@d SMALL_ARRAY_SIZE 256
+@d Z_NULL 0
+
+@c
+void mp_set_job_id (MP mp) {
+ char *name_string, *format_string, *s;
+ size_t slen;
+ int i;
+ if (mp->ps->job_id_string != NULL)
+ return;
+ if ( mp->job_name==NULL )
+ mp->job_name = mp_xstrdup(mp,"mpout");
+ name_string = mp_xstrdup (mp,mp->job_name);
+ format_string = mp_xstrdup (mp,mp->mem_ident);
+ slen = SMALL_BUF_SIZE +
+ strlen (name_string) +
+ strlen (format_string);
+ s = mp_xmalloc (mp,slen, sizeof (char));
+ i = snprintf (s, slen,
+ "%.4d/%.2d/%.2d %.2d:%.2d %s %s",
+ (mp->internal[mp_year]>>16),
+ (mp->internal[mp_month]>>16),
+ (mp->internal[mp_day]>>16),
+ (mp->internal[mp_time]>>16) / 60,
+ (mp->internal[mp_time]>>16) % 60,
+ name_string, format_string);
+ mp->ps->job_id_string = mp_xstrdup (mp,s);
+ mp_xfree (s);
+ mp_xfree (name_string);
+ mp_xfree (format_string);
+}
+static void fnstr_append (MP mp, const char *s) {
+ size_t l = strlen (s) + 1;
+ alloc_array (char, l, SMALL_ARRAY_SIZE);
+ strcat (mp->ps->char_ptr, s);
+ mp->ps->char_ptr = strend (mp->ps->char_ptr);
+}
+
+@ @<Exported function headers@>=
+void mp_set_job_id (MP mp) ;
+
+@ @<Dealloc variables@>=
+mp_xfree(mp->ps->job_id_string);
+
+@ this is not really a true crc32, but it should be just enough to keep
+ subsets prefixes somewhat disjunct
+
+@c
+static unsigned long crc32 (int oldcrc, const Byte *buf, int len) {
+ unsigned long ret = 0;
+ int i;
+ if (oldcrc==0)
+ ret = (23<<24)+(45<<16)+(67<<8)+89;
+ else
+ for (i=0;i<len;i++)
+ ret = (ret<<2)+buf[i];
+ return ret;
+}
+static boolean mp_char_marked (MP mp,font_number f, eight_bits c) {
+ integer b; /* |char_base[f]| */
+ b=mp->char_base[f];
+ if ( (c>=mp->font_bc[f])&&(c<=mp->font_ec[f])&&(mp->font_info[b+c].qqqq.b3!=0) )
+ return true;
+ else
+ return false;
+}
+
+static void make_subset_tag (MP mp, fm_entry * fm_cur, char **glyph_names, int tex_font)
+{
+ char tag[7];
+ unsigned long crc;
+ int i;
+ size_t l ;
+ if (mp->ps->job_id_string ==NULL)
+ mp_fatal_error(mp, "no job id!");
+ l = strlen (mp->ps->job_id_string) + 1;
+
+ alloc_array (char, l, SMALL_ARRAY_SIZE);
+ strcpy (mp->ps->char_array, mp->ps->job_id_string);
+ mp->ps->char_ptr = strend (mp->ps->char_array);
+ if (fm_cur->tfm_name != NULL) {
+ fnstr_append (mp," TFM name: ");
+ fnstr_append (mp,fm_cur->tfm_name);
+ }
+ fnstr_append (mp," PS name: ");
+ if (fm_cur->ps_name != NULL)
+ fnstr_append (mp,fm_cur->ps_name);
+ fnstr_append (mp," Encoding: ");
+ if (fm_cur->encoding != NULL && (fm_cur->encoding)->file_name != NULL)
+ fnstr_append (mp,(fm_cur->encoding)->file_name);
+ else
+ fnstr_append (mp,"built-in");
+ fnstr_append (mp," CharSet: ");
+ for (i = 0; i < 256; i++)
+ if (mp_char_marked (mp,tex_font, i) && glyph_names[i] != notdef) {
+ if (glyph_names[i]!=NULL) {
+ fnstr_append (mp,"/");
+ fnstr_append (mp,glyph_names[i]);
+ }
+ }
+ if (fm_cur->charset != NULL) {
+ fnstr_append (mp," Extra CharSet: ");
+ fnstr_append (mp, fm_cur->charset);
+ }
+ crc = crc32 (0L, Z_NULL, 0);
+ crc = crc32 (crc, (Bytef *) mp->ps->char_array, strlen (mp->ps->char_array));
+ /* we need to fit a 32-bit number into a string of 6 uppercase chars long;
+ * there are 26 uppercase chars ==> each char represents a number in range
+ * |0..25|. The maximal number that can be represented by the tag is
+ * $26^6 - 1$, which is a number between $2^28$ and $2^29$. Thus the bits |29..31|
+ * of the CRC must be dropped out.
+ */
+ for (i = 0; i < 6; i++) {
+ tag[i] = 'A' + crc % 26;
+ crc /= 26;
+ }
+ tag[6] = 0;
+ fm_cur->subset_tag = mp_xstrdup (mp,tag);
+}
+
+
+
+@
+@d external_enc() (fm_cur->encoding)->glyph_names
+@d is_used_char(c) mp_char_marked (mp, tex_font, c)
+@d end_last_eexec_line()
+ mp->ps->hexline_length = HEXLINE_WIDTH;
+ end_hexline(mp);
+ mp->ps->t1_eexec_encrypt = false
+@d t1_log(s) mp_print(mp,(char *)s)
+@d t1_putchar(c) wps_chr(c)
+@d embed_all_glyphs(tex_font) false
+@d t1_char(c) c
+@d extra_charset() mp->ps->dvips_extra_charset
+@d update_subset_tag()
+@d fixedcontent true
+
+@<Glob...@>=
+#define PRINTF_BUF_SIZE 1024
+char *dvips_extra_charset;
+char *cur_enc_name;
+unsigned char *grid;
+char *ext_glyph_names[256];
+char print_buf[PRINTF_BUF_SIZE];
+int t1_byte_waiting;
+
+@ @<Set initial ...@>=
+mp->ps->dvips_extra_charset=NULL;
+mp->ps->t1_byte_waiting=0;
+
+@
+@d t1_ungetchar(A) mp->ps->t1_byte_waiting=A
+@d t1_eof() (mp->eof_file)(mp,mp->ps->t1_file)
+@d t1_close() (mp->close_file)(mp,mp->ps->t1_file)
+@d valid_code(c) (c >= 0 && c < 256)
+
+@c
+int t1_getchar (MP mp) {
+ size_t len = 1;
+ unsigned char abyte=0;
+ void *byte_ptr = &abyte;
+ if (mp->ps->t1_byte_waiting) {
+ abyte = mp->ps->t1_byte_waiting;
+ mp->ps->t1_byte_waiting = 0;
+ } else {
+ (mp->read_binary_file)(mp,mp->ps->t1_file,&byte_ptr,&len);
+ }
+ return abyte;
+}
+
+@ @<Static variables in the outer block@>=
+static const char *standard_glyph_names[256] =
+ { notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ "space", "exclam", "quotedbl", "numbersign",
+ "dollar", "percent", "ampersand", "quoteright", "parenleft",
+ "parenright", "asterisk", "plus", "comma", "hyphen", "period",
+ "slash", "zero", "one", "two", "three", "four", "five", "six", "seven",
+ "eight", "nine", "colon", "semicolon", "less",
+ "equal", "greater", "question", "at", "A", "B", "C", "D", "E", "F",
+ "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q",
+ "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "bracketleft",
+ "backslash", "bracketright", "asciicircum", "underscore",
+ "quoteleft", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k",
+ "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v",
+ "w", "x", "y", "z", "braceleft", "bar", "braceright", "asciitilde",
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, "exclamdown", "cent",
+ "sterling", "fraction", "yen", "florin", "section", "currency",
+ "quotesingle", "quotedblleft", "guillemotleft",
+ "guilsinglleft", "guilsinglright", "fi", "fl", notdef, "endash",
+ "dagger", "daggerdbl", "periodcentered", notdef,
+ "paragraph", "bullet", "quotesinglbase", "quotedblbase",
+ "quotedblright", "guillemotright", "ellipsis", "perthousand",
+ notdef, "questiondown", notdef, "grave", "acute", "circumflex",
+ "tilde", "macron", "breve", "dotaccent", "dieresis", notdef,
+ "ring", "cedilla", notdef, "hungarumlaut", "ogonek", "caron", "emdash",
+ notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, "AE", notdef, "ordfeminine", notdef, notdef,
+ notdef, notdef, "Lslash", "Oslash", "OE", "ordmasculine", notdef,
+ notdef, notdef, notdef, notdef, "ae", notdef, notdef,
+ notdef, "dotlessi", notdef, notdef, "lslash", "oslash", "oe",
+ "germandbls", notdef, notdef, notdef, notdef };
+static const char charstringname[] = "/CharStrings";
+
+@ @<Glob...@>=
+char **t1_glyph_names;
+char *t1_builtin_glyph_names[256];
+char charsetstr[0x4000];
+boolean read_encoding_only;
+int t1_encoding;
+
+@ @c
+#define T1_BUF_SIZE 0x10
+
+#define CS_HSTEM 1
+#define CS_VSTEM 3
+#define CS_VMOVETO 4
+#define CS_RLINETO 5
+#define CS_HLINETO 6
+#define CS_VLINETO 7
+#define CS_RRCURVETO 8
+#define CS_CLOSEPATH 9
+#define CS_CALLSUBR 10
+#define CS_RETURN 11
+#define CS_ESCAPE 12
+#define CS_HSBW 13
+#define CS_ENDCHAR 14
+#define CS_RMOVETO 21
+#define CS_HMOVETO 22
+#define CS_VHCURVETO 30
+#define CS_HVCURVETO 31
+#define CS_1BYTE_MAX (CS_HVCURVETO + 1)
+
+#define CS_DOTSECTION CS_1BYTE_MAX + 0
+#define CS_VSTEM3 CS_1BYTE_MAX + 1
+#define CS_HSTEM3 CS_1BYTE_MAX + 2
+#define CS_SEAC CS_1BYTE_MAX + 6
+#define CS_SBW CS_1BYTE_MAX + 7
+#define CS_DIV CS_1BYTE_MAX + 12
+#define CS_CALLOTHERSUBR CS_1BYTE_MAX + 16
+#define CS_POP CS_1BYTE_MAX + 17
+#define CS_SETCURRENTPOINT CS_1BYTE_MAX + 33
+#define CS_2BYTE_MAX (CS_SETCURRENTPOINT + 1)
+#define CS_MAX CS_2BYTE_MAX
+
+@ @<Types...@>=
+typedef unsigned char byte;
+typedef struct {
+ byte nargs; /* number of arguments */
+ boolean bottom; /* take arguments from bottom of stack? */
+ boolean clear; /* clear stack? */
+ boolean valid;
+} cc_entry; /* CharString Command */
+typedef struct {
+ char *glyph_name; /* glyph name (or notdef for Subrs entry) */
+ byte *data;
+ unsigned short len; /* length of the whole string */
+ unsigned short cslen; /* length of the encoded part of the string */
+ boolean is_used;
+ boolean valid;
+} cs_entry;
+
+@ @<Glob...@>=
+unsigned short t1_dr, t1_er;
+unsigned short t1_c1, t1_c2;
+unsigned short t1_cslen;
+short t1_lenIV;
+
+@ @<Set initial...@>=
+mp->ps->t1_c1 = 52845;
+mp->ps->t1_c2 = 22719;
+
+@ @<Types...@>=
+typedef char t1_line_entry;
+typedef char t1_buf_entry;
+
+@ @<Glob...@>=
+t1_line_entry *t1_line_ptr, *t1_line_array;
+size_t t1_line_limit;
+t1_buf_entry *t1_buf_ptr, *t1_buf_array;
+size_t t1_buf_limit;
+int cs_start;
+cs_entry *cs_tab, *cs_ptr, *cs_notdef;
+char *cs_dict_start, *cs_dict_end;
+int cs_count, cs_size, cs_size_pos;
+cs_entry *subr_tab;
+char *subr_array_start, *subr_array_end;
+int subr_max, subr_size, subr_size_pos;
+
+@ @<Set initial...@>=
+mp->ps->t1_line_array = NULL;
+mp->ps->t1_buf_array = NULL;
+
+@
+ This list contains the begin/end tokens commonly used in the
+ /Subrs array of a Type 1 font.
+
+@<Static variables in the outer block@>=
+static const char *cs_token_pairs_list[][2] = {
+ {" RD", "NP"},
+ {" -|", "|"},
+ {" RD", "noaccess put"},
+ {" -|", "noaccess put"},
+ {NULL, NULL}
+};
+
+@ @<Glob...@>=
+const char **cs_token_pair;
+boolean t1_pfa, t1_cs, t1_scan, t1_eexec_encrypt, t1_synthetic;
+int t1_in_eexec; /* 0 before eexec-encrypted, 1 during, 2 after */
+long t1_block_length;
+int last_hexbyte;
+void *t1_file;
+int hexline_length;
+
+@
+@d HEXLINE_WIDTH 64
+
+@<Set initial ...@>=
+mp->ps->hexline_length = 0;
+
+@
+@d t1_prefix(s) str_prefix(mp->ps->t1_line_array, s)
+@d t1_buf_prefix(s) str_prefix(mp->ps->t1_buf_array, s)
+@d t1_suffix(s) str_suffix(mp->ps->t1_line_array, mp->ps->t1_line_ptr, s)
+@d t1_buf_suffix(s) str_suffix(mp->ps->t1_buf_array, mp->ps->t1_buf_ptr, s)
+@d t1_charstrings() strstr(mp->ps->t1_line_array, charstringname)
+@d t1_subrs() t1_prefix("/Subrs")
+@d t1_end_eexec() t1_suffix("mark currentfile closefile")
+@d t1_cleartomark() t1_prefix("cleartomark")
+
+@d isdigit(A) ((A)>='0'&&(A)<='9')
+
+@c
+static void end_hexline (MP mp) {
+ if (mp->ps->hexline_length >= HEXLINE_WIDTH) {
+ wps_cr;
+ mp->ps->hexline_length = 0;
+ }
+}
+static void t1_check_pfa (MP mp) {
+ const int c = t1_getchar (mp);
+ mp->ps->t1_pfa = (c != 128) ? true : false;
+ t1_ungetchar (c);
+}
+static int t1_getbyte (MP mp)
+{
+ int c = t1_getchar (mp);
+ if (mp->ps->t1_pfa)
+ return c;
+ if (mp->ps->t1_block_length == 0) {
+ if (c != 128)
+ mp_fatal_error (mp, "invalid marker");
+ c = t1_getchar (mp);
+ if (c == 3) {
+ while (!t1_eof ())
+ t1_getchar (mp);
+ return EOF;
+ }
+ mp->ps->t1_block_length = t1_getchar (mp) & 0xff;
+ mp->ps->t1_block_length |= (t1_getchar (mp) & 0xff) << 8;
+ mp->ps->t1_block_length |= (t1_getchar (mp) & 0xff) << 16;
+ mp->ps->t1_block_length |= (t1_getchar (mp) & 0xff) << 24;
+ c = t1_getchar (mp);
+ }
+ mp->ps->t1_block_length--;
+ return c;
+}
+static int hexval (int c) {
+ if (c >= 'A' && c <= 'F')
+ return c - 'A' + 10;
+ else if (c >= 'a' && c <= 'f')
+ return c - 'a' + 10;
+ else if (c >= '0' && c <= '9')
+ return c - '0';
+ else
+ return -1;
+}
+static byte edecrypt (MP mp, byte cipher) {
+ byte plain;
+ if (mp->ps->t1_pfa) {
+ while (cipher == 10 || cipher == 13)
+ cipher = t1_getbyte (mp);
+ mp->ps->last_hexbyte = cipher = (hexval (cipher) << 4) + hexval (t1_getbyte (mp));
+ }
+ plain = (cipher ^ (mp->ps->t1_dr >> 8));
+ mp->ps->t1_dr = (cipher + mp->ps->t1_dr) * mp->ps->t1_c1 + mp->ps->t1_c2;
+ return plain;
+}
+static byte cdecrypt (MP mp, byte cipher, unsigned short *cr)
+{
+ const byte plain = (cipher ^ (*cr >> 8));
+ *cr = (cipher + *cr) * mp->ps->t1_c1 + mp->ps->t1_c2;
+ return plain;
+}
+static byte eencrypt (MP mp, byte plain)
+{
+ const byte cipher = (plain ^ (mp->ps->t1_er >> 8));
+ mp->ps->t1_er = (cipher + mp->ps->t1_er) * mp->ps->t1_c1 + mp->ps->t1_c2;
+ return cipher;
+}
+
+static byte cencrypt (MP mp, byte plain, unsigned short *cr)
+{
+ const byte cipher = (plain ^ (*cr >> 8));
+ *cr = (cipher + *cr) * mp->ps->t1_c1 + mp->ps->t1_c2;
+ return cipher;
+}
+
+static char *eol (char *s) {
+ char *p = strend (s);
+ if (p - s > 1 && p[-1] != 10) {
+ *p++ = 10;
+ *p = 0;
+ }
+ return p;
+}
+static float t1_scan_num (MP mp, char *p, char **r)
+{
+ float f;
+ char s[128];
+ skip (p, ' ');
+ if (sscanf (p, "%g", &f) != 1) {
+ remove_eol (p, mp->ps->t1_line_array);
+ snprintf(s,128, "a number expected: `%s'", mp->ps->t1_line_array);
+ mp_fatal_error(mp,s);
+ }
+ if (r != NULL) {
+ for (; isdigit (*p) || *p == '.' ||
+ *p == 'e' || *p == 'E' || *p == '+' || *p == '-'; p++);
+ *r = p;
+ }
+ return f;
+}
+
+static boolean str_suffix (const char *begin_buf, const char *end_buf,
+ const char *s)
+{
+ const char *s1 = end_buf - 1, *s2 = strend (s) - 1;
+ if (*s1 == 10)
+ s1--;
+ while (s1 >= begin_buf && s2 >= s) {
+ if (*s1-- != *s2--)
+ return false;
+ }
+ return s2 < s;
+}
+
+@
+
+@d alloc_array(T, n, s) do {
+ if (mp->ps->T##_array == NULL) {
+ mp->ps->T##_limit = (s);
+ if ((unsigned)(n) > mp->ps->T##_limit)
+ mp->ps->T##_limit = (n);
+ mp->ps->T##_array = mp_xmalloc (mp,mp->ps->T##_limit,sizeof(T##_entry));
+ mp->ps->T##_ptr = mp->ps->T##_array;
+ }
+ else if ((unsigned)(mp->ps->T##_ptr - mp->ps->T##_array + (n)) > mp->ps->T##_limit) {
+ size_t last_ptr_index;
+ last_ptr_index = mp->ps->T##_ptr - mp->ps->T##_array;
+ mp->ps->T##_limit *= 2;
+ if ((unsigned)(mp->ps->T##_ptr - mp->ps->T##_array + (n)) > mp->ps->T##_limit)
+ mp->ps->T##_limit = mp->ps->T##_ptr - mp->ps->T##_array + (n);
+ mp->ps->T##_array = mp_xrealloc(mp,mp->ps->T##_array,mp->ps->T##_limit, sizeof(T##_entry));
+ mp->ps->T##_ptr = mp->ps->T##_array + last_ptr_index;
+ }
+} while (0)
+
+@d out_eexec_char(A) t1_outhex(mp,(A))
+
+@c
+static void t1_outhex (MP mp, byte b)
+{
+ static const char *hexdigits = "0123456789ABCDEF";
+ t1_putchar (hexdigits[b / 16]);
+ t1_putchar (hexdigits[b % 16]);
+ mp->ps->hexline_length += 2;
+ end_hexline (mp);
+}
+static void t1_getline (MP mp) {
+ int c, l, eexec_scan;
+ char *p;
+ static const char eexec_str[] = "currentfile eexec";
+ static int eexec_len = 17; /* |strlen(eexec_str)| */
+ RESTART:
+ if (t1_eof ())
+ mp_fatal_error (mp,"unexpected end of file");
+ mp->ps->t1_line_ptr = mp->ps->t1_line_array;
+ alloc_array (t1_line, 1, T1_BUF_SIZE);
+ mp->ps->t1_cslen = 0;
+ eexec_scan = 0;
+ c = t1_getbyte (mp);
+ if (c == EOF)
+ goto EXIT;
+ while (!t1_eof ()) {
+ if (mp->ps->t1_in_eexec == 1)
+ c = edecrypt (mp,c);
+ alloc_array (t1_line, 1, T1_BUF_SIZE);
+ append_char_to_buf (c, mp->ps->t1_line_ptr, mp->ps->t1_line_array, mp->ps->t1_line_limit);
+ if (mp->ps->t1_in_eexec == 0 && eexec_scan >= 0 && eexec_scan < eexec_len) {
+ if (mp->ps->t1_line_array[eexec_scan] == eexec_str[eexec_scan])
+ eexec_scan++;
+ else
+ eexec_scan = -1;
+ }
+ if (c == 10 || (mp->ps->t1_pfa && eexec_scan == eexec_len && c == 32))
+ break;
+ if (mp->ps->t1_cs && mp->ps->t1_cslen == 0 &&
+ (mp->ps->t1_line_ptr - mp->ps->t1_line_array > 4) &&
+ (t1_suffix (" RD ") || t1_suffix (" -| "))) {
+ p = mp->ps->t1_line_ptr - 5;
+ while (*p != ' ')
+ p--;
+ mp->ps->t1_cslen = l = t1_scan_num (mp, p + 1, 0);
+ mp->ps->cs_start = mp->ps->t1_line_ptr - mp->ps->t1_line_array;
+ /* |mp->ps->cs_start| is an index now */
+ alloc_array (t1_line, l, T1_BUF_SIZE);
+ while (l-- > 0)
+ *mp->ps->t1_line_ptr++ = edecrypt (mp,t1_getbyte (mp));
+ }
+ c = t1_getbyte (mp);
+ }
+ alloc_array (t1_line, 2, T1_BUF_SIZE); /* |append_eol| can append 2 chars */
+ append_eol (mp->ps->t1_line_ptr, mp->ps->t1_line_array, mp->ps->t1_line_limit);
+ if (mp->ps->t1_line_ptr - mp->ps->t1_line_array < 2)
+ goto RESTART;
+ if (eexec_scan == eexec_len)
+ mp->ps->t1_in_eexec = 1;
+ EXIT:
+ /* ensure that |mp->ps->t1_buf_array| has as much room as |t1_line_array| */
+ mp->ps->t1_buf_ptr = mp->ps->t1_buf_array;
+ alloc_array (t1_buf, mp->ps->t1_line_limit, mp->ps->t1_line_limit);
+}
+
+static void t1_putline (MP mp)
+{
+ char *p = mp->ps->t1_line_array;
+ if (mp->ps->t1_line_ptr - mp->ps->t1_line_array <= 1)
+ return;
+ if (mp->ps->t1_eexec_encrypt) {
+ while (p < mp->ps->t1_line_ptr)
+ out_eexec_char (eencrypt (mp,*p++));
+ } else {
+ while (p < mp->ps->t1_line_ptr)
+ t1_putchar (*p++);
+ }
+}
+
+static void t1_puts (MP mp, const char *s)
+{
+ if (s != mp->ps->t1_line_array)
+ strcpy (mp->ps->t1_line_array, s);
+ mp->ps->t1_line_ptr = strend (mp->ps->t1_line_array);
+ t1_putline (mp);
+}
+
+static void t1_printf (MP mp, const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+ vsprintf (mp->ps->t1_line_array, fmt, args);
+ t1_puts (mp,mp->ps->t1_line_array);
+ va_end (args);
+}
+
+static void t1_init_params (MP mp, char *open_name_prefix,
+ char *cur_file_name) {
+ if ((open_name_prefix != NULL) && strlen(open_name_prefix)) {
+ t1_log (open_name_prefix);
+ t1_log (cur_file_name);
+ }
+ mp->ps->t1_lenIV = 4;
+ mp->ps->t1_dr = 55665;
+ mp->ps->t1_er = 55665;
+ mp->ps->t1_in_eexec = 0;
+ mp->ps->t1_cs = false;
+ mp->ps->t1_scan = true;
+ mp->ps->t1_synthetic = false;
+ mp->ps->t1_eexec_encrypt = false;
+ mp->ps->t1_block_length = 0;
+ t1_check_pfa (mp);
+}
+static void t1_close_font_file (MP mp, const char *close_name_suffix) {
+ if ((close_name_suffix != NULL) && strlen(close_name_suffix)) {
+ t1_log (close_name_suffix);
+ }
+ t1_close ();
+}
+
+static void t1_check_block_len (MP mp, boolean decrypt) {
+ int l, c;
+ char s[128];
+ if (mp->ps->t1_block_length == 0)
+ return;
+ c = t1_getbyte (mp);
+ if (decrypt)
+ c = edecrypt (mp,c);
+ l = mp->ps->t1_block_length;
+ if (!(l == 0 && (c == 10 || c == 13))) {
+ snprintf(s,128,"%i bytes more than expected were ignored", l+ 1);
+ mp_warn(mp,s);
+ while (l-- > 0)
+ t1_getbyte (mp);
+ }
+}
+static void t1_start_eexec (MP mp, fm_entry *fm_cur) {
+ int i;
+ if (!mp->ps->t1_pfa)
+ t1_check_block_len (mp, false);
+ for (mp->ps->t1_line_ptr = mp->ps->t1_line_array, i = 0; i < 4; i++) {
+ edecrypt (mp, t1_getbyte (mp));
+ *mp->ps->t1_line_ptr++ = 0;
+ }
+ mp->ps->t1_eexec_encrypt = true;
+ if (!mp->ps->read_encoding_only)
+ if (is_included (fm_cur))
+ t1_putline (mp); /* to put the first four bytes */
+}
+static void t1_stop_eexec (MP mp) {
+ int c;
+ end_last_eexec_line ();
+ if (!mp->ps->t1_pfa)
+ t1_check_block_len (mp,true);
+ else {
+ c = edecrypt (mp, t1_getbyte (mp));
+ if (!(c == 10 || c == 13)) {
+ if (mp->ps->last_hexbyte == 0)
+ t1_puts (mp,"00");
+ else
+ mp_warn (mp,"unexpected data after eexec");
+ }
+ }
+ mp->ps->t1_cs = false;
+ mp->ps->t1_in_eexec = 2;
+}
+static void t1_modify_fm (MP mp) {
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+}
+
+static void t1_modify_italic (MP mp) {
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+}
+
+@ @<Types...@>=
+typedef struct {
+ const char *pdfname;
+ const char *t1name;
+ float value;
+ boolean valid;
+} key_entry;
+
+@
+@d FONT_KEYS_NUM 11
+
+@<Declarations@>=
+static key_entry font_keys[FONT_KEYS_NUM] = {
+ {"Ascent", "Ascender", 0, false},
+ {"CapHeight", "CapHeight", 0, false},
+ {"Descent", "Descender", 0, false},
+ {"FontName", "FontName", 0, false},
+ {"ItalicAngle", "ItalicAngle", 0, false},
+ {"StemV", "StdVW", 0, false},
+ {"XHeight", "XHeight", 0, false},
+ {"FontBBox", "FontBBox", 0, false},
+ {"", "", 0, false},
+ {"", "", 0, false},
+ {"", "", 0, false}
+};
+
+
+@
+@d ASCENT_CODE 0
+@d CAPHEIGHT_CODE 1
+@d DESCENT_CODE 2
+@d FONTNAME_CODE 3
+@d ITALIC_ANGLE_CODE 4
+@d STEMV_CODE 5
+@d XHEIGHT_CODE 6
+@d FONTBBOX1_CODE 7
+@d FONTBBOX2_CODE 8
+@d FONTBBOX3_CODE 9
+@d FONTBBOX4_CODE 10
+@d MAX_KEY_CODE (FONTBBOX1_CODE + 1)
+
+@c
+static void t1_scan_keys (MP mp, int tex_font,fm_entry *fm_cur) {
+ int i, k;
+ char *p, *r;
+ key_entry *key;
+ if (fm_extend (fm_cur) != 0 || fm_slant (fm_cur) != 0) {
+ if (t1_prefix ("/FontMatrix")) {
+ t1_modify_fm (mp);
+ return;
+ }
+ if (t1_prefix ("/ItalicAngle")) {
+ t1_modify_italic (mp);
+ return;
+ }
+ }
+ if (t1_prefix ("/FontType")) {
+ p = mp->ps->t1_line_array + strlen ("FontType") + 1;
+ if ((i = t1_scan_num (mp,p, 0)) != 1) {
+ char s[128];
+ snprintf(s,125,"Type%d fonts unsupported by metapost", i);
+ mp_fatal_error(mp,s);
+ }
+ return;
+ }
+ for (key = font_keys; key - font_keys < MAX_KEY_CODE; key++)
+ if (str_prefix (mp->ps->t1_line_array + 1, key->t1name))
+ break;
+ if (key - font_keys == MAX_KEY_CODE)
+ return;
+ key->valid = true;
+ p = mp->ps->t1_line_array + strlen (key->t1name) + 1;
+ skip (p, ' ');
+ if ((k = key - font_keys) == FONTNAME_CODE) {
+ if (*p != '/') {
+ char s[128];
+ remove_eol (p, mp->ps->t1_line_array);
+ snprintf(s,128,"a name expected: `%s'", mp->ps->t1_line_array);
+ mp_fatal_error(mp,s);
+ }
+ r = ++p; /* skip the slash */
+ if (is_included (fm_cur)) {
+ /* save the fontname */
+ strncpy (mp->ps->fontname_buf, p, FONTNAME_BUF_SIZE);
+ for (i=0; mp->ps->fontname_buf[i] != 10; i++);
+ mp->ps->fontname_buf[i]=0;
+
+ if(is_subsetted (fm_cur)) {
+ if (fm_cur->encoding!=NULL && fm_cur->encoding->glyph_names!=NULL)
+ make_subset_tag (mp,fm_cur, fm_cur->encoding->glyph_names, tex_font);
+ else
+ make_subset_tag (mp,fm_cur, mp->ps->t1_builtin_glyph_names, tex_font);
+
+ alloc_array (t1_line, (r-mp->ps->t1_line_array+6+1+strlen(mp->ps->fontname_buf)+1),
+ T1_BUF_SIZE);
+ strncpy (r, fm_cur->subset_tag , 6);
+ *(r+6) = '-';
+ strncpy (r+7, mp->ps->fontname_buf, strlen(mp->ps->fontname_buf)+1);
+ mp->ps->t1_line_ptr = eol (r);
+ } else {
+ /* |for (q = p; *q != ' ' && *q != 10; *q++);|*/
+ /*|*q = 0;|*/
+ mp->ps->t1_line_ptr = eol (r);
+ }
+ }
+ return;
+ }
+ if ((k == STEMV_CODE || k == FONTBBOX1_CODE)
+ && (*p == '[' || *p == '{'))
+ p++;
+ if (k == FONTBBOX1_CODE) {
+ for (i = 0; i < 4; i++) {
+ key[i].value = t1_scan_num (mp, p, &r);
+ p = r;
+ }
+ return;
+ }
+ key->value = t1_scan_num (mp, p, 0);
+}
+static void t1_scan_param (MP mp, int tex_font,fm_entry *fm_cur)
+{
+ static const char *lenIV = "/lenIV";
+ if (!mp->ps->t1_scan || *mp->ps->t1_line_array != '/')
+ return;
+ if (t1_prefix (lenIV)) {
+ mp->ps->t1_lenIV = t1_scan_num (mp,mp->ps->t1_line_array + strlen (lenIV), 0);
+ return;
+ }
+ t1_scan_keys (mp, tex_font,fm_cur);
+}
+static void copy_glyph_names (MP mp, char **glyph_names, int a, int b) {
+ if (glyph_names[b] != notdef) {
+ mp_xfree (glyph_names[b]);
+ glyph_names[b] = (char *) notdef;
+ }
+ if (glyph_names[a] != notdef) {
+ glyph_names[b] = mp_xstrdup (mp,glyph_names[a]);
+ }
+}
+static void t1_builtin_enc (MP mp) {
+ int i, a, b, c, counter = 0;
+ char *r, *p;
+ /*
+ * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array|
+ */
+ if (t1_suffix ("def")) { /* predefined encoding */
+ sscanf (mp->ps->t1_line_array + strlen ("/Encoding"), "%256s", mp->ps->t1_buf_array);
+ if (strcmp (mp->ps->t1_buf_array, "StandardEncoding") == 0) {
+ for (i = 0; i < 256; i++)
+ if (standard_glyph_names[i] == notdef)
+ mp->ps->t1_builtin_glyph_names[i] = (char *) notdef;
+ else
+ mp->ps->t1_builtin_glyph_names[i] =
+ mp_xstrdup (mp,standard_glyph_names[i]);
+ mp->ps->t1_encoding = ENC_STANDARD;
+ } else {
+ char s[128];
+ snprintf(s,128, "cannot subset font (unknown predefined encoding `%s')",
+ mp->ps->t1_buf_array);
+ mp_fatal_error(mp,s);
+ }
+ return;
+ } else
+ mp->ps->t1_encoding = ENC_BUILTIN;
+ /*
+ * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array|, and the encoding is
+ * not a predefined encoding
+ *
+ * We have two possible forms of Encoding vector. The first case is
+ *
+ * /Encoding [/a /b /c...] readonly def
+ *
+ * and the second case can look like
+ *
+ * /Encoding 256 array 0 1 255 {1 index exch /.notdef put} for
+ * dup 0 /x put
+ * dup 1 /y put
+ * ...
+ * readonly def
+ */
+ for (i = 0; i < 256; i++)
+ mp->ps->t1_builtin_glyph_names[i] = (char *) notdef;
+ if (t1_prefix ("/Encoding [") || t1_prefix ("/Encoding[")) { /* the first case */
+ r = strchr (mp->ps->t1_line_array, '[') + 1;
+ skip (r, ' ');
+ for (;;) {
+ while (*r == '/') {
+ for (p = mp->ps->t1_buf_array, r++;
+ *r != 32 && *r != 10 && *r != ']' && *r != '/';
+ *p++ = *r++);
+ *p = 0;
+ skip (r, ' ');
+ if (counter > 255) {
+ mp_fatal_error
+ (mp, "encoding vector contains more than 256 names");
+ }
+ if (strcmp (mp->ps->t1_buf_array, notdef) != 0)
+ mp->ps->t1_builtin_glyph_names[counter] = mp_xstrdup (mp,mp->ps->t1_buf_array);
+ counter++;
+ }
+ if (*r != 10 && *r != '%') {
+ if (str_prefix (r, "] def")
+ || str_prefix (r, "] readonly def"))
+ break;
+ else {
+ char s[128];
+ remove_eol (r, mp->ps->t1_line_array);
+ snprintf(s,128,"a name or `] def' or `] readonly def' expected: `%s'",
+ mp->ps->t1_line_array);
+ mp_fatal_error(mp,s);
+ }
+ }
+ t1_getline (mp);
+ r = mp->ps->t1_line_array;
+ }
+ } else { /* the second case */
+ p = strchr (mp->ps->t1_line_array, 10);
+ for (;;) {
+ if (*p == 10) {
+ t1_getline (mp);
+ p = mp->ps->t1_line_array;
+ }
+ /*
+ check for `dup <index> <glyph> put'
+ */
+ if (sscanf (p, "dup %i%256s put", &i, mp->ps->t1_buf_array) == 2 &&
+ *mp->ps->t1_buf_array == '/' && valid_code (i)) {
+ if (strcmp (mp->ps->t1_buf_array + 1, notdef) != 0)
+ mp->ps->t1_builtin_glyph_names[i] =
+ mp_xstrdup (mp,mp->ps->t1_buf_array + 1);
+ p = strstr (p, " put") + strlen (" put");
+ skip (p, ' ');
+ }
+ /*
+ check for `dup dup <to> exch <from> get put'
+ */
+ else if (sscanf (p, "dup dup %i exch %i get put", &b, &a) == 2
+ && valid_code (a) && valid_code (b)) {
+ copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a, b);
+ p = strstr (p, " get put") + strlen (" get put");
+ skip (p, ' ');
+ }
+ /*
+ check for `dup dup <from> <size> getinterval <to> exch putinterval'
+ */
+ else if (sscanf
+ (p, "dup dup %i %i getinterval %i exch putinterval",
+ &a, &c, &b) == 3 && valid_code (a) && valid_code (b)
+ && valid_code (c)) {
+ for (i = 0; i < c; i++)
+ copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a + i, b + i);
+ p = strstr (p, " putinterval") + strlen (" putinterval");
+ skip (p, ' ');
+ }
+ /*
+ check for `def' or `readonly def'
+ */
+ else if ((p == mp->ps->t1_line_array || (p > mp->ps->t1_line_array && p[-1] == ' '))
+ && strcmp (p, "def\n") == 0)
+ return;
+ /*
+ skip an unrecognizable word
+ */
+ else {
+ while (*p != ' ' && *p != 10)
+ p++;
+ skip (p, ' ');
+ }
+ }
+ }
+}
+
+static void t1_check_end (MP mp) {
+ if (t1_eof ())
+ return;
+ t1_getline (mp);
+ if (t1_prefix ("{restore}"))
+ t1_putline (mp);
+}
+
+@ @<Types...@>=
+typedef struct {
+ char *ff_name; /* base name of font file */
+ char *ff_path; /* full path to font file */
+} ff_entry;
+
+@ @c
+static boolean t1_open_fontfile (MP mp, fm_entry *fm_cur,const char *open_name_prefix) {
+ ff_entry *ff;
+ ff = check_ff_exist (mp, fm_cur);
+ if (ff->ff_path != NULL) {
+ mp->ps->t1_file = (mp->open_file)(mp,ff->ff_path, "r", mp_filetype_font);
+ } else {
+ mp_warn (mp, "cannot open Type 1 font file for reading");
+ return false;
+ }
+ t1_init_params (mp,(char *)open_name_prefix,fm_cur->ff_name);
+ mp->ps->fontfile_found = true;
+ return true;
+}
+
+static void t1_scan_only (MP mp, int tex_font, fm_entry *fm_cur) {
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ }
+ while (mp->ps->t1_in_eexec == 0);
+ t1_start_eexec (mp,fm_cur);
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ }
+ while (!(t1_charstrings () || t1_subrs ()));
+}
+
+static void t1_include (MP mp, int tex_font, fm_entry *fm_cur) {
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ t1_putline (mp);
+ }
+ while (mp->ps->t1_in_eexec == 0);
+ t1_start_eexec (mp,fm_cur);
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ t1_putline (mp);
+ }
+ while (!(t1_charstrings () || t1_subrs ()));
+ mp->ps->t1_cs = true;
+ do {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ while (!t1_end_eexec ());
+ t1_stop_eexec (mp);
+ if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
+ do {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ while (!t1_cleartomark ());
+ t1_check_end (mp); /* write "{restore}if" if found */
+ }
+}
+
+@
+@d check_subr(SUBR) if (SUBR >= mp->ps->subr_size || SUBR < 0) {
+ char s[128];
+ snprintf(s,128,"Subrs array: entry index out of range (%i)",SUBR);
+ mp_fatal_error(mp,s);
+ }
+
+@c
+static const char **check_cs_token_pair (MP mp) {
+ const char **p = (const char **) cs_token_pairs_list;
+ for (; p[0] != NULL; ++p)
+ if (t1_buf_prefix (p[0]) && t1_buf_suffix (p[1]))
+ return p;
+ return NULL;
+}
+
+static void cs_store (MP mp, boolean is_subr) {
+ char *p;
+ cs_entry *ptr;
+ int subr;
+ for (p = mp->ps->t1_line_array, mp->ps->t1_buf_ptr = mp->ps->t1_buf_array; *p != ' ';
+ *mp->ps->t1_buf_ptr++ = *p++);
+ *mp->ps->t1_buf_ptr = 0;
+ if (is_subr) {
+ subr = t1_scan_num (mp, p + 1, 0);
+ check_subr (subr);
+ ptr = mp->ps->subr_tab + subr;
+ } else {
+ ptr = mp->ps->cs_ptr++;
+ if (mp->ps->cs_ptr - mp->ps->cs_tab > mp->ps->cs_size) {
+ char s[128];
+ snprintf(s,128,"CharStrings dict: more entries than dict size (%i)",mp->ps->cs_size);
+ mp_fatal_error(mp,s);
+ }
+ if (strcmp (mp->ps->t1_buf_array + 1, notdef) == 0) /* skip the slash */
+ ptr->glyph_name = (char *) notdef;
+ else
+ ptr->glyph_name = mp_xstrdup (mp,mp->ps->t1_buf_array + 1);
+ }
+ /* copy " RD " + cs data to |mp->ps->t1_buf_array| */
+ memcpy (mp->ps->t1_buf_array, mp->ps->t1_line_array + mp->ps->cs_start - 4,
+ (unsigned) (mp->ps->t1_cslen + 4));
+ /* copy the end of cs data to |mp->ps->t1_buf_array| */
+ for (p = mp->ps->t1_line_array + mp->ps->cs_start + mp->ps->t1_cslen, mp->ps->t1_buf_ptr =
+ mp->ps->t1_buf_array + mp->ps->t1_cslen + 4; *p != 10; *mp->ps->t1_buf_ptr++ = *p++);
+ *mp->ps->t1_buf_ptr++ = 10;
+ if (is_subr && mp->ps->cs_token_pair == NULL)
+ mp->ps->cs_token_pair = check_cs_token_pair (mp);
+ ptr->len = mp->ps->t1_buf_ptr - mp->ps->t1_buf_array;
+ ptr->cslen = mp->ps->t1_cslen;
+ ptr->data = mp_xmalloc (mp,ptr->len , sizeof (byte));
+ memcpy (ptr->data, mp->ps->t1_buf_array, ptr->len);
+ ptr->valid = true;
+}
+
+#define store_subr(mp) cs_store(mp,true)
+#define store_cs(mp) cs_store(mp,false)
+
+#define CC_STACK_SIZE 24
+
+static integer cc_stack[CC_STACK_SIZE], *stack_ptr = cc_stack;
+static cc_entry cc_tab[CS_MAX];
+static boolean is_cc_init = false;
+
+
+#define cc_pop(N) \
+ if (stack_ptr - cc_stack < (N)) \
+ stack_error(N); \
+ stack_ptr -= N
+
+#define stack_error(N) { \
+ char s[256]; \
+ snprintf(s,255,"CharString: invalid access (%i) to stack (%i entries)", \
+ (int) N, (int)(stack_ptr - cc_stack)); \
+ mp_warn(mp,s); \
+ goto cs_error; \
+}
+
+
+#define cc_get(N) ((N) < 0 ? *(stack_ptr + (N)) : *(cc_stack + (N)))
+
+#define cc_push(V) *stack_ptr++ = V
+#define cc_clear() stack_ptr = cc_stack
+
+#define set_cc(N, B, A, C) \
+ cc_tab[N].nargs = A; \
+ cc_tab[N].bottom = B; \
+ cc_tab[N].clear = C; \
+ cc_tab[N].valid = true
+
+static void cc_init (void) {
+ int i;
+ if (is_cc_init)
+ return;
+ for (i = 0; i < CS_MAX; i++)
+ cc_tab[i].valid = false;
+ set_cc (CS_HSTEM, true, 2, true);
+ set_cc (CS_VSTEM, true, 2, true);
+ set_cc (CS_VMOVETO, true, 1, true);
+ set_cc (CS_RLINETO, true, 2, true);
+ set_cc (CS_HLINETO, true, 1, true);
+ set_cc (CS_VLINETO, true, 1, true);
+ set_cc (CS_RRCURVETO, true, 6, true);
+ set_cc (CS_CLOSEPATH, false, 0, true);
+ set_cc (CS_CALLSUBR, false, 1, false);
+ set_cc (CS_RETURN, false, 0, false);
+ /*
+ |set_cc(CS_ESCAPE, false, 0, false);|
+ */
+ set_cc (CS_HSBW, true, 2, true);
+ set_cc (CS_ENDCHAR, false, 0, true);
+ set_cc (CS_RMOVETO, true, 2, true);
+ set_cc (CS_HMOVETO, true, 1, true);
+ set_cc (CS_VHCURVETO, true, 4, true);
+ set_cc (CS_HVCURVETO, true, 4, true);
+ set_cc (CS_DOTSECTION, false, 0, true);
+ set_cc (CS_VSTEM3, true, 6, true);
+ set_cc (CS_HSTEM3, true, 6, true);
+ set_cc (CS_SEAC, true, 5, true);
+ set_cc (CS_SBW, true, 4, true);
+ set_cc (CS_DIV, false, 2, false);
+ set_cc (CS_CALLOTHERSUBR, false, 0, false);
+ set_cc (CS_POP, false, 0, false);
+ set_cc (CS_SETCURRENTPOINT, true, 2, true);
+ is_cc_init = true;
+}
+
+@
+
+@d cs_getchar(mp) cdecrypt(mp,*data++, &cr)
+
+@d mark_subr(mp,n) cs_mark(mp,0, n)
+@d mark_cs(mp,s) cs_mark(mp,s, 0)
+@d SMALL_BUF_SIZE 256
+
+@c
+static void cs_warn (MP mp, const char *cs_name, int subr, const char *fmt, ...) {
+ char buf[SMALL_BUF_SIZE];
+ char s[300];
+ va_list args;
+ va_start (args, fmt);
+ vsprintf (buf, fmt, args);
+ va_end (args);
+ if (cs_name == NULL) {
+ snprintf(s,299,"Subr (%i): %s", (int) subr, buf);
+ } else {
+ snprintf(s,299,"CharString (/%s): %s", cs_name, buf);
+ }
+ mp_warn(mp,s);
+}
+
+static void cs_mark (MP mp, const char *cs_name, int subr)
+{
+ byte *data;
+ int i, b, cs_len;
+ integer a, a1, a2;
+ unsigned short cr;
+ static integer lastargOtherSubr3 = 3; /* the argument of last call to
+ OtherSubrs[3] */
+ cs_entry *ptr;
+ cc_entry *cc;
+ if (cs_name == NULL) {
+ check_subr (subr);
+ ptr = mp->ps->subr_tab + subr;
+ if (!ptr->valid)
+ return;
+ } else {
+ if (mp->ps->cs_notdef != NULL &&
+ (cs_name == notdef || strcmp (cs_name, notdef) == 0))
+ ptr = mp->ps->cs_notdef;
+ else {
+ for (ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
+ if (strcmp (ptr->glyph_name, cs_name) == 0)
+ break;
+ if (ptr == mp->ps->cs_ptr) {
+ char s[128];
+ snprintf (s,128,"glyph `%s' undefined", cs_name);
+ mp_warn(mp,s);
+ return;
+ }
+ if (ptr->glyph_name == notdef)
+ mp->ps->cs_notdef = ptr;
+ }
+ }
+ /* only marked CharString entries and invalid entries can be skipped;
+ valid marked subrs must be parsed to keep the stack in sync */
+ if (!ptr->valid || (ptr->is_used && cs_name != NULL))
+ return;
+ ptr->is_used = true;
+ cr = 4330;
+ cs_len = ptr->cslen;
+ data = ptr->data + 4;
+ for (i = 0; i < mp->ps->t1_lenIV; i++, cs_len--)
+ cs_getchar (mp);
+ while (cs_len > 0) {
+ --cs_len;
+ b = cs_getchar (mp);
+ if (b >= 32) {
+ if (b <= 246)
+ a = b - 139;
+ else if (b <= 250) {
+ --cs_len;
+ a = ((b - 247) << 8) + 108 + cs_getchar (mp);
+ } else if (b <= 254) {
+ --cs_len;
+ a = -((b - 251) << 8) - 108 - cs_getchar (mp);
+ } else {
+ cs_len -= 4;
+ a = (cs_getchar (mp) & 0xff) << 24;
+ a |= (cs_getchar (mp) & 0xff) << 16;
+ a |= (cs_getchar (mp) & 0xff) << 8;
+ a |= (cs_getchar (mp) & 0xff) << 0;
+ if (sizeof (integer) > 4 && (a & 0x80000000))
+ a |= ~0x7FFFFFFF;
+ }
+ cc_push (a);
+ } else {
+ if (b == CS_ESCAPE) {
+ b = cs_getchar (mp) + CS_1BYTE_MAX;
+ cs_len--;
+ }
+ if (b >= CS_MAX) {
+ cs_warn (mp,cs_name, subr, "command value out of range: %i",
+ (int) b);
+ goto cs_error;
+ }
+ cc = cc_tab + b;
+ if (!cc->valid) {
+ cs_warn (mp,cs_name, subr, "command not valid: %i", (int) b);
+ goto cs_error;
+ }
+ if (cc->bottom) {
+ if (stack_ptr - cc_stack < cc->nargs)
+ cs_warn (mp,cs_name, subr,
+ "less arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ else if (stack_ptr - cc_stack > cc->nargs)
+ cs_warn (mp,cs_name, subr,
+ "more arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ }
+ switch (cc - cc_tab) {
+ case CS_CALLSUBR:
+ a1 = cc_get (-1);
+ cc_pop (1);
+ mark_subr (mp,a1);
+ if (!mp->ps->subr_tab[a1].valid) {
+ cs_warn (mp,cs_name, subr, "cannot call subr (%i)", (int) a1);
+ goto cs_error;
+ }
+ break;
+ case CS_DIV:
+ cc_pop (2);
+ cc_push (0);
+ break;
+ case CS_CALLOTHERSUBR:
+ if (cc_get (-1) == 3)
+ lastargOtherSubr3 = cc_get (-3);
+ a1 = cc_get (-2) + 2;
+ cc_pop (a1);
+ break;
+ case CS_POP:
+ cc_push (lastargOtherSubr3);
+ /* the only case when we care about the value being pushed onto
+ stack is when POP follows CALLOTHERSUBR (changing hints by
+ OtherSubrs[3])
+ */
+ break;
+ case CS_SEAC:
+ a1 = cc_get (3);
+ a2 = cc_get (4);
+ cc_clear ();
+ mark_cs (mp,standard_glyph_names[a1]);
+ mark_cs (mp,standard_glyph_names[a2]);
+ break;
+ default:
+ if (cc->clear)
+ cc_clear ();
+ }
+ }
+ }
+ return;
+ cs_error: /* an error occured during parsing */
+ cc_clear ();
+ ptr->valid = false;
+ ptr->is_used = false;
+}
+
+static void t1_subset_ascii_part (MP mp, int tex_font, fm_entry *fm_cur)
+{
+ int i, j;
+ t1_getline (mp);
+ while (!t1_prefix ("/Encoding")) {
+ t1_scan_param (mp,tex_font, fm_cur);
+ t1_putline (mp);
+ t1_getline (mp);
+ }
+ t1_builtin_enc (mp);
+ if (is_reencoded (fm_cur))
+ mp->ps->t1_glyph_names = external_enc ();
+ else
+ mp->ps->t1_glyph_names = mp->ps->t1_builtin_glyph_names;
+ /*
+ |if (is_included (fm_cur) && is_subsetted (fm_cur)) {
+ make_subset_tag (fm_cur, t1_glyph_names, tex_font);
+ update_subset_tag ();
+ }|
+ */
+ if ((!is_subsetted (fm_cur)) && mp->ps->t1_encoding == ENC_STANDARD)
+ t1_puts (mp,"/Encoding StandardEncoding def\n");
+ else {
+ t1_puts
+ (mp,"/Encoding 256 array\n0 1 255 {1 index exch /.notdef put} for\n");
+ for (i = 0, j = 0; i < 256; i++) {
+ if (is_used_char (i) && mp->ps->t1_glyph_names[i] != notdef) {
+ j++;
+ t1_printf (mp,"dup %i /%s put\n", (int) t1_char (i),
+ mp->ps->t1_glyph_names[i]);
+ }
+ }
+ /* We didn't mark anything for the Encoding array. */
+ /* We add "dup 0 /.notdef put" for compatibility */
+ /* with Acrobat 5.0. */
+ if (j == 0)
+ t1_puts (mp,"dup 0 /.notdef put\n");
+ t1_puts (mp,"readonly def\n");
+ }
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ if (!t1_prefix ("/UniqueID")) /* ignore UniqueID for subsetted fonts */
+ t1_putline (mp);
+ }
+ while (mp->ps->t1_in_eexec == 0);
+}
+
+#define t1_subr_flush(mp) t1_flush_cs(mp,true)
+#define t1_cs_flush(mp) t1_flush_cs(mp,false)
+
+static void cs_init (MP mp) {
+ mp->ps->cs_ptr = mp->ps->cs_tab = NULL;
+ mp->ps->cs_dict_start = mp->ps->cs_dict_end = NULL;
+ mp->ps->cs_count = mp->ps->cs_size = mp->ps->cs_size_pos = 0;
+ mp->ps->cs_token_pair = NULL;
+ mp->ps->subr_tab = NULL;
+ mp->ps->subr_array_start = mp->ps->subr_array_end = NULL;
+ mp->ps->subr_max = mp->ps->subr_size = mp->ps->subr_size_pos = 0;
+}
+
+static void init_cs_entry ( cs_entry * cs) {
+ cs->data = NULL;
+ cs->glyph_name = NULL;
+ cs->len = 0;
+ cs->cslen = 0;
+ cs->is_used = false;
+ cs->valid = false;
+}
+
+static void t1_mark_glyphs (MP mp, int tex_font);
+
+static void t1_read_subrs (MP mp, int tex_font, fm_entry *fm_cur)
+{
+ int i, s;
+ cs_entry *ptr;
+ t1_getline (mp);
+ while (!(t1_charstrings () || t1_subrs ())) {
+ t1_scan_param (mp,tex_font, fm_cur);
+ t1_putline (mp);
+ t1_getline (mp);
+ }
+ FOUND:
+ mp->ps->t1_cs = true;
+ mp->ps->t1_scan = false;
+ if (!t1_subrs ())
+ return;
+ mp->ps->subr_size_pos = strlen ("/Subrs") + 1;
+ /* |subr_size_pos| points to the number indicating dict size after "/Subrs" */
+ mp->ps->subr_size = t1_scan_num (mp,mp->ps->t1_line_array + mp->ps->subr_size_pos, 0);
+ if (mp->ps->subr_size == 0) {
+ while (!t1_charstrings ())
+ t1_getline (mp);
+ return;
+ }
+ /* |subr_tab = xtalloc (subr_size, cs_entry);| */
+ mp->ps->subr_tab = (cs_entry *)mp_xmalloc (mp,mp->ps->subr_size, sizeof (cs_entry));
+ for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
+ init_cs_entry (ptr);
+ mp->ps->subr_array_start = mp_xstrdup (mp,mp->ps->t1_line_array);
+ t1_getline (mp);
+ while (mp->ps->t1_cslen) {
+ store_subr (mp);
+ t1_getline (mp);
+ }
+ /* mark the first four entries without parsing */
+ for (i = 0; i < mp->ps->subr_size && i < 4; i++)
+ mp->ps->subr_tab[i].is_used = true;
+ /* the end of the Subrs array might have more than one line so we need to
+ concatnate them to |subr_array_end|. Unfortunately some fonts don't have
+ the Subrs array followed by the CharStrings dict immediately (synthetic
+ fonts). If we cannot find CharStrings in next |POST_SUBRS_SCAN| lines then
+ we will treat the font as synthetic and ignore everything until next
+ Subrs is found
+ */
+#define POST_SUBRS_SCAN 5
+ s = 0;
+ *mp->ps->t1_buf_array = 0;
+ for (i = 0; i < POST_SUBRS_SCAN; i++) {
+ if (t1_charstrings ())
+ break;
+ s += mp->ps->t1_line_ptr - mp->ps->t1_line_array;
+ alloc_array (t1_buf, s, T1_BUF_SIZE);
+ strcat (mp->ps->t1_buf_array, mp->ps->t1_line_array);
+ t1_getline (mp);
+ }
+ mp->ps->subr_array_end = mp_xstrdup (mp,mp->ps->t1_buf_array);
+ if (i == POST_SUBRS_SCAN) { /* CharStrings not found;
+ suppose synthetic font */
+ for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
+ if (ptr->valid)
+ mp_xfree (ptr->data);
+ mp_xfree (mp->ps->subr_tab);
+ mp_xfree (mp->ps->subr_array_start);
+ mp_xfree (mp->ps->subr_array_end);
+ cs_init (mp);
+ mp->ps->t1_cs = false;
+ mp->ps->t1_synthetic = true;
+ while (!(t1_charstrings () || t1_subrs ()))
+ t1_getline (mp);
+ goto FOUND;
+ }
+}
+
+@ @c
+static void t1_flush_cs (MP mp, boolean is_subr)
+{
+ char *p;
+ byte *r, *return_cs = NULL;
+ cs_entry *tab, *end_tab, *ptr;
+ char *start_line, *line_end;
+ int count, size_pos;
+ unsigned short cr, cs_len = 0; /* to avoid warning about uninitialized use of |cs_len| */
+ if (is_subr) {
+ start_line = mp->ps->subr_array_start;
+ line_end = mp->ps->subr_array_end;
+ size_pos = mp->ps->subr_size_pos;
+ tab = mp->ps->subr_tab;
+ count = mp->ps->subr_max + 1;
+ end_tab = mp->ps->subr_tab + count;
+ } else {
+ start_line = mp->ps->cs_dict_start;
+ line_end = mp->ps->cs_dict_end;
+ size_pos = mp->ps->cs_size_pos;
+ tab = mp->ps->cs_tab;
+ end_tab = mp->ps->cs_ptr;
+ count = mp->ps->cs_count;
+ }
+ mp->ps->t1_line_ptr = mp->ps->t1_line_array;
+ for (p = start_line; p - start_line < size_pos;)
+ *mp->ps->t1_line_ptr++ = *p++;
+ while (isdigit (*p))
+ p++;
+ sprintf (mp->ps->t1_line_ptr, "%u", count);
+ strcat (mp->ps->t1_line_ptr, p);
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+ t1_putline (mp);
+
+ /* create |return_cs| to replace unsused subr's */
+ if (is_subr) {
+ cr = 4330;
+ cs_len = 0;
+ return_cs = mp_xmalloc (mp, (mp->ps->t1_lenIV + 1) , sizeof(byte));
+ if ( mp->ps->t1_lenIV > 0) {
+ for (cs_len = 0, r = return_cs; cs_len < mp->ps->t1_lenIV; cs_len++, r++)
+ *r = cencrypt (mp,0x00, &cr);
+ *r = cencrypt (mp,CS_RETURN, &cr);
+ } else {
+ *return_cs = CS_RETURN;
+ }
+ cs_len++;
+ }
+
+ for (ptr = tab; ptr < end_tab; ptr++) {
+ if (ptr->is_used) {
+ if (is_subr)
+ sprintf (mp->ps->t1_line_array, "dup %i %u", (int) (ptr - tab),
+ ptr->cslen);
+ else
+ sprintf (mp->ps->t1_line_array, "/%s %u", ptr->glyph_name, ptr->cslen);
+ p = strend (mp->ps->t1_line_array);
+ memcpy (p, ptr->data, ptr->len);
+ mp->ps->t1_line_ptr = p + ptr->len;
+ t1_putline (mp);
+ } else {
+ /* replace unsused subr's by |return_cs| */
+ if (is_subr) {
+ sprintf (mp->ps->t1_line_array, "dup %i %u%s ", (int) (ptr - tab),
+ cs_len, mp->ps->cs_token_pair[0]);
+ p = strend (mp->ps->t1_line_array);
+ memcpy (p, return_cs, cs_len);
+ mp->ps->t1_line_ptr = p + cs_len;
+ t1_putline (mp);
+ sprintf (mp->ps->t1_line_array, " %s", mp->ps->cs_token_pair[1]);
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+ t1_putline (mp);
+ }
+ }
+ mp_xfree (ptr->data);
+ if (ptr->glyph_name != notdef)
+ mp_xfree (ptr->glyph_name);
+ }
+ sprintf (mp->ps->t1_line_array, "%s", line_end);
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+ t1_putline (mp);
+ if (is_subr)
+ mp_xfree (return_cs);
+ mp_xfree (tab);
+ mp_xfree (start_line);
+ mp_xfree (line_end);
+}
+
+static void t1_mark_glyphs (MP mp, int tex_font)
+{
+ int i;
+ char *charset = extra_charset ();
+ char *g, *s, *r;
+ cs_entry *ptr;
+ if (mp->ps->t1_synthetic || embed_all_glyphs (tex_font)) { /* mark everything */
+ if (mp->ps->cs_tab != NULL)
+ for (ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
+ if (ptr->valid)
+ ptr->is_used = true;
+ if (mp->ps->subr_tab != NULL) {
+ for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
+ if (ptr->valid)
+ ptr->is_used = true;
+ mp->ps->subr_max = mp->ps->subr_size - 1;
+ }
+ return;
+ }
+ mark_cs (mp,notdef);
+ for (i = 0; i < 256; i++)
+ if (is_used_char (i)) {
+ if (mp->ps->t1_glyph_names[i] == notdef) {
+ char S[128];
+ snprintf(S,128, "character %i is mapped to %s", i, notdef);
+ mp_warn(mp,S);
+ } else
+ mark_cs (mp,mp->ps->t1_glyph_names[i]);
+ }
+ if (charset == NULL)
+ goto SET_SUBR_MAX;
+ g = s = charset + 1; /* skip the first '/' */
+ r = strend (g);
+ while (g < r) {
+ while (*s != '/' && s < r)
+ s++;
+ *s = 0; /* terminate g by rewriting '/' to 0 */
+ mark_cs (mp,g);
+ g = s + 1;
+ }
+ SET_SUBR_MAX:
+ if (mp->ps->subr_tab != NULL)
+ for (mp->ps->subr_max = -1, ptr = mp->ps->subr_tab;
+ ptr - mp->ps->subr_tab < mp->ps->subr_size;
+ ptr++)
+ if (ptr->is_used && ptr - mp->ps->subr_tab > mp->ps->subr_max)
+ mp->ps->subr_max = ptr - mp->ps->subr_tab;
+}
+
+static void t1_subset_charstrings (MP mp, int tex_font)
+{
+ cs_entry *ptr;
+ mp->ps->cs_size_pos =
+ strstr (mp->ps->t1_line_array, charstringname) + strlen (charstringname)
+ - mp->ps->t1_line_array + 1;
+ /* |cs_size_pos| points to the number indicating
+ dict size after "/CharStrings" */
+ mp->ps->cs_size = t1_scan_num (mp,mp->ps->t1_line_array + mp->ps->cs_size_pos, 0);
+ mp->ps->cs_ptr = mp->ps->cs_tab = mp_xmalloc (mp,mp->ps->cs_size, sizeof(cs_entry));
+ for (ptr = mp->ps->cs_tab; ptr - mp->ps->cs_tab < mp->ps->cs_size; ptr++)
+ init_cs_entry (ptr);
+ mp->ps->cs_notdef = NULL;
+ mp->ps->cs_dict_start = mp_xstrdup (mp,mp->ps->t1_line_array);
+ t1_getline (mp);
+ while (mp->ps->t1_cslen) {
+ store_cs (mp);
+ t1_getline (mp);
+ }
+ mp->ps->cs_dict_end = mp_xstrdup (mp,mp->ps->t1_line_array);
+ t1_mark_glyphs (mp,tex_font);
+ if (mp->ps->subr_tab != NULL) {
+ if (mp->ps->cs_token_pair == NULL)
+ mp_fatal_error
+ (mp, "This Type 1 font uses mismatched subroutine begin/end token pairs.");
+ t1_subr_flush (mp);
+ }
+ for (mp->ps->cs_count = 0, ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
+ if (ptr->is_used)
+ mp->ps->cs_count++;
+ t1_cs_flush (mp);
+}
+
+static void t1_subset_end (MP mp)
+{
+ if (mp->ps->t1_synthetic) { /* copy to "dup /FontName get exch definefont pop" */
+ while (!strstr (mp->ps->t1_line_array, "definefont")) {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ while (!t1_end_eexec ())
+ t1_getline (mp); /* ignore the rest */
+ t1_putline (mp); /* write "mark currentfile closefile" */
+ } else
+ while (!t1_end_eexec ()) { /* copy to "mark currentfile closefile" */
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ t1_stop_eexec (mp);
+ if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
+ while (!t1_cleartomark ()) {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ if (!mp->ps->t1_synthetic) /* don't check "{restore}if" for synthetic fonts */
+ t1_check_end (mp); /* write "{restore}if" if found */
+ }
+}
+
+static int t1_updatefm (MP mp, int f, fm_entry *fm)
+{
+ char *s, *p;
+ mp->ps->read_encoding_only = true;
+ if (!t1_open_fontfile (mp,fm,NULL)) {
+ return 0;
+ }
+ t1_scan_only (mp,f, fm);
+ s = mp_xstrdup(mp,mp->ps->fontname_buf);
+ p = s;
+ while (*p != ' ' && *p != 0)
+ p++;
+ *p=0;
+ fm->ps_name = s;
+ t1_close_font_file (mp,"");
+ return 1;
+}
+
+
+static void writet1 (MP mp, int tex_font, fm_entry *fm_cur) {
+ int save_selector = mp->selector;
+ mp_normalize_selector(mp);
+ mp->ps->read_encoding_only = false;
+ if (!is_included (fm_cur)) { /* scan parameters from font file */
+ if (!t1_open_fontfile (mp,fm_cur,"{"))
+ return;
+ t1_scan_only (mp,tex_font, fm_cur);
+ t1_close_font_file (mp,"}");
+ return;
+ }
+ if (!is_subsetted (fm_cur)) { /* include entire font */
+ if (!t1_open_fontfile (mp,fm_cur,"<<"))
+ return;
+ t1_include (mp,tex_font,fm_cur);
+ t1_close_font_file (mp,">>");
+ return;
+ }
+ /* partial downloading */
+ if (!t1_open_fontfile (mp,fm_cur,"<"))
+ return;
+ t1_subset_ascii_part (mp,tex_font,fm_cur);
+ t1_start_eexec (mp,fm_cur);
+ cc_init ();
+ cs_init (mp);
+ t1_read_subrs (mp,tex_font, fm_cur);
+ t1_subset_charstrings (mp,tex_font);
+ t1_subset_end (mp);
+ t1_close_font_file (mp,">");
+ mp->selector = save_selector;
+}
+
+@ @<Declarations@>=
+static void t1_free (MP mp);
+
+@ @c
+static void t1_free (MP mp) {
+ mp_xfree (mp->ps->t1_line_array);
+ mp_xfree (mp->ps->t1_buf_array);
+}
+
+
+@* \[44d] Embedding fonts.
+
+@ The |tfm_num| is officially of type |font_number|, but that
+type does not exist yet at this point in the output order.
+
+@<Types...@>=
+typedef struct {
+ char *tfm_name; /* TFM file name */
+ char *ps_name; /* PostScript name */
+ integer flags; /* font flags */
+ char *ff_name; /* font file name */
+ char *subset_tag; /* pseudoUniqueTag for subsetted font */
+ enc_entry *encoding; /* pointer to corresponding encoding */
+ unsigned int tfm_num; /* number of the TFM refering this entry */
+ unsigned short type; /* font type (T1/TTF/...) */
+ short slant; /* SlantFont */
+ short extend; /* ExtendFont */
+ integer ff_objnum; /* FontFile object number */
+ integer fn_objnum; /* FontName/BaseName object number */
+ integer fd_objnum; /* FontDescriptor object number */
+ char *charset; /* string containing used glyphs */
+ boolean all_glyphs; /* embed all glyphs? */
+ unsigned short links; /* link flags from |tfm_tree| and |ps_tree| */
+ short tfm_avail; /* flags whether a tfm is available */
+ short pid; /* Pid for truetype fonts */
+ short eid; /* Eid for truetype fonts */
+} fm_entry;
+
+
+@
+@<Glob...@>=
+#define FONTNAME_BUF_SIZE 128
+boolean fontfile_found;
+boolean is_otf_font;
+char fontname_buf[FONTNAME_BUF_SIZE];
+
+@
+@d F_INCLUDED 0x01
+@d F_SUBSETTED 0x02
+@d F_TRUETYPE 0x04
+@d F_BASEFONT 0x08
+
+@d set_included(fm) ((fm)->type |= F_INCLUDED)
+@d set_subsetted(fm) ((fm)->type |= F_SUBSETTED)
+@d set_truetype(fm) ((fm)->type |= F_TRUETYPE)
+@d set_basefont(fm) ((fm)->type |= F_BASEFONT)
+
+@d is_included(fm) ((fm)->type & F_INCLUDED)
+@d is_subsetted(fm) ((fm)->type & F_SUBSETTED)
+@d is_truetype(fm) ((fm)->type & F_TRUETYPE)
+@d is_basefont(fm) ((fm)->type & F_BASEFONT)
+@d is_reencoded(fm) ((fm)->encoding != NULL)
+@d is_fontfile(fm) (fm_fontfile(fm) != NULL)
+@d is_t1fontfile(fm) (is_fontfile(fm) && !is_truetype(fm))
+
+@d fm_slant(fm) (fm)->slant
+@d fm_extend(fm) (fm)->extend
+@d fm_fontfile(fm) (fm)->ff_name
+
+@<Declarations@>=
+static boolean mp_font_is_reencoded (MP mp, int f);
+static boolean mp_font_is_included (MP mp, int f);
+static boolean mp_font_is_subsetted (MP mp, int f);
+
+@ @c
+static boolean mp_font_is_reencoded (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL
+ && (fm->ps_name != NULL)
+ && is_reencoded (fm))
+ return 1;
+ }
+ return 0;
+}
+static boolean mp_font_is_included (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL
+ && (fm->ps_name != NULL && fm->ff_name != NULL)
+ && is_included (fm))
+ return 1;
+ }
+ return 0;
+}
+static boolean mp_font_is_subsetted (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f,&fm)) {
+ if (fm != NULL
+ && (fm->ps_name != NULL && fm->ff_name != NULL)
+ && is_included (fm) && is_subsetted (fm))
+ return 1;
+ }
+ return 0;
+}
+
+@ @<Exported function headers@>=
+char * mp_fm_encoding_name (MP mp, int f);
+char * mp_fm_font_name (MP mp, int f);
+
+@ @<Declarations@>=
+static char * mp_fm_font_subset_name (MP mp, int f);
+
+@
+@c char * mp_fm_encoding_name (MP mp, int f) {
+ enc_entry *e;
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (is_reencoded (fm)) {
+ e = fm->encoding;
+ if (e->enc_name!=NULL)
+ return mp_xstrdup(mp,e->enc_name);
+ } else {
+ return NULL;
+ }
+ }
+ }
+ print_err ("fontmap encoding problems for font ");
+ mp_print(mp,mp->font_name[f]);
+ mp_error(mp);
+ return NULL;
+}
+char * mp_fm_font_name (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f,&fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (mp_font_is_included(mp, f) && !mp->font_ps_name_fixed[f]) {
+ /* find the real fontname, and update |ps_name| and |subset_tag| if needed */
+ if (t1_updatefm(mp,f,fm)) {
+ mp->font_ps_name_fixed[f] = true;
+ } else {
+ print_err ("font loading problems for font ");
+ mp_print(mp,mp->font_name[f]);
+ mp_error(mp);
+ }
+ }
+ return mp_xstrdup(mp,fm->ps_name);
+ }
+ }
+ print_err ("fontmap name problems for font ");
+ mp_print(mp,mp->font_name[f]);
+ mp_error(mp);
+ return NULL;
+}
+
+static char * mp_fm_font_subset_name (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (is_subsetted(fm)) {
+ char *s = mp_xmalloc(mp,strlen(fm->ps_name)+8,1);
+ snprintf(s,strlen(fm->ps_name)+8,"%s-%s",fm->subset_tag,fm->ps_name);
+ return s;
+ } else {
+ return mp_xstrdup(mp,fm->ps_name);
+ }
+ }
+ }
+ print_err ("fontmap name problems for font ");
+ mp_print(mp,mp->font_name[f]);
+ mp_error(mp);
+ return NULL;
+}
+
+@ @<Declarations@>=
+static integer mp_fm_font_slant (MP mp, int f);
+static integer mp_fm_font_extend (MP mp, int f);
+
+@
+@c static integer mp_fm_font_slant (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ return fm->slant;
+ }
+ }
+ return 0;
+}
+static integer mp_fm_font_extend (MP mp, int f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ return fm->extend;
+ }
+ }
+ return 0;
+}
+
+@ @<Declarations@>=
+static boolean mp_do_ps_font (MP mp, font_number f);
+
+@ @c static boolean mp_do_ps_font (MP mp, font_number f) {
+ fm_entry *fm_cur;
+ (void)mp_has_fm_entry (mp, f, &fm_cur); /* for side effects */
+ if (fm_cur == NULL)
+ return 1;
+ if (is_truetype(fm_cur) ||
+ (fm_cur->ps_name == NULL && fm_cur->ff_name == NULL)) {
+ return 0;
+ }
+ if (is_included(fm_cur)) {
+ mp_ps_print_nl(mp,"%%BeginResource: font ");
+ if (is_subsetted(fm_cur)) {
+ mp_ps_print(mp, fm_cur->subset_tag);
+ mp_ps_print_char(mp,'-');
+ }
+ mp_ps_print(mp, fm_cur->ps_name);
+ mp_ps_print_ln(mp);
+ writet1 (mp,f,fm_cur);
+ mp_ps_print_nl(mp,"%%EndResource");
+ mp_ps_print_ln(mp);
+ }
+ return 1;
+}
+
+@ Included subset fonts do not need and encoding vector, make
+sure we skip that case.
+
+@<Declarations@>=
+static void mp_list_used_resources (MP mp, int prologues, int procset);
+
+@ @c static void mp_list_used_resources (MP mp, int prologues, int procset) {
+ font_number f; /* fonts used in a text node or as loop counters */
+ int ff; /* a loop counter */
+ font_number ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ boolean firstitem;
+ if ( procset>0 )
+ mp_ps_print_nl(mp, "%%DocumentResources: procset mpost");
+ else
+ mp_ps_print_nl(mp, "%%DocumentResources: procset mpost-minimal");
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( (mp_has_font_size(mp,f))&&(mp_font_is_reencoded(mp,f)) ) {
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp_has_font_size(mp,ff) )
+ if ( mp_xstrcmp(mp->font_enc_name[f],mp->font_enc_name[ff])==0 )
+ goto FOUND;
+ }
+ if ( mp_font_is_subsetted(mp,f) )
+ goto FOUND;
+ if ( mp->ps->ps_offset+1+strlen(mp->font_enc_name[f])>
+ (unsigned)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ encoding");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ encoding");
+ }
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print(mp, mp->font_enc_name[f]);
+ ldf=f;
+ }
+ FOUND:
+ ;
+ }
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp_has_font_size(mp,ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND2;
+ }
+ if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>
+ (unsigned)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ font");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ font");
+ }
+ mp_ps_print_char(mp, ' ');
+ if ( (prologues==3)&&
+ (mp_font_is_subsetted(mp,f)) )
+ mp_ps_print(mp, mp_fm_font_subset_name(mp,f));
+ else
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ ldf=f;
+ }
+ FOUND2:
+ ;
+ }
+ mp_ps_print_ln(mp);
+}
+
+@ @<Declarations@>=
+static void mp_list_supplied_resources (MP mp, int prologues, int procset);
+
+@ @c static void mp_list_supplied_resources (MP mp, int prologues, int procset) {
+ font_number f; /* fonts used in a text node or as loop counters */
+ int ff; /* a loop counter */
+ font_number ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ boolean firstitem;
+ if ( procset>0 )
+ mp_ps_print_nl(mp, "%%DocumentSuppliedResources: procset mpost");
+ else
+ mp_ps_print_nl(mp, "%%DocumentSuppliedResources: procset mpost-minimal");
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( (mp_has_font_size(mp,f))&&(mp_font_is_reencoded(mp,f)) ) {
+ for (ff=ldf;ff>= null_font;ff++) {
+ if ( mp_has_font_size(mp,ff) )
+ if ( mp_xstrcmp(mp->font_enc_name[f],mp->font_enc_name[ff])==0 )
+ goto FOUND;
+ }
+ if ( (prologues==3)&&(mp_font_is_subsetted(mp,f)))
+ goto FOUND;
+ if ( mp->ps->ps_offset+1+strlen(mp->font_enc_name[f])>(unsigned)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ encoding");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ encoding");
+ }
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print(mp, mp->font_enc_name[f]);
+ ldf=f;
+ }
+ FOUND:
+ ;
+ }
+ ldf=null_font;
+ firstitem=true;
+ if (prologues==3) {
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ for (ff=ldf;ff>= null_font;ff--) {
+ if ( mp_has_font_size(mp,ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND2;
+ }
+ if ( ! mp_font_is_included(mp,f) )
+ goto FOUND2;
+ if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(unsigned)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ font");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ font");
+ }
+ mp_ps_print_char(mp, ' ');
+ if ( mp_font_is_subsetted(mp,f) )
+ mp_ps_print(mp, mp_fm_font_subset_name(mp,f));
+ else
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ ldf=f;
+ }
+ FOUND2:
+ ;
+ }
+ mp_ps_print_ln(mp);
+ }
+}
+
+@ @<Declarations...@>=
+static void mp_list_needed_resources (MP mp, int prologues);
+
+@ @c static void mp_list_needed_resources (MP mp, int prologues) {
+ font_number f; /* fonts used in a text node or as loop counters */
+ int ff; /* a loop counter */
+ font_number ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ boolean firstitem;
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++ ) {
+ if ( mp_has_font_size(mp,f)) {
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp_has_font_size(mp,ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND;
+ };
+ if ((prologues==3)&&(mp_font_is_included(mp,f)) )
+ goto FOUND;
+ if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(unsigned)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ font");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%DocumentNeededResources: font");
+ }
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ ldf=f;
+ }
+ FOUND:
+ ;
+ }
+ if ( ! firstitem ) {
+ mp_ps_print_ln(mp);
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<= mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ for (ff=ldf;ff>=null_font;ff-- ) {
+ if ( mp_has_font_size(mp,ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND2;
+ }
+ if ((prologues==3)&&(mp_font_is_included(mp,f)) )
+ goto FOUND2;
+ mp_ps_print(mp, "%%IncludeResource: font ");
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ mp_ps_print_ln(mp);
+ ldf=f;
+ }
+ FOUND2:
+ ;
+ }
+ }
+}
+
+@ @<Declarations@>=
+static void mp_write_font_definition (MP mp, font_number f, int prologues);
+
+@
+
+@d applied_reencoding(A) ((mp_font_is_reencoded(mp,(A)))&&
+ ((! mp_font_is_subsetted(mp,(A)))||(prologues==2)))
+
+@c static void mp_write_font_definition(MP mp, font_number f, int prologues) {
+ if ( (applied_reencoding(f))||(mp_fm_font_slant(mp,f)!=0)||
+ (mp_fm_font_extend(mp,f)!=0)||
+ (mp_xstrcmp(mp->font_name[f],"psyrgo")==0)||
+ (mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0) ) {
+ if ( (mp_font_is_subsetted(mp,f))&&
+ (mp_font_is_included(mp,f))&&(prologues==3))
+ mp_ps_name_out(mp, mp_fm_font_subset_name(mp,f),true);
+ else
+ mp_ps_name_out(mp, mp->font_ps_name[f],true);
+ mp_ps_print(mp, " fcp");
+ mp_ps_print_ln(mp);
+ if ( applied_reencoding(f) ) {
+ mp_ps_print(mp, "/Encoding ");
+ mp_ps_print(mp, mp->font_enc_name[f]);
+ mp_ps_print(mp, " def ");
+ };
+ if ( mp_fm_font_slant(mp,f)!=0 ) {
+ mp_ps_print_int(mp, mp_fm_font_slant(mp,f));
+ mp_ps_print(mp, " SlantFont ");
+ };
+ if ( mp_fm_font_extend(mp,f)!=0 ) {
+ mp_ps_print_int(mp, mp_fm_font_extend(mp,f));
+ mp_ps_print(mp, " ExtendFont ");
+ };
+ if ( mp_xstrcmp(mp->font_name[f],"psyrgo")==0 ) {
+ mp_ps_print(mp, " 890 ScaleFont ");
+ mp_ps_print(mp, " 277 SlantFont ");
+ };
+ if ( mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0 ) {
+ mp_ps_print(mp, " FontMatrix [-1 0 0 1 0 0] matrix concatmatrix /FontMatrix exch def ");
+ mp_ps_print(mp, "/Metrics 2 dict dup begin ");
+ mp_ps_print(mp, "/space[0 -278]def ");
+ mp_ps_print(mp, "/a12[-904 -939]def ");
+ mp_ps_print(mp, "end def ");
+ };
+ mp_ps_print(mp, "currentdict end");
+ mp_ps_print_ln(mp);
+ mp_ps_print_defined_name(mp,f,prologues);
+ mp_ps_print(mp, " exch definefont pop");
+ mp_ps_print_ln(mp);
+ }
+}
+
+@ @<Declarations@>=
+static void mp_ps_print_defined_name (MP mp, font_number f, int prologues);
+
+@
+@c static void mp_ps_print_defined_name(MP mp, font_number A, int prologues) {
+ mp_ps_print(mp, " /");
+ if ((mp_font_is_subsetted(mp,(A)))&&
+ (mp_font_is_included(mp,(A)))&&(prologues==3))
+ mp_ps_print(mp, mp_fm_font_subset_name(mp,(A)));
+ else
+ mp_ps_print(mp, mp->font_ps_name[(A)]);
+ if ( mp_xstrcmp(mp->font_name[(A)],"psyrgo")==0 )
+ mp_ps_print(mp, "-Slanted");
+ if ( mp_xstrcmp(mp->font_name[(A)],"zpzdr-reversed")==0 )
+ mp_ps_print(mp, "-Reverse");
+ if ( applied_reencoding((A)) ) {
+ mp_ps_print(mp, "-");
+ mp_ps_print(mp, mp->font_enc_name[(A)]);
+ }
+ if ( mp_fm_font_slant(mp,(A))!=0 ) {
+ mp_ps_print(mp, "-Slant_"); mp_ps_print_int(mp, mp_fm_font_slant(mp,(A))) ;
+ }
+ if ( mp_fm_font_extend(mp,(A))!=0 ) {
+ mp_ps_print(mp, "-Extend_"); mp_ps_print_int(mp, mp_fm_font_extend(mp,(A)));
+ }
+}
+
+@ @<Include encodings and fonts for edge structure~|h|@>=
+mp_font_encodings(mp,mp->last_fnum,(prologues==2));
+@<Embed fonts that are available@>
+
+@ @<Embed fonts that are available@>=
+{
+next_size=0;
+@<Make |cur_fsize| a copy of the |font_sizes| array@>;
+do {
+ done_fonts=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( cur_fsize[f]!=null ) {
+ if (prologues==3 ) {
+ if ( ! mp_do_ps_font(mp,f) ) {
+ if ( mp_has_fm_entry(mp,f, NULL) ) {
+ print_err("Font embedding failed");
+ mp_error(mp);
+ }
+ }
+ }
+ cur_fsize[f]=link(cur_fsize[f]);
+ if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; }
+ }
+ }
+ if ( ! done_fonts )
+ @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
+ that size index@>;
+} while (! done_fonts);
+}
+
+@ @<Increment |next_size| and apply |mark_string_chars| to all text nodes...@>=
+{
+ next_size++;
+ mp_apply_mark_string_chars(mp, h, next_size);
+}
+
+@ We also need to keep track of which characters are used in text nodes
+in the edge structure that is being shipped out. This is done by procedures
+that use the left-over |b3| field in the |char_info| words; i.e.,
+|char_info(f)(c).b3| gives the status of character |c| in font |f|.
+
+@<Types...@>=
+enum mp_char_mark_state {mp_unused=0, mp_used};
+
+@ @<Exported...@>=
+void mp_mark_string_chars (MP mp,font_number f, char *s) ;
+
+@ @c
+void mp_mark_string_chars (MP mp,font_number f, char *s) {
+ integer b; /* |char_base[f]| */
+ ASCII_code bc,ec; /* only characters between these bounds are marked */
+ char *k; /* an index into string |s| */
+ b=mp->char_base[f];
+ bc=mp->font_bc[f];
+ ec=mp->font_ec[f];
+ k=s; /* str_stop */
+ while (*k){
+ if ( (*k>=bc)&&(*k<=ec) )
+ mp->font_info[b+*k].qqqq.b3=mp_used;
+ k++;
+ }
+}
+
+
+@ @<Exported ...@>=
+void mp_unmark_font (MP mp,font_number f) ;
+
+@ @c
+void mp_unmark_font (MP mp,font_number f) {
+ int k; /* an index into |font_info| */
+ for (k= mp->char_base[f]+mp->font_bc[f];
+ k<=mp->char_base[f]+mp->font_ec[f];
+ k++)
+ mp->font_info[k].qqqq.b3=mp_unused;
+}
+
+
+@ @<Exported...@>=
+void mp_print_improved_prologue (MP mp, mp_edge_object *h, int prologues, int procset) ;
+
+@ @c
+void mp_print_improved_prologue (MP mp, mp_edge_object *h, int prologues, int procset) {
+ quarterword next_size; /* the size index for fonts being listed */
+ pointer *cur_fsize; /* current positions in |font_sizes| */
+ boolean done_fonts; /* have we finished listing the fonts in the header? */
+ font_number f; /* a font number for loops */
+ cur_fsize = mp_xmalloc(mp,(mp->font_max+1),sizeof(pointer));
+ mp_list_used_resources(mp, prologues, procset);
+ mp_list_supplied_resources(mp, prologues, procset);
+ mp_list_needed_resources(mp, prologues);
+ mp_ps_print_nl(mp, "%%EndComments");
+ mp_ps_print_nl(mp, "%%BeginProlog");
+ if ( procset>0 )
+ mp_ps_print_nl(mp, "%%BeginResource: procset mpost");
+ else
+ mp_ps_print_nl(mp, "%%BeginResource: procset mpost-minimal");
+ mp_ps_print_nl(mp, "/bd{bind def}bind def"
+ "/fshow {exch findfont exch scalefont setfont show}bd");
+ if ( procset>0 ) @<Print the procset@>;
+ mp_ps_print_nl(mp, "/fcp{findfont dup length dict begin"
+ "{1 index/FID ne{def}{pop pop}ifelse}forall}bd");
+ mp_ps_print_nl(mp, "/fmc{FontMatrix dup length array copy dup dup}bd"
+ "/fmd{/FontMatrix exch def}bd");
+ mp_ps_print_nl(mp, "/Amul{4 -1 roll exch mul 1000 div}bd"
+ "/ExtendFont{fmc 0 get Amul 0 exch put fmd}bd");
+ mp_ps_print_nl(mp, "/ScaleFont{dup fmc 0 get"
+ " Amul 0 exch put dup dup 3 get Amul 3 exch put fmd}bd");
+ mp_ps_print_nl(mp, "/SlantFont{fmc 2 get dup 0 eq{pop 1}if"
+ " Amul FontMatrix 0 get mul 2 exch put fmd}bd");
+ mp_ps_print_nl(mp, "%%EndResource");
+ @<Include encodings and fonts for edge structure~|h|@>;
+ mp_ps_print_nl(mp, "%%EndProlog");
+ mp_ps_print_nl(mp, "%%BeginSetup");
+ mp_ps_print_ln(mp);
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ if ( mp_has_fm_entry(mp,f,NULL) ) {
+ mp_write_font_definition(mp,f, prologues);
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_print_defined_name(mp,f, prologues);
+ mp_ps_print(mp, " def");
+ } else {
+ char s[256];
+ snprintf(s,256,"font %s cannot be found in any fontmapfile!", mp->font_name[f]);
+ mp_warn(mp,s);
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_print(mp, " def");
+ }
+ mp_ps_print_ln(mp);
+ }
+ }
+ mp_ps_print_nl(mp, "%%EndSetup");
+ mp_ps_print_nl(mp, "%%Page: 1 1");
+ mp_ps_print_ln(mp);
+ mp_xfree(cur_fsize);
+}
+
+@ @<Declarations@>=
+static font_number mp_print_font_comments (MP mp , mp_edge_object *h, int prologues);
+
+
+@
+@c
+static font_number mp_print_font_comments (MP mp , mp_edge_object *h, int prologues) {
+ quarterword next_size; /* the size index for fonts being listed */
+ pointer *cur_fsize; /* current positions in |font_sizes| */
+ int ff; /* a loop counter */
+ boolean done_fonts; /* have we finished listing the fonts in the header? */
+ font_number f; /* a font number for loops */
+ scaled ds; /* design size and scale factor for a text node */
+ font_number ldf=0; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ cur_fsize = mp_xmalloc(mp,(mp->font_max+1),sizeof(pointer));
+ if ( prologues>0 ) {
+ @<Give a \.{DocumentFonts} comment listing all fonts with non-null
+ |font_sizes| and eliminate duplicates@>;
+ } else {
+ next_size=0;
+ @<Make |cur_fsize| a copy of the |font_sizes| array@>;
+ do { done_fonts=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( cur_fsize[f]!=null ) {
+ @<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>;
+ }
+ if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; };
+ }
+ if ( ! done_fonts ) {
+ @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
+ that size index@>;
+ }
+ } while (! done_fonts);
+ }
+ mp_xfree(cur_fsize);
+ return ldf;
+}
+
+@ @<Make |cur_fsize| a copy of the |font_sizes| array@>=
+for (f=null_font+1;f<= mp->last_fnum;f++)
+ cur_fsize[f]=mp->font_sizes[f]
+
+@ It's not a good idea to make any assumptions about the |font_ps_name| entries,
+so we carefully remove duplicates. There is no harm in using a slow, brute-force
+search.
+
+@<Give a \.{DocumentFonts} comment listing all fonts with non-null...@>=
+{
+ ldf=null_font;
+ for (f=null_font+1;f<= mp->last_fnum;f++) {
+ if ( mp->font_sizes[f]!=null ) {
+ if ( ldf==null_font )
+ mp_ps_print_nl(mp, "%%DocumentFonts:");
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp->font_sizes[ff]!=null )
+ if ( mp_xstrcmp(mp->font_ps_name[f],mp->font_ps_name[ff])==0 )
+ goto FOUND;
+ }
+ if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(unsigned)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+");
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ ldf=f;
+ FOUND:
+ ;
+ }
+ }
+}
+
+@ @c
+static void mp_hex_digit_out (MP mp,small_number d) {
+ if ( d<10 ) mp_ps_print_char(mp, d+'0');
+ else mp_ps_print_char(mp, d+'a'-10);
+}
+
+@ We output the marks as a hexadecimal bit string starting at |c| or
+|font_bc[f]|, whichever is greater. If the output has to be truncated
+to avoid exceeding |emergency_line_length| the return value says where to
+start scanning next time.
+
+@<Declarations@>=
+static halfword mp_ps_marks_out (MP mp,font_number f, eight_bits c);
+
+@
+@d emergency_line_length 255
+ /* \ps\ output lines can be this long in unusual circumstances */
+
+@c
+static halfword mp_ps_marks_out (MP mp,font_number f, eight_bits c) {
+ eight_bits bc,ec; /* only encode characters between these bounds */
+ integer lim; /* the maximum number of marks to encode before truncating */
+ int p; /* |font_info| index for the current character */
+ int d,b; /* used to construct a hexadecimal digit */
+ lim=4*(emergency_line_length-mp->ps->ps_offset-4);
+ bc=mp->font_bc[f];
+ ec=mp->font_ec[f];
+ if ( c>bc ) bc=c;
+ @<Restrict the range |bc..ec| so that it contains no unused characters
+ at either end and has length at most |lim|@>;
+ @<Print the initial label indicating that the bitmap starts at |bc|@>;
+ @<Print a hexadecimal encoding of the marks for characters |bc..ec|@>;
+ while ( (ec<mp->font_ec[f])&&(mp->font_info[p].qqqq.b3==mp_unused) ) {
+ p++; ec++;
+ }
+ return (ec+1);
+}
+
+@ We could save time by setting the return value before the loop that
+decrements |ec|, but there is no point in being so tricky.
+
+@<Restrict the range |bc..ec| so that it contains no unused characters...@>=
+p=mp->char_base[f]+bc;
+while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) {
+ p++; bc++;
+}
+if ( ec>=bc+lim ) ec=bc+lim-1;
+p=mp->char_base[f]+ec;
+while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) {
+ p--; ec--;
+}
+
+@ @<Print the initial label indicating that the bitmap starts at |bc|@>=
+mp_ps_print_char(mp, ' ');
+mp_hex_digit_out(mp, bc / 16);
+mp_hex_digit_out(mp, bc % 16);
+mp_ps_print_char(mp, ':')
+
+@
+
+@<Print a hexadecimal encoding of the marks for characters |bc..ec|@>=
+b=8; d=0;
+for (p=mp->char_base[f]+bc;p<=mp->char_base[f]+ec;p++) {
+ if ( b==0 ) {
+ mp_hex_digit_out(mp, d);
+ d=0; b=8;
+ }
+ if ( mp->font_info[p].qqqq.b3!=mp_unused ) d=d+b;
+ b=b>>1;
+}
+mp_hex_digit_out(mp, d)
+
+
+@ Here is a simple function that determines whether there are any marked
+characters in font~|f| with character code at least~|c|.
+
+@<Declarations@>=
+static boolean mp_check_ps_marks (MP mp,font_number f, integer c) ;
+
+@ @c
+static boolean mp_check_ps_marks (MP mp,font_number f, integer c) {
+ int p; /* |font_info| index for the current character */
+ for (p=mp->char_base[f]+c;p<=mp->char_base[f]+mp->font_ec[f];p++) {
+ if ( mp->font_info[p].qqqq.b3==mp_used )
+ return true;
+ }
+ return false;
+}
+
+
+@ If the file name is so long that it can't be printed without exceeding
+|emergency_line_length| then there will be missing items in the \.{\%*Font:}
+line. We might have to repeat line in order to get the character usage
+information to fit within |emergency_line_length|.
+
+TODO: these two defines are also defined in mp.w!
+
+@d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
+@d sc_factor(A) mp->mem[(A)+1].cint /* the scale factor stored in a font size node */
+
+@<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>=
+{ integer t=0;
+ while ( mp_check_ps_marks(mp, f,t) ) {
+ mp_ps_print_nl(mp, "%*Font: ");
+ if ( mp->ps->ps_offset+strlen(mp->font_name[f])+12>emergency_line_length )
+ break;
+ mp_ps_print(mp, mp->font_name[f]);
+ mp_ps_print_char(mp, ' ');
+ ds=(mp->font_dsize[f] + 8) / 16;
+ mp_ps_print_scaled(mp, mp_take_scaled(mp, ds,sc_factor(cur_fsize[f])));
+ if ( mp->ps->ps_offset+12>emergency_line_length ) break;
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, ds);
+ if ( mp->ps->ps_offset+5>emergency_line_length ) break;
+ t=mp_ps_marks_out(mp, f,t);
+ }
+ cur_fsize[f]=link(cur_fsize[f]);
+}
+
+@ @<Print the procset@>=
+{
+ mp_ps_print_nl(mp, "/hlw{0 dtransform exch truncate exch idtransform pop setlinewidth}bd");
+ mp_ps_print_nl(mp, "/vlw{0 exch dtransform truncate idtransform setlinewidth pop}bd");
+ mp_ps_print_nl(mp, "/l{lineto}bd/r{rlineto}bd/c{curveto}bd/m{moveto}bd"
+ "/p{closepath}bd/n{newpath}bd");
+ mp_ps_print_nl(mp, "/C{setcmykcolor}bd/G{setgray}bd/R{setrgbcolor}bd"
+ "/lj{setlinejoin}bd/ml{setmiterlimit}bd");
+ mp_ps_print_nl(mp, "/lc{setlinecap}bd/S{stroke}bd/F{fill}bd/q{gsave}bd"
+ "/Q{grestore}bd/s{scale}bd/t{concat}bd");
+ mp_ps_print_nl(mp, "/sd{setdash}bd/rd{[] 0 setdash}bd/P{showpage}bd/B{q F Q}bd/W{clip}bd");
+}
+
+
+@ The prologue defines \.{fshow} and corrects for the fact that \.{fshow}
+arguments use |font_name| instead of |font_ps_name|. Downloaded bitmap fonts
+might not have reasonable |font_ps_name| entries, but we just charge ahead
+anyway. The user should not make \&{prologues} positive if this will cause
+trouble.
+@:prologues_}{\&{prologues} primitive@>
+
+@<Exported...@>=
+void mp_print_prologue (MP mp, mp_edge_object *h, int prologues, int procset);
+
+@ @c
+void mp_print_prologue (MP mp, mp_edge_object *h, int prologues, int procset) {
+ font_number f;
+ font_number ldf ;
+ ldf = mp_print_font_comments (mp, h, prologues);
+ mp_ps_print_ln(mp);
+ if ( (prologues==1) && (mp->last_ps_fnum<mp->last_fnum) )
+ mp_read_psname_table(mp);
+ mp_ps_print(mp, "%%BeginProlog"); mp_ps_print_ln(mp);
+ if ( (prologues>0)||(procset>0) ) {
+ if ( ldf!=null_font ) {
+ if ( prologues>0 ) {
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_name_out(mp, mp->font_ps_name[f],true);
+ mp_ps_print(mp, " def");
+ mp_ps_print_ln(mp);
+ }
+ }
+ if ( procset==0 ) {
+ mp_ps_print(mp, "/fshow {exch findfont exch scalefont setfont show}bind def");
+ mp_ps_print_ln(mp);
+ }
+ }
+ }
+ if (procset>0 ) {
+ mp_ps_print_nl(mp, "%%BeginResource: procset mpost");
+ if ( (prologues>0)&&(ldf!=null_font) )
+ mp_ps_print_nl(mp,
+ "/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd");
+ else
+ mp_ps_print_nl(mp, "/bd{bind def}bind def");
+ @<Print the procset@>;
+ mp_ps_print_nl(mp, "%%EndResource");
+ mp_ps_print_ln(mp);
+ }
+ }
+ mp_ps_print(mp, "%%EndProlog");
+ mp_ps_print_nl(mp, "%%Page: 1 1"); mp_ps_print_ln(mp);
+}
+
+@ \MP\ used to have one single routine to print to both `write' files
+and the PostScript output. Web2c redefines ``Character |k| cannot be
+printed'', and that resulted in some bugs where 8-bit characters were
+written to the PostScript file (reported by Wlodek Bzyl).
+
+Also, Hans Hagen requested spaces to be output as "\\040" instead of
+a plain space, since that makes it easier to parse the result file
+for postprocessing.
+
+@<Character |k| is not allowed in PostScript output@>=
+ (k<=' ')||(k>'~')
+
+@ We often need to print a pair of coordinates.
+
+@c
+void mp_ps_pair_out (MP mp,scaled x, scaled y) {
+ ps_room(26);
+ mp_ps_print_scaled(mp, x); mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, y); mp_ps_print_char(mp, ' ');
+}
+
+@ @<Exported...@>=
+void mp_ps_pair_out (MP mp,scaled x, scaled y) ;
+
+@ @c
+void mp_ps_print_cmd (MP mp, const char *l, const char *s) {
+ if ( mp->internal[mp_procset]>0 ) { ps_room(strlen(s)); mp_ps_print(mp,s); }
+ else { ps_room(strlen(l)); mp_ps_print(mp, l); };
+}
+
+@ @<Exported...@>=
+void mp_ps_print_cmd (MP mp, const char *l, const char *s) ;
+
+@ @c
+void mp_ps_string_out (MP mp, const char *s) {
+ ASCII_code k; /* bits to be converted to octal */
+ mp_ps_print(mp, "(");
+ while ((k=*s++)) {
+ if ( mp->ps->ps_offset+5>mp->max_print_line ) {
+ mp_ps_print_char(mp, '\\');
+ mp_ps_print_ln(mp);
+ }
+ if ( (@<Character |k| is not allowed in PostScript output@>) ) {
+ mp_ps_print_char(mp, '\\');
+ mp_ps_print_char(mp, '0'+(k / 64));
+ mp_ps_print_char(mp, '0'+((k / 8) % 8));
+ mp_ps_print_char(mp, '0'+(k % 8));
+ } else {
+ if ( (k=='(')||(k==')')||(k=='\\') )
+ mp_ps_print_char(mp, '\\');
+ mp_ps_print_char(mp, k);
+ }
+ }
+ mp_ps_print_char(mp, ')');
+}
+
+@ @<Exported...@>=
+void mp_ps_string_out (MP mp, const char *s) ;
+
+@ This is a define because the function does not use its |mp| argument.
+
+@d mp_is_ps_name(M,A) mp_do_is_ps_name(A)
+
+@c
+static boolean mp_do_is_ps_name (char *s) {
+ ASCII_code k; /* the character being checked */
+ while ((k=*s++)) {
+ if ( (k<=' ')||(k>'~') ) return false;
+ if ( (k=='(')||(k==')')||(k=='<')||(k=='>')||
+ (k=='{')||(k=='}')||(k=='/')||(k=='%') ) return false;
+ }
+ return true;
+}
+
+@ @<Exported...@>=
+void mp_ps_name_out (MP mp, char *s, boolean lit) ;
+
+@ @c
+void mp_ps_name_out (MP mp, char *s, boolean lit) {
+ ps_room(strlen(s)+2);
+ mp_ps_print_char(mp, ' ');
+ if ( mp_is_ps_name(mp, s) ) {
+ if ( lit ) mp_ps_print_char(mp, '/');
+ mp_ps_print(mp, s);
+ } else {
+ mp_ps_string_out(mp, s);
+ if ( ! lit ) mp_ps_print(mp, "cvx ");
+ mp_ps_print(mp, "cvn");
+ }
+}
+
+
+@ These special comments described in the {\sl PostScript Language Reference
+Manual}, 2nd.~edition are understood by some \ps-reading programs.
+We can't normally output ``conforming'' \ps\ because
+the structuring conventions don't allow us to say ``Please make sure the
+following characters are downloaded and define the \.{fshow} macro to access
+them.''
+
+The exact bounding box is written out if |mp_prologues<0|, although this
+is not standard \ps, since it allows \TeX\ to calculate the box dimensions
+accurately. (Overfull boxes are avoided if an illustration is made to
+match a given \.{\char`\\hsize}.)
+
+@<Exported...@>=
+void mp_print_initial_comment(MP mp,mp_edge_object *hh, int prologues);
+
+@ @c
+void mp_print_initial_comment(MP mp,mp_edge_object *hh, int prologues) {
+ scaled t;
+ mp_ps_print(mp, "%!PS");
+ if ( prologues>0 )
+ mp_ps_print(mp, "-Adobe-3.0 EPSF-3.0");
+ mp_ps_print_nl(mp, "%%BoundingBox: ");
+ if ( hh->_minx>hh->_maxx) {
+ mp_ps_print(mp, "0 0 0 0");
+ } else if ( prologues<0 ) {
+ mp_ps_pair_out(mp, hh->_minx,hh->_miny);
+ mp_ps_pair_out(mp, hh->_maxx,hh->_maxy);
+ } else {
+ mp_ps_pair_out(mp, mp_floor_scaled(mp, hh->_minx),mp_floor_scaled(mp, hh->_miny));
+ mp_ps_pair_out(mp, -mp_floor_scaled(mp, -hh->_maxx),-mp_floor_scaled(mp, -hh->_maxy));
+ }
+ mp_ps_print_nl(mp, "%%HiResBoundingBox: ");
+ if ( hh->_minx>hh->_maxx ) {
+ mp_ps_print(mp, "0 0 0 0");
+ } else {
+ mp_ps_pair_out(mp, hh->_minx,hh->_miny);
+ mp_ps_pair_out(mp, hh->_maxx,hh->_maxy);
+ }
+ mp_ps_print_nl(mp, "%%Creator: MetaPost ");
+ mp_ps_print(mp, mp_metapost_version(mp));
+ mp_ps_print_nl(mp, "%%CreationDate: ");
+ mp_ps_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
+ mp_ps_print_char(mp, '.');
+ mp_ps_print_dd(mp, mp_round_unscaled(mp, mp->internal[mp_month]));
+ mp_ps_print_char(mp, '.');
+ mp_ps_print_dd(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
+ mp_ps_print_char(mp, ':');
+ t=mp_round_unscaled(mp, mp->internal[mp_time]);
+ mp_ps_print_dd(mp, t / 60);
+ mp_ps_print_dd(mp, t % 60);
+ mp_ps_print_nl(mp, "%%Pages: 1");
+}
+
+@ The most important output procedure is the one that gives the \ps\ version of
+a \MP\ path.
+
+@<Types...@>=
+#define gr_left_type(A) (A)->left_type_field
+#define gr_right_type(A) (A)->right_type_field
+#define gr_x_coord(A) (A)->x_coord_field
+#define gr_y_coord(A) (A)->y_coord_field
+#define gr_left_x(A) (A)->left_x_field
+#define gr_left_y(A) (A)->left_y_field
+#define gr_right_x(A) (A)->right_x_field
+#define gr_right_y(A) (A)->right_y_field
+#define gr_next_knot(A) (A)->next_field
+#define gr_originator(A) (A)->originator_field
+typedef struct mp_knot {
+ unsigned short left_type_field;
+ unsigned short right_type_field;
+ scaled x_coord_field;
+ scaled y_coord_field;
+ scaled left_x_field;
+ scaled left_y_field;
+ scaled right_x_field;
+ scaled right_y_field;
+ struct mp_knot * next_field;
+ quarterword originator_field;
+} mp_knot;
+
+@ @c
+mp_knot * mp_gr_insert_knot (MP mp, mp_knot *q, scaled x, scaled y) {
+ /* returns the inserted knot */
+ mp_knot *r; /* the new knot */
+ r= mp_xmalloc(mp, 1, sizeof (mp_knot));
+ gr_next_knot(r)=gr_next_knot(q); gr_next_knot(q)=r;
+ gr_right_x(r)=gr_right_x(q);
+ gr_right_y(r)=gr_right_y(q);
+ gr_x_coord(r)=x;
+ gr_y_coord(r)=y;
+ gr_right_x(q)=gr_x_coord(q);
+ gr_right_y(q)=gr_y_coord(q);
+ gr_left_x(r)=gr_x_coord(r);
+ gr_left_y(r)=gr_y_coord(r);
+ gr_left_type(r)=mp_explicit;
+ gr_right_type(r)=mp_explicit;
+ gr_originator(r)=mp_program_code;
+ return r;
+}
+
+
+@ If we want to duplicate a knot node, we can say |copy_knot|:
+
+@c
+mp_knot *mp_gr_copy_knot (MP mp, mp_knot *p) {
+ mp_knot *q; /* the copy */
+ q = mp_xmalloc(mp, 1, sizeof (mp_knot));
+ memcpy(q,p,sizeof (mp_knot));
+ gr_next_knot(q)=NULL;
+ return q;
+}
+
+@ The |copy_path| routine makes a clone of a given path.
+
+@c
+mp_knot *mp_gr_copy_path (MP mp, mp_knot *p) {
+ mp_knot *q, *pp, *qq; /* for list manipulation */
+ if (p==NULL)
+ return NULL;
+ q=mp_gr_copy_knot(mp, p);
+ qq=q;
+ pp=gr_next_knot(p);
+ while ( pp!=p ) {
+ gr_next_knot(qq)=mp_gr_copy_knot(mp, pp);
+ qq=gr_next_knot(qq);
+ pp=gr_next_knot(pp);
+ }
+ gr_next_knot(qq)=q;
+ return q;
+}
+
+@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
+returns a pointer to the first node of the copy, if the path is a cycle,
+but to the final node of a non-cyclic copy. The global
+variable |path_tail| will point to the final node of the original path;
+this trick makes it easier to implement `\&{doublepath}'.
+
+All node types are assumed to be |endpoint| or |explicit| only.
+
+This function is currenly unused.
+
+@c
+mp_knot * mp_gr_htap_ypoc (MP mp, mp_knot *p) {
+ mp_knot *q, *pp, *qq, *rr; /* for list manipulation */
+ q=mp_xmalloc(mp, 1, sizeof (mp_knot)); /* this will correspond to |p| */
+ qq=q; pp=p;
+ while (1) {
+ gr_right_type(qq)=gr_left_type(pp);
+ gr_left_type(qq)=gr_right_type(pp);
+ gr_x_coord(qq)=gr_x_coord(pp);
+ gr_y_coord(qq)=gr_y_coord(pp);
+ gr_right_x(qq)=gr_left_x(pp);
+ gr_right_y(qq)=gr_left_y(pp);
+ gr_left_x(qq)=gr_right_x(pp);
+ gr_left_y(qq)=gr_right_y(pp);
+ gr_originator(qq)=gr_originator(pp);
+ if ( gr_next_knot(pp)==p ) {
+ gr_next_knot(q)=qq;
+ /* mp->path_tail=pp; */ /* ? */
+ return q;
+ }
+ rr=mp_xmalloc(mp, 1, sizeof (mp_knot));
+ gr_next_knot(rr)=qq;
+ qq=rr;
+ pp=gr_next_knot(pp);
+ }
+}
+
+@ When a cyclic list of knot nodes is no longer needed, it can be recycled by
+calling the following subroutine.
+
+@<Declarations@>=
+void mp_do_gr_toss_knot_list (mp_knot *p) ;
+
+@
+@d mp_gr_toss_knot_list(B,A) mp_do_gr_toss_knot_list(A)
+
+@c
+void mp_do_gr_toss_knot_list (mp_knot * p) {
+ mp_knot *q; /* the node being freed */
+ mp_knot *r; /* the next node */
+ if (p==NULL)
+ return;
+ q=p;
+ do {
+ r=gr_next_knot(q);
+ mp_xfree(q); q=r;
+ } while (q!=p);
+}
+
+
+
+@ @c
+void mp_gr_ps_path_out (MP mp, mp_knot *h) {
+ mp_knot *p, *q; /* for scanning the path */
+ scaled d; /* a temporary value */
+ boolean curved; /* |true| unless the cubic is almost straight */
+ ps_room(40);
+ mp_ps_print_cmd(mp, "newpath ","n ");
+ mp_ps_pair_out(mp, gr_x_coord(h),gr_y_coord(h));
+ mp_ps_print_cmd(mp, "moveto","m");
+ p=h;
+ do {
+ if ( gr_right_type(p)==mp_endpoint ) {
+ if ( p==h ) mp_ps_print_cmd(mp, " 0 0 rlineto"," 0 0 r");
+ return;
+ }
+ q=gr_next_knot(p);
+ @<Start a new line and print the \ps\ commands for the curve from
+ |p| to~|q|@>;
+ p=q;
+ } while (p!=h);
+ mp_ps_print_cmd(mp, " closepath"," p");
+}
+
+@ @<Start a new line and print the \ps\ commands for the curve from...@>=
+curved=true;
+@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>;
+mp_ps_print_ln(mp);
+if ( curved ){
+ mp_ps_pair_out(mp, gr_right_x(p),gr_right_y(p));
+ mp_ps_pair_out(mp, gr_left_x(q),gr_left_y(q));
+ mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ mp_ps_print_cmd(mp, "curveto","c");
+} else if ( q!=h ){
+ mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ mp_ps_print_cmd(mp, "lineto","l");
+}
+
+@ Two types of straight lines come up often in \MP\ paths:
+cubics with zero initial and final velocity as created by |make_path| or
+|make_envelope|, and cubics with control points uniformly spaced on a line
+as created by |make_choices|.
+
+@d bend_tolerance 131 /* allow rounding error of $2\cdot10^{-3}$ */
+
+@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>=
+if ( gr_right_x(p)==gr_x_coord(p) )
+ if ( gr_right_y(p)==gr_y_coord(p) )
+ if ( gr_left_x(q)==gr_x_coord(q) )
+ if ( gr_left_y(q)==gr_y_coord(q) ) curved=false;
+d=gr_left_x(q)-gr_right_x(p);
+if ( abs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance )
+ if ( abs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance )
+ { d=gr_left_y(q)-gr_right_y(p);
+ if ( abs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance )
+ if ( abs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance ) curved=false;
+ }
+
+@ The colored objects use a struct with anonymous fields to express the color parts:
+
+@<Types...@>=
+typedef struct {
+ scaled _a_val, _b_val, _c_val, _d_val;
+} mp_color;
+
+@ The exported form of a dash pattern is simpler than the internal
+format, it is closely modelled to the PostScript model. The array of
+dashes is ended by a single negative value, because this is not
+allowed in PostScript.
+
+@d gr_dash_scale(A) (gr_dash_p(A))->scale_field
+
+@<Types...@>=
+typedef struct {
+ scaled offset_field;
+ scaled scale_field;
+ scaled *array_field;
+} mp_dash_object ;
+
+
+@
+@d mp_gr_toss_dashes(A,B) mp_do_gr_toss_dashes(B)
+
+@<Declarations@>=
+void mp_do_gr_toss_dashes(mp_dash_object *dl);
+
+@ @c
+void mp_do_gr_toss_dashes(mp_dash_object *dl) {
+ if (dl==NULL)
+ return;
+ mp_xfree(dl->array_field);
+ mp_xfree(dl);
+}
+
+
+@ @c
+mp_dash_object *mp_gr_copy_dashes(MP mp, mp_dash_object *dl) {
+ mp_dash_object *q = NULL;
+ (void)mp;
+ if (dl==NULL)
+ return NULL;
+ q = mp_xmalloc(mp, 1, sizeof (mp_dash_object));
+ memcpy (q,dl,sizeof(mp_dash_object));
+ if (dl->array_field != NULL) {
+ int i = 0;
+ while (*(dl->array_field+i) != -1) i++;
+ q->array_field = mp_xmalloc(mp, i, sizeof (scaled));
+ memcpy(q->array_field,dl->array_field, (i*sizeof(scaled)));
+ }
+ return q;
+}
+
+
+@ Now for outputting the actual graphic objects. First, set up some
+structures and access macros.
+
+@d gr_has_color(A) (gr_type((A))<mp_start_clip_code)
+
+@<Types...@>=
+#define gr_type(A) (A)->_type_field
+#define gr_link(A) (A)->_link_field
+#define gr_color_model(A) (A)->color_model_field
+#define gr_red_val(A) (A)->color_field._a_val
+#define gr_green_val(A) (A)->color_field._b_val
+#define gr_blue_val(A) (A)->color_field._c_val
+#define gr_cyan_val(A) (A)->color_field._a_val
+#define gr_magenta_val(A) (A)->color_field._b_val
+#define gr_yellow_val(A) (A)->color_field._c_val
+#define gr_black_val(A) (A)->color_field._d_val
+#define gr_grey_val(A) (A)->color_field._a_val
+#define gr_path_p(A) (A)->path_p_field
+#define gr_htap_p(A) ((mp_fill_object *)A)->htap_p_field
+#define gr_pen_p(A) (A)->pen_p_field
+#define gr_ljoin_val(A) (A)->ljoin_field
+#define gr_lcap_val(A) ((mp_stroked_object *)A)->lcap_field
+#define gr_miterlim_val(A) (A)->miterlim_field
+#define gr_pre_script(A) (A)->pre_script_field
+#define gr_post_script(A) (A)->post_script_field
+#define gr_dash_p(A) ((mp_stroked_object *)A)->dash_p_field
+#define gr_name_type(A) ((mp_text_object *)A)->name_type_field
+#define gr_text_p(A) ((mp_text_object *)A)->text_p_field
+#define gr_font_n(A) ((mp_text_object *)A)->font_n_field
+#define gr_font_name(A) ((mp_text_object *)A)->font_name_field
+#define gr_font_dsize(A) ((mp_text_object *)A)->font_dsize_field
+#define gr_width_val(A) ((mp_text_object *)A)->width_field
+#define gr_height_val(A) ((mp_text_object *)A)->height_field
+#define gr_depth_val(A) ((mp_text_object *)A)->depth_field
+#define gr_tx_val(A) ((mp_text_object *)A)->tx_field
+#define gr_ty_val(A) ((mp_text_object *)A)->ty_field
+#define gr_txx_val(A) ((mp_text_object *)A)->txx_field
+#define gr_txy_val(A) ((mp_text_object *)A)->txy_field
+#define gr_tyx_val(A) ((mp_text_object *)A)->tyx_field
+#define gr_tyy_val(A) ((mp_text_object *)A)->tyy_field
+
+#define GRAPHIC_BODY \
+ halfword _type_field; \
+ struct mp_graphic_object * _link_field
+
+typedef struct mp_graphic_object {
+ GRAPHIC_BODY;
+} mp_graphic_object;
+
+typedef struct mp_text_object {
+ GRAPHIC_BODY;
+ char *pre_script_field;
+ char *post_script_field;
+ mp_color color_field;
+ quarterword color_model_field;
+ quarterword name_type_field;
+ char *text_p_field;
+ char *font_name_field ;
+ scaled font_dsize_field ;
+ font_number font_n_field ;
+ scaled width_field ;
+ scaled height_field ;
+ scaled depth_field ;
+ scaled tx_field ;
+ scaled ty_field ;
+ scaled txx_field ;
+ scaled txy_field ;
+ scaled tyx_field ;
+ scaled tyy_field ;
+} mp_text_object;
+
+typedef struct mp_fill_object {
+ GRAPHIC_BODY;
+ char *pre_script_field;
+ char *post_script_field;
+ mp_color color_field;
+ quarterword color_model_field;
+ quarterword ljoin_field ;
+ mp_knot * path_p_field;
+ mp_knot * htap_p_field;
+ mp_knot * pen_p_field;
+ scaled miterlim_field ;
+} mp_fill_object;
+
+typedef struct mp_stroked_object {
+ GRAPHIC_BODY;
+ char *pre_script_field;
+ char *post_script_field;
+ mp_color color_field;
+ quarterword color_model_field;
+ quarterword ljoin_field ;
+ quarterword lcap_field ;
+ mp_knot * path_p_field;
+ mp_knot * pen_p_field;
+ scaled miterlim_field ;
+ mp_dash_object *dash_p_field;
+} mp_stroked_object;
+
+typedef struct mp_clip_object {
+ GRAPHIC_BODY;
+ mp_knot * path_p_field;
+} mp_clip_object;
+
+typedef struct mp_bounds_object {
+ GRAPHIC_BODY;
+ mp_knot * path_p_field;
+} mp_bounds_object;
+
+typedef struct mp_special_object {
+ GRAPHIC_BODY;
+ char *pre_script_field;
+} mp_special_object ;
+
+typedef struct mp_edge_object {
+ struct mp_graphic_object * body;
+ struct mp_edge_object * _next;
+ char * _filename;
+ MP _parent;
+ scaled _minx, _miny, _maxx, _maxy;
+} mp_edge_object;
+
+@ @<Exported function headers@>=
+mp_graphic_object *mp_new_graphic_object(MP mp, int type);
+
+@ @c
+mp_graphic_object *mp_new_graphic_object (MP mp, int type) {
+ mp_graphic_object *p;
+ int size ;
+ switch (type) {
+ case mp_fill_code: size = sizeof(mp_fill_object); break;
+ case mp_stroked_code: size = sizeof(mp_stroked_object); break;
+ case mp_text_code: size = sizeof(mp_text_object); break;
+ case mp_start_clip_code: size = sizeof(mp_clip_object); break;
+ case mp_start_bounds_code: size = sizeof(mp_bounds_object); break;
+ case mp_special_code: size = sizeof(mp_special_object); break;
+ default: size = sizeof(mp_graphic_object); break;
+ }
+ p = (mp_graphic_object *)mp_xmalloc(mp,1,size);
+ memset(p,0,size);
+ gr_type(p) = type;
+ return p;
+}
+
+@ We need to keep track of several parameters from the \ps\ graphics state.
+@^graphics state@>
+This allows us to be sure that \ps\ has the correct values when they are
+needed without wasting time and space setting them unnecessarily.
+
+@d gs_red mp->ps->gs_state->red_field
+@d gs_green mp->ps->gs_state->green_field
+@d gs_blue mp->ps->gs_state->blue_field
+@d gs_black mp->ps->gs_state->black_field
+@d gs_colormodel mp->ps->gs_state->colormodel_field
+@d gs_ljoin mp->ps->gs_state->ljoin_field
+@d gs_lcap mp->ps->gs_state->lcap_field
+@d gs_adj_wx mp->ps->gs_state->adj_wx_field
+@d gs_miterlim mp->ps->gs_state->miterlim_field
+@d gs_dash_p mp->ps->gs_state->dash_p_field
+@d gs_dash_init_done mp->ps->gs_state->dash_done_field
+@d gs_previous mp->ps->gs_state->previous_field
+@d gs_width mp->ps->gs_state->width_field
+
+@<Types...@>=
+typedef struct _gs_state {
+ scaled red_field ;
+ scaled green_field ;
+ scaled blue_field ;
+ scaled black_field ;
+ /* color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command */
+ quarterword colormodel_field ;
+ /* the current colormodel */
+ quarterword ljoin_field ;
+ quarterword lcap_field ;
+ /* values from the last \&{setlinejoin} and \&{setlinecap} commands */
+ quarterword adj_wx_field ;
+ /* what resolution-dependent adjustment applies to the width */
+ scaled miterlim_field ;
+ /* the value from the last \&{setmiterlimit} command */
+ mp_dash_object * dash_p_field ;
+ /* edge structure for last \&{setdash} command */
+ boolean dash_done_field ; /* to test for initial \&{setdash} */
+ struct _gs_state * previous_field ;
+ /* backlink to the previous |_gs_state| structure */
+ scaled width_field ;
+ /* width setting or $-1$ if no \&{setlinewidth} command so far */
+} _gs_state;
+
+
+@ @<Glob...@>=
+struct _gs_state * gs_state;
+
+@ @<Set init...@>=
+mp->ps->gs_state=NULL;
+
+@ @<Dealloc variables@>=
+mp_xfree(mp->ps->gs_state);
+
+@ To avoid making undue assumptions about the initial graphics state, these
+parameters are given special values that are guaranteed not to match anything
+in the edge structure being shipped out. On the other hand, the initial color
+should be black so that the translation of an all-black picture will have no
+\&{setcolor} commands. (These would be undesirable in a font application.)
+Hence we use |c=0| when initializing the graphics state and we use |c<0|
+to recover from a situation where we have lost track of the graphics state.
+
+@c
+void mp_gs_unknown_graphics_state (MP mp,scaled c) ;
+
+@
+@d mp_void (null+1) /* a null pointer different from |null| */
+
+@c void mp_gs_unknown_graphics_state (MP mp,scaled c) {
+ struct _gs_state *p; /* to shift graphic states around */
+ if ( (c==0)||(c==-1) ) {
+ if ( mp->ps->gs_state==NULL ) {
+ mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state));
+ gs_previous=NULL;
+ } else {
+ while ( gs_previous!=NULL ) {
+ p = gs_previous;
+ mp_xfree(mp->ps->gs_state);
+ mp->ps->gs_state=p;
+ }
+ }
+ gs_red=c; gs_green=c; gs_blue=c; gs_black=c;
+ gs_colormodel=mp_uninitialized_model;
+ gs_ljoin=3;
+ gs_lcap=3;
+ gs_miterlim=0;
+ gs_dash_p=NULL;
+ gs_dash_init_done=false;
+ gs_width=-1;
+ } else if ( c==1 ) {
+ p= mp->ps->gs_state;
+ mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state));
+ memcpy(mp->ps->gs_state,p,sizeof(struct _gs_state));
+ gs_previous = p;
+ } else if ( c==2 ) {
+ p = gs_previous;
+ mp_xfree(mp->ps->gs_state);
+ mp->ps->gs_state=p;
+ }
+}
+
+
+@ When it is time to output a graphical object, |fix_graphics_state| ensures
+that \ps's idea of the graphics state agrees with what is stored in the object.
+
+@<Declarations@>=
+void mp_gr_fix_graphics_state (MP mp, mp_graphic_object *p) ;
+
+@ @c
+void mp_gr_fix_graphics_state (MP mp, mp_graphic_object *p) {
+ /* get ready to output graphical object |p| */
+ mp_knot *pp, *path_p; /* for list manipulation */
+ mp_dash_object *hh;
+ scaled wx,wy,ww; /* dimensions of pen bounding box */
+ boolean adj_wx; /* whether pixel rounding should be based on |wx| or |wy| */
+ integer tx,ty; /* temporaries for computing |adj_wx| */
+ scaled scf; /* a scale factor for the dash pattern */
+ if ( gr_has_color(p) )
+ @<Make sure \ps\ will use the right color for object~|p|@>;
+ if ( (gr_type(p)==mp_fill_code)||(gr_type(p)==mp_stroked_code) ) {
+ if (gr_type(p)==mp_fill_code) {
+ pp = gr_pen_p((mp_fill_object *)p);
+ path_p = gr_path_p((mp_fill_object *)p);
+ } else {
+ pp = gr_pen_p((mp_stroked_object *)p);
+ path_p = gr_path_p((mp_stroked_object *)p);
+ }
+ if ( pp!=NULL )
+ if ( pen_is_elliptical(pp) ) {
+ @<Generate \ps\ code that sets the stroke width to the
+ appropriate rounded value@>;
+ @<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>;
+ @<Decide whether the line cap parameter matters and set it if necessary@>;
+ @<Set the other numeric parameters as needed for object~|p|@>;
+ }
+ }
+ if ( mp->ps->ps_offset>0 ) mp_ps_print_ln(mp);
+}
+
+@ @<Decide whether the line cap parameter matters and set it if necessary@>=
+if ( gr_type(p)==mp_stroked_code ) {
+ mp_stroked_object *ts = (mp_stroked_object *)p;
+ if ( (gr_left_type(gr_path_p(ts))==mp_endpoint)||(gr_dash_p(ts)!=NULL) )
+ if ( gs_lcap!=gr_lcap_val(ts) ) {
+ ps_room(13);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_char(mp, '0'+gr_lcap_val(ts));
+ mp_ps_print_cmd(mp, " setlinecap"," lc");
+ gs_lcap=gr_lcap_val(ts);
+ }
+}
+
+@
+@d set_ljoin_miterlim(p)
+ if ( gs_ljoin!=gr_ljoin_val(p) ) {
+ ps_room(14);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_char(mp, '0'+gr_ljoin_val(p));
+ mp_ps_print_cmd(mp, " setlinejoin"," lj");
+ gs_ljoin=gr_ljoin_val(p);
+ }
+ if ( gs_miterlim!=gr_miterlim_val(p) ) {
+ ps_room(27);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gr_miterlim_val(p));
+ mp_ps_print_cmd(mp, " setmiterlimit"," ml");
+ gs_miterlim=gr_miterlim_val(p);
+ }
+
+@<Set the other numeric parameters as needed for object~|p|@>=
+if ( gr_type(p)==mp_stroked_code ) {
+ mp_stroked_object *ts = (mp_stroked_object *)p;
+ set_ljoin_miterlim(ts);
+} else {
+ mp_fill_object *ts = (mp_fill_object *)p;
+ set_ljoin_miterlim(ts);
+}
+
+@
+@d set_color_objects(pq)
+ object_color_model = pq->color_model_field;
+ object_color_a = pq->color_field._a_val;
+ object_color_b = pq->color_field._b_val;
+ object_color_c = pq->color_field._c_val;
+ object_color_d = pq->color_field._d_val;
+
+@<Make sure \ps\ will use the right color for object~|p|@>=
+{
+ int object_color_model;
+ int object_color_a, object_color_b, object_color_c, object_color_d ;
+ if (gr_type(p) == mp_fill_code) {
+ mp_fill_object *pq = (mp_fill_object *)p;
+ set_color_objects(pq);
+ } else if (gr_type(p) == mp_stroked_code) {
+ mp_stroked_object *pq = (mp_stroked_object *)p;
+ set_color_objects(pq);
+ } else {
+ mp_text_object *pq = (mp_text_object *)p;
+ set_color_objects(pq);
+ }
+
+ if ( object_color_model==mp_rgb_model) {
+ if ( (gs_colormodel!=mp_rgb_model)||(gs_red!=object_color_a)||
+ (gs_green!=object_color_b)||(gs_blue!=object_color_c) ) {
+ gs_red = object_color_a;
+ gs_green = object_color_b;
+ gs_blue = object_color_c;
+ gs_black = -1;
+ gs_colormodel=mp_rgb_model;
+ { ps_room(36);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_red); mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_green); mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_blue);
+ mp_ps_print_cmd(mp, " setrgbcolor", " R");
+ }
+ }
+ } else if ( object_color_model==mp_cmyk_model) {
+ if ( (gs_red!=object_color_a)||(gs_green!=object_color_b)||
+ (gs_blue!=object_color_c)||(gs_black!=object_color_d)||
+ (gs_colormodel!=mp_cmyk_model) ) {
+ gs_red = object_color_a;
+ gs_green = object_color_b;
+ gs_blue = object_color_c;
+ gs_black = object_color_d;
+ gs_colormodel=mp_cmyk_model;
+ { ps_room(45);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_red);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_green);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_blue);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_black);
+ mp_ps_print_cmd(mp, " setcmykcolor"," C");
+ }
+ }
+ } else if ( object_color_model==mp_grey_model ) {
+ if ( (gs_red!=object_color_a)||(gs_colormodel!=mp_grey_model) ) {
+ gs_red = object_color_a;
+ gs_green = -1;
+ gs_blue = -1;
+ gs_black = -1;
+ gs_colormodel=mp_grey_model;
+ { ps_room(16);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, gs_red);
+ mp_ps_print_cmd(mp, " setgray"," G");
+ }
+ }
+ } else if ( object_color_model==mp_no_model ) {
+ gs_colormodel=mp_no_model;
+ }
+}
+
+@ In order to get consistent widths for horizontal and vertical pen strokes, we
+want \ps\ to use an integer number of pixels for the \&{setwidth} parameter.
+@:setwidth}{\&{setwidth}command@>
+We set |gs_width| to the ideal horizontal or vertical stroke width and then
+generate \ps\ code that computes the rounded value. For non-circular pens, the
+pen shape will be rescaled so that horizontal or vertical parts of the stroke
+have the computed width.
+
+Rounding the width to whole pixels is not likely to improve the appearance of
+diagonal or curved strokes, but we do it anyway for consistency. The
+\&{truncate} command generated here tends to make all the strokes a little
+@:truncate}{\&{truncate} command@>
+thinner, but this is appropriate for \ps's scan-conversion rules. Even with
+truncation, an ideal with of $w$~pixels gets mapped into $\lfloor w\rfloor+1$.
+It would be better to have $\lceil w\rceil$ but that is ridiculously expensive
+to compute in \ps.
+
+@<Generate \ps\ code that sets the stroke width...@>=
+@<Set |wx| and |wy| to the width and height of the bounding box for
+ |pen_p(p)|@>;
+@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more
+ important and set |adj_wx| and |ww| accordingly@>;
+if ( (ww!=gs_width) || (adj_wx!=gs_adj_wx) ) {
+ if ( adj_wx ) {
+ ps_room(13);
+ mp_ps_print_char(mp, ' '); mp_ps_print_scaled(mp, ww);
+ mp_ps_print_cmd(mp,
+ " 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw");
+ } else {
+ if ( mp->internal[mp_procset]>0 ) {
+ ps_room(13);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_scaled(mp, ww);
+ mp_ps_print(mp, " vlw");
+ } else {
+ ps_room(15);
+ mp_ps_print(mp, " 0 "); mp_ps_print_scaled(mp, ww);
+ mp_ps_print(mp, " dtransform truncate idtransform setlinewidth pop");
+ }
+ }
+ gs_width = ww;
+ gs_adj_wx = adj_wx;
+}
+
+@ @<Set |wx| and |wy| to the width and height of the bounding box for...@>=
+if ( (gr_right_x(pp)==gr_x_coord(pp)) && (gr_left_y(pp)==gr_y_coord(pp)) ) {
+ wx = abs(gr_left_x(pp) - gr_x_coord(pp));
+ wy = abs(gr_right_y(pp) - gr_y_coord(pp));
+} else {
+ wx = mp_pyth_add(mp, gr_left_x(pp)-gr_x_coord(pp), gr_right_x(pp)-gr_x_coord(pp));
+ wy = mp_pyth_add(mp, gr_left_y(pp)-gr_y_coord(pp), gr_right_y(pp)-gr_y_coord(pp));
+}
+
+@ The path is considered ``essentially horizontal'' if its range of
+$y$~coordinates is less than the $y$~range |wy| for the pen. ``Essentially
+vertical'' paths are detected similarly. This code ensures that no component
+of the pen transformation is more that |aspect_bound*(ww+1)|.
+
+@d aspect_bound 10 /* ``less important'' of |wx|, |wy| cannot exceed the other by
+ more than this factor */
+
+@d do_x_loc 1
+@d do_y_loc 2
+
+@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more...@>=
+tx=1; ty=1;
+if ( mp_gr_coord_rangeOK(path_p, do_y_loc, wy) ) tx=aspect_bound;
+else if ( mp_gr_coord_rangeOK(path_p, do_x_loc, wx) ) ty=aspect_bound;
+if ( wy / ty>=wx / tx ) { ww=wy; adj_wx=false; }
+else { ww=wx; adj_wx=true; }
+
+@ This routine quickly tests if path |h| is ``essentially horizontal'' or
+``essentially vertical,'' where |zoff| is |x_loc(0)| or |y_loc(0)| and |dz| is
+allowable range for $x$ or~$y$. We do not need and cannot afford a full
+bounding-box computation.
+
+@<Declarations@>=
+boolean mp_gr_coord_rangeOK (mp_knot *h,
+ small_number zoff, scaled dz);
+
+@ @c
+boolean mp_gr_coord_rangeOK (mp_knot *h,
+ small_number zoff, scaled dz) {
+ mp_knot *p; /* for scanning the path form |h| */
+ scaled zlo,zhi; /* coordinate range so far */
+ scaled z; /* coordinate currently being tested */
+ if (zoff==do_x_loc) {
+ zlo=gr_x_coord(h);
+ zhi=zlo;
+ p=h;
+ while ( gr_right_type(p)!=mp_endpoint ) {
+ z=gr_right_x(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ p=gr_next_knot(p); z=gr_left_x(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ z=gr_x_coord(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ if ( p==h ) break;
+ }
+ } else {
+ zlo=gr_y_coord(h);
+ zhi=zlo;
+ p=h;
+ while ( gr_right_type(p)!=mp_endpoint ) {
+ z=gr_right_y(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ p=gr_next_knot(p); z=gr_left_y(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ z=gr_y_coord(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ if ( p==h ) break;
+ }
+ }
+ return true;
+}
+
+@ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>=
+if ( z<zlo ) zlo=z;
+else if ( z>zhi ) zhi=z;
+if ( zhi-zlo>dz ) return false
+
+@ Filling with an elliptical pen is implemented via a combination of \&{stroke}
+and \&{fill} commands and a nontrivial dash pattern would interfere with this.
+@:stroke}{\&{stroke} command@>
+@:fill}{\&{fill} command@>
+Note that we don't use |delete_edge_ref| because |gs_dash_p| is not counted as
+a reference.
+
+@<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>=
+if ( gr_type(p)==mp_fill_code || gr_dash_p(p) == NULL) {
+ hh=NULL;
+} else {
+ hh=gr_dash_p(p);
+ scf=mp_gr_get_pen_scale(mp, gr_pen_p((mp_fill_object *)p));
+ if ( scf==0 ) {
+ if ( gs_width==0 ) scf=hh->scale_field; else hh=NULL;
+ } else {
+ scf=mp_make_scaled(mp, gs_width,scf);
+ scf=mp_take_scaled(mp, scf, (hh == NULL ? unity : gr_dash_scale(p)));
+ }
+}
+if ( hh==NULL ) {
+ if ( gs_dash_p!=NULL || gs_dash_init_done == false) {
+ mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
+ gs_dash_p=NULL;
+ gs_dash_init_done=true;
+ }
+} else if ( ! mp_gr_same_dashes(gs_dash_p,hh) ) {
+ @<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>;
+}
+
+@ @<Declarations@>=
+scaled mp_gr_get_pen_scale (MP mp, mp_knot *p) ;
+
+
+@ @c
+scaled mp_gr_get_pen_scale (MP mp, mp_knot *p) {
+ return mp_sqrt_det(mp,
+ gr_left_x(p)-gr_x_coord(p), gr_right_x(p)-gr_x_coord(p),
+ gr_left_y(p)-gr_y_coord(p), gr_right_y(p)-gr_y_coord(p));
+}
+
+
+@ The original code had a check here to ensure that the result from
+|mp_take_scaled| did not go out of bounds.
+
+@<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>=
+{ gs_dash_p=hh;
+ if ( (gr_dash_p(p)==NULL) || (hh==NULL) || (hh->array_field==NULL)) {
+ mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
+ } else {
+ int i;
+ ps_room(28);
+ mp_ps_print(mp, " [");
+ for (i=0; *(hh->array_field+i) != -1;i++) {
+ ps_room(13);
+ mp_ps_print_scaled(mp, *(hh->array_field+i));
+ mp_ps_print_char(mp, ' ') ;
+ }
+ ps_room(22);
+ mp_ps_print(mp, "] ");
+ mp_ps_print_scaled(mp, hh->offset_field);
+ mp_ps_print_cmd(mp, " setdash"," sd");
+ }
+}
+
+@ @<Declarations@>=
+boolean mp_gr_same_dashes (mp_dash_object *h, mp_dash_object *hh) ;
+
+@ This function test if |h| and |hh| represent the same dash pattern.
+
+The |scale_field| is ignored in this test because it is not really
+a property of the PostScript format of a dash pattern.
+
+@c
+boolean mp_gr_same_dashes (mp_dash_object *h, mp_dash_object *hh) {
+ boolean ret=false;
+ int i = 0;
+ if ( h==hh ) ret=true;
+ else if ( (h==NULL)||(hh==NULL) ) ret=false;
+ else if ( h->offset_field!=hh->offset_field ) ret=false;
+ else if ( h->array_field == hh->array_field) ret=true;
+ else if ( h->array_field == NULL || hh->array_field == NULL) ret=false;
+ else { @<Compare |dash_list(h)| and |dash_list(hh)|@>; }
+ return ret;
+}
+
+@ @<Compare |dash_list(h)| and |dash_list(hh)|@>=
+{
+ while (*(h->array_field+i)!=-1 &&
+ *(hh->array_field+i)!=-1 &&
+ *(h->array_field+i) == *(hh->array_field+i)) i++;
+ if (i>0) {
+ if (*(h->array_field+(i))==-1 && *(hh->array_field+(i)) == -1)
+ ret=true;
+ }
+}
+
+@ When stroking a path with an elliptical pen, it is necessary to transform
+the coordinate system so that a unit circular pen will have the desired shape.
+To keep this transformation local, we enclose it in a
+$$\&{gsave}\ldots\&{grestore}$$
+block. Any translation component must be applied to the path being stroked
+while the rest of the transformation must apply only to the pen.
+If |fill_also=true|, the path is to be filled as well as stroked so we must
+insert commands to do this after giving the path.
+
+@<Declarations@>=
+void mp_gr_stroke_ellipse (MP mp, mp_graphic_object *h, boolean fill_also) ;
+
+@
+@c void mp_gr_stroke_ellipse (MP mp, mp_graphic_object *h, boolean fill_also) {
+ /* generate an elliptical pen stroke from object |h| */
+ scaled txx,txy,tyx,tyy; /* transformation parameters */
+ mp_knot *p; /* the pen to stroke with */
+ scaled d1,det; /* for tweaking transformation parameters */
+ integer s; /* also for tweaking transformation paramters */
+ boolean transformed; /* keeps track of whether gsave/grestore are needed */
+ transformed=false;
+ @<Use |pen_p(h)| to set the transformation parameters and give the initial
+ translation@>;
+ @<Tweak the transformation parameters so the transformation is nonsingular@>;
+ if (gr_type(h)==mp_fill_code) {
+ mp_gr_ps_path_out(mp, gr_path_p((mp_fill_object *)h));
+ } else {
+ mp_gr_ps_path_out(mp, gr_path_p((mp_stroked_object *)h));
+ }
+ if ( mp->internal[mp_procset]==0 ) {
+ if ( fill_also ) mp_ps_print_nl(mp, "gsave fill grestore");
+ @<Issue \ps\ commands to transform the coordinate system@>;
+ mp_ps_print(mp, " stroke");
+ if ( transformed ) mp_ps_print(mp, " grestore");
+ } else {
+ if ( fill_also ) mp_ps_print_nl(mp, "B"); else mp_ps_print_ln(mp);
+ if ( (txy!=0)||(tyx!=0) ) {
+ mp_ps_print(mp, " [");
+ mp_ps_pair_out(mp, txx,tyx);
+ mp_ps_pair_out(mp, txy,tyy);
+ mp_ps_print(mp, "0 0] t");
+ } else if ((txx!=unity)||(tyy!=unity) ) {
+ mp_ps_pair_out(mp,txx,tyy);
+ mp_ps_print(mp, " s");
+ };
+ mp_ps_print(mp, " S");
+ if ( transformed ) mp_ps_print(mp, " Q");
+ }
+ mp_ps_print_ln(mp);
+}
+
+@ @<Use |pen_p(h)| to set the transformation parameters and give the...@>=
+if (gr_type(h)==mp_fill_code) {
+ p=gr_pen_p((mp_fill_object *)h);
+} else {
+ p=gr_pen_p((mp_stroked_object *)h);
+}
+txx=gr_left_x(p);
+tyx=gr_left_y(p);
+txy=gr_right_x(p);
+tyy=gr_right_y(p);
+if ( (gr_x_coord(p)!=0)||(gr_y_coord(p)!=0) ) {
+ mp_ps_print_nl(mp, "");
+ mp_ps_print_cmd(mp, "gsave ","q ");
+ mp_ps_pair_out(mp, gr_x_coord(p), gr_y_coord(p));
+ mp_ps_print(mp, "translate ");
+ txx-=gr_x_coord(p);
+ tyx-=gr_y_coord(p);
+ txy-=gr_x_coord(p);
+ tyy-=gr_y_coord(p);
+ transformed=true;
+} else {
+ mp_ps_print_nl(mp, "");
+}
+@<Adjust the transformation to account for |gs_width| and output the
+ initial \&{gsave} if |transformed| should be |true|@>
+
+@ @<Adjust the transformation to account for |gs_width| and output the...@>=
+if ( gs_width!=unity ) {
+ if ( gs_width==0 ) {
+ txx=unity; tyy=unity;
+ } else {
+ txx=mp_make_scaled(mp, txx,gs_width);
+ txy=mp_make_scaled(mp, txy,gs_width);
+ tyx=mp_make_scaled(mp, tyx,gs_width);
+ tyy=mp_make_scaled(mp, tyy,gs_width);
+ };
+}
+if ( (txy!=0)||(tyx!=0)||(txx!=unity)||(tyy!=unity) ) {
+ if ( (! transformed) ){
+ mp_ps_print_cmd(mp, "gsave ","q ");
+ transformed=true;
+ }
+}
+
+@ @<Issue \ps\ commands to transform the coordinate system@>=
+if ( (txy!=0)||(tyx!=0) ){
+ mp_ps_print_ln(mp);
+ mp_ps_print_char(mp, '[');
+ mp_ps_pair_out(mp, txx,tyx);
+ mp_ps_pair_out(mp, txy,tyy);
+ mp_ps_print(mp, "0 0] concat");
+} else if ( (txx!=unity)||(tyy!=unity) ){
+ mp_ps_print_ln(mp);
+ mp_ps_pair_out(mp, txx,tyy);
+ mp_ps_print(mp, "scale");
+}
+
+@ The \ps\ interpreter will probably abort if it encounters a singular
+transformation matrix. The determinant must be large enough to ensure that
+the printed representation will be nonsingular. Since the printed
+representation is always within $2^{-17}$ of the internal |scaled| value, the
+total error is at most $4T_{\rm max}2^{-17}$, where $T_{\rm max}$ is a bound on
+the magnitudes of |txx/65536|, |txy/65536|, etc.
+
+The |aspect_bound*(gs_width+1)| bound on the components of the pen
+transformation allows $T_{\rm max}$ to be at most |2*aspect_bound|.
+
+@<Tweak the transformation parameters so the transformation is nonsingular@>=
+det=mp_take_scaled(mp, txx,tyy) - mp_take_scaled(mp, txy,tyx);
+d1=4*aspect_bound+1;
+if ( abs(det)<d1 ) {
+ if ( det>=0 ) { d1=d1-det; s=1; }
+ else { d1=-d1-det; s=-1; };
+ d1=d1*unity;
+ if ( abs(txx)+abs(tyy)>=abs(txy)+abs(tyy) ) {
+ if ( abs(txx)>abs(tyy) ) tyy=tyy+(d1+s*abs(txx)) / txx;
+ else txx=txx+(d1+s*abs(tyy)) / tyy;
+ } else {
+ if ( abs(txy)>abs(tyx) ) tyx=tyx+(d1+s*abs(txy)) / txy;
+ else txy=txy+(d1+s*abs(tyx)) / tyx;
+ }
+}
+
+@ Here is a simple routine that just fills a cycle.
+
+@<Declarations@>=
+void mp_gr_ps_fill_out (MP mp, mp_knot *p);
+
+@ @c
+void mp_gr_ps_fill_out (MP mp, mp_knot *p) { /* fill cyclic path~|p| */
+ mp_gr_ps_path_out(mp, p);
+ mp_ps_print_cmd(mp, " fill"," F");
+ mp_ps_print_ln(mp);
+}
+
+@ A text node may specify an arbitrary transformation but the usual case
+involves only shifting, scaling, and occasionally rotation. The purpose
+of |choose_scale| is to select a scale factor so that the remaining
+transformation is as ``nice'' as possible. The definition of ``nice''
+is somewhat arbitrary but shifting and $90^\circ$ rotation are especially
+nice because they work out well for bitmap fonts. The code here selects
+a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the
+non-shifting part of the transformation matrix. It is careful to avoid
+additions that might cause undetected overflow.
+
+@<Declarations@>=
+scaled mp_gr_choose_scale (MP mp, mp_graphic_object *p) ;
+
+@ @c scaled mp_gr_choose_scale (MP mp, mp_graphic_object *p) {
+ /* |p| should point to a text node */
+ scaled a,b,c,d,ad,bc; /* temporary values */
+ a=gr_txx_val(p);
+ b=gr_txy_val(p);
+ c=gr_tyx_val(p);
+ d=gr_tyy_val(p);
+ if ( a<0 ) negate(a);
+ if ( b<0 ) negate(b);
+ if ( c<0 ) negate(c);
+ if ( d<0 ) negate(d);
+ ad=half(a-d);
+ bc=half(b-c);
+ return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc));
+}
+
+@ The potential overflow here is caused by the fact the returned value
+has to fit in a |name_type|, which is a quarterword.
+
+@d fscale_tolerance 65 /* that's $.001\times2^{16}$ */
+
+@<Declarations@>=
+quarterword mp_size_index (MP mp, font_number f, scaled s) ;
+
+@ @c
+quarterword mp_size_index (MP mp, font_number f, scaled s) {
+ pointer p,q; /* the previous and current font size nodes */
+ quarterword i; /* the size index for |q| */
+ q=mp->font_sizes[f];
+ i=0;
+ while ( q!=null ) {
+ if ( abs(s-sc_factor(q))<=fscale_tolerance )
+ return i;
+ else
+ { p=q; q=link(q); incr(i); };
+ if ( i==max_quarterword )
+ mp_overflow(mp, "sizes per font",max_quarterword);
+@:MetaPost capacity exceeded sizes per font}{\quad sizes per font@>
+ }
+ q=mp_get_node(mp, font_size_size);
+ sc_factor(q)=s;
+ if ( i==0 ) mp->font_sizes[f]=q; else link(p)=q;
+ return i;
+}
+
+@ @<Declarations@>=
+scaled mp_indexed_size (MP mp,font_number f, quarterword j);
+
+@ @c
+scaled mp_indexed_size (MP mp,font_number f, quarterword j) {
+ pointer p; /* a font size node */
+ quarterword i; /* the size index for |p| */
+ p=mp->font_sizes[f];
+ i=0;
+ if ( p==null ) mp_confusion(mp, "size");
+ while ( (i!=j) ) {
+ incr(i); p=link(p);
+ if ( p==null ) mp_confusion(mp, "size");
+ }
+ return sc_factor(p);
+}
+
+@ @<Declarations@>=
+void mp_clear_sizes (MP mp) ;
+
+@ @c void mp_clear_sizes (MP mp) {
+ font_number f; /* the font whose size list is being cleared */
+ pointer p; /* current font size nodes */
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ while ( mp->font_sizes[f]!=null ) {
+ p=mp->font_sizes[f];
+ mp->font_sizes[f]=link(p);
+ mp_free_node(mp, p,font_size_size);
+ }
+ }
+}
+
+@ A text node may specify an arbitrary transformation but the usual case
+involves only shifting, scaling, and occasionally rotation. The purpose
+of |choose_scale| is to select a scale factor so that the remaining
+transformation is as ``nice'' as possible. The definition of ``nice''
+is somewhat arbitrary but shifting and $90^\circ$ rotation are especially
+nice because they work out well for bitmap fonts. The code here selects
+a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the
+non-shifting part of the transformation matrix. It is careful to avoid
+additions that might cause undetected overflow.
+
+@<Declare the \ps\ output procedures@>=
+scaled mp_choose_scale (MP mp, mp_graphic_object *p) ;
+
+@ @c scaled mp_choose_scale (MP mp, mp_graphic_object *p) {
+ /* |p| should point to a text node */
+ scaled a,b,c,d,ad,bc; /* temporary values */
+ a=gr_txx_val(p);
+ b=gr_txy_val(p);
+ c=gr_tyx_val(p);
+ d=gr_tyy_val(p);
+ if ( (a<0) ) negate(a);
+ if ( (b<0) ) negate(b);
+ if ( (c<0) ) negate(c);
+ if ( (d<0) ) negate(d);
+ ad=half(a-d);
+ bc=half(b-c);
+ return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc));
+}
+
+@ There may be many sizes of one font and we need to keep track of the
+characters used for each size. This is done by keeping a linked list of
+sizes for each font with a counter in each text node giving the appropriate
+position in the size list for its font.
+
+@d font_size_size 2 /* size of a font size node */
+
+
+@ @<Declarations@>=
+void mp_apply_mark_string_chars(MP mp, mp_edge_object *h, int next_size);
+
+@ @c
+void mp_apply_mark_string_chars(MP mp, mp_edge_object *h, int next_size) {
+ mp_graphic_object * p;
+ p=h->body;
+ while ( p!= NULL ) {
+ if ( gr_type(p)==mp_text_code ) {
+ if ( gr_font_n(p)!=null_font ) {
+ if ( gr_name_type(p)==next_size )
+ mp_mark_string_chars(mp, gr_font_n(p),gr_text_p(p));
+ }
+ }
+ p=gr_link(p);
+ }
+}
+
+@ @<Unmark all marked characters@>=
+for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp->font_sizes[f]!=null ) {
+ mp_unmark_font(mp, f);
+ mp->font_sizes[f]=null;
+ }
+}
+
+@ @<Scan all the text nodes and mark the used ...@>=
+p=hh->body;
+while ( p!=null ) {
+ if ( gr_type(p)==mp_text_code ) {
+ f = gr_font_n(p);
+ if (f!=null_font ) {
+ switch (prologues) {
+ case 2:
+ case 3:
+ mp->font_sizes[f] = mp_void;
+ mp_mark_string_chars(mp, f, gr_text_p(p));
+ if (mp_has_fm_entry(mp,f,NULL) ) {
+ if (mp->font_enc_name[f]==NULL )
+ mp->font_enc_name[f] = mp_fm_encoding_name(mp,f);
+ mp->font_ps_name[f] = mp_fm_font_name(mp,f);
+ }
+ break;
+ case 1:
+ mp->font_sizes[f]=mp_void;
+ break;
+ default:
+ gr_name_type(p)=mp_size_index(mp, f,mp_choose_scale(mp, p));
+ if ( gr_name_type(p)==0 )
+ mp_mark_string_chars(mp, f, gr_text_p(p));
+ }
+ }
+ }
+ p=gr_link(p);
+}
+
+
+@
+@d pen_is_elliptical(A) ((A)==gr_next_knot((A)))
+
+@<Exported function headers@>=
+void mp_gr_ship_out (mp_edge_object *hh, int prologues, int procset) ;
+
+@ @c
+void mp_gr_ship_out (mp_edge_object *hh, int prologues, int procset) {
+ mp_graphic_object *p;
+ scaled ds,scf; /* design size and scale factor for a text node */
+ font_number f; /* for loops over fonts while (un)marking characters */
+ boolean transformed; /* is the coordinate system being transformed? */
+ MP mp = hh->_parent;
+ if (mp->history >= mp_fatal_error_stop ) return;
+ if (prologues<0)
+ prologues = (mp->internal[mp_prologues]>>16);
+ if (procset<0)
+ procset = (mp->internal[mp_procset]>>16);
+ mp_open_output_file(mp);
+ mp_print_initial_comment(mp, hh, prologues);
+ p = hh->body;
+ @<Unmark all marked characters@>;
+ if ( prologues==2 || prologues==3 ) {
+ mp_reload_encodings(mp);
+ }
+ @<Scan all the text nodes and mark the used characters@>;
+ if ( prologues==2 || prologues==3 ) {
+ mp_print_improved_prologue(mp, hh, prologues, procset);
+ } else {
+ mp_print_prologue(mp, hh, prologues, procset);
+ }
+ mp_gs_unknown_graphics_state(mp, 0);
+ p = hh->body;
+ while ( p!=NULL ) {
+ if ( gr_has_color(p) ) {
+ @<Write |pre_script| of |p|@>;
+ }
+ mp_gr_fix_graphics_state(mp, p);
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ if ( gr_pen_p((mp_fill_object *)p)==NULL ) {
+ mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p));
+ } else if ( pen_is_elliptical(gr_pen_p((mp_fill_object *)p)) ) {
+ mp_gr_stroke_ellipse(mp, p,true);
+ } else {
+ mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p));
+ mp_gr_ps_fill_out(mp, gr_htap_p(p));
+ }
+ if ( gr_post_script((mp_fill_object *)p)!=NULL ) {
+ mp_ps_print_nl (mp, gr_post_script((mp_fill_object *)p));
+ mp_ps_print_ln(mp);
+ }
+ break;
+ case mp_stroked_code:
+ if ( pen_is_elliptical(gr_pen_p((mp_stroked_object *)p)) )
+ mp_gr_stroke_ellipse(mp, p,false);
+ else {
+ mp_gr_ps_fill_out(mp, gr_path_p((mp_stroked_object *)p));
+ }
+ if ( gr_post_script((mp_stroked_object *)p)!=NULL ) {
+ mp_ps_print_nl (mp, gr_post_script((mp_stroked_object *)p));
+ mp_ps_print_ln(mp);
+ }
+ break;
+ case mp_text_code:
+ if ( (gr_font_n(p)!=null_font) && (strlen(gr_text_p(p))>0) ) {
+ if ( prologues>0 )
+ scf=mp_gr_choose_scale(mp, p);
+ else
+ scf=mp_indexed_size(mp, gr_font_n(p), gr_name_type(p));
+ @<Shift or transform as necessary before outputting text node~|p| at scale
+ factor~|scf|; set |transformed:=true| if the original transformation must
+ be restored@>;
+ mp_ps_string_out(mp, gr_text_p(p));
+ mp_ps_name_out(mp, mp->font_name[gr_font_n(p)],false);
+ @<Print the size information and \ps\ commands for text node~|p|@>;
+ mp_ps_print_ln(mp);
+ }
+ if ( gr_post_script((mp_text_object *)p)!=NULL ) {
+ mp_ps_print_nl (mp, gr_post_script((mp_text_object *)p)); mp_ps_print_ln(mp);
+ }
+ break;
+ case mp_start_clip_code:
+ mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "gsave ","q ");
+ mp_gr_ps_path_out(mp, gr_path_p((mp_clip_object *)p));
+ mp_ps_print_cmd(mp, " clip"," W");
+ mp_ps_print_ln(mp);
+ if ( mp->internal[mp_restore_clip_color]>0 )
+ mp_gs_unknown_graphics_state(mp, 1);
+ break;
+ case mp_stop_clip_code:
+ mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "grestore","Q");
+ mp_ps_print_ln(mp);
+ if ( mp->internal[mp_restore_clip_color]>0 )
+ mp_gs_unknown_graphics_state(mp, 2);
+ else
+ mp_gs_unknown_graphics_state(mp, -1);
+ break;
+ case mp_start_bounds_code:
+ case mp_stop_bounds_code:
+ break;
+ case mp_special_code:
+ mp_ps_print_nl (mp, gr_pre_script((mp_special_object *)p));
+ mp_ps_print_ln (mp);
+ break;
+ } /* all cases are enumerated */
+ p=gr_link(p);
+ }
+ mp_ps_print_cmd(mp, "showpage","P"); mp_ps_print_ln(mp);
+ mp_ps_print(mp, "%%EOF"); mp_ps_print_ln(mp);
+ (mp->close_file)(mp,mp->ps_file);
+ if ( prologues<=0 )
+ mp_clear_sizes(mp);
+}
+
+@
+@d do_write_prescript(a,b) {
+ if ( (gr_pre_script((b *)a))!=NULL ) {
+ mp_ps_print_nl (mp, gr_pre_script((b *)a));
+ mp_ps_print_ln(mp);
+ }
+}
+
+@<Write |pre_script| of |p|@>=
+{
+ if (gr_type(p)==mp_fill_code) { do_write_prescript(p,mp_fill_object); }
+ else if (gr_type(p)==mp_stroked_code) { do_write_prescript(p,mp_stroked_object); }
+ else if (gr_type(p)==mp_text_code) { do_write_prescript(p,mp_text_object); }
+}
+
+@ The envelope of a cyclic path~|q| could be computed by calling
+|make_envelope| once for |q| and once for its reversal. We don't do this
+because it would fail color regions that are covered by the pen regardless
+of where it is placed on~|q|.
+
+@<Break the cycle and set |t:=1| if path |q| is cyclic@>=
+if ( gr_left_type(q)!=mp_endpoint ) {
+ gr_left_type(mp_gr_insert_knot(mp, q,gr_x_coord(q),gr_y_coord(q)))=mp_endpoint;
+ gr_right_type(q)=mp_endpoint;
+ q=gr_next_knot(q);
+ t=1;
+}
+
+@ @<Print the size information and \ps\ commands for text node~|p|@>=
+ps_room(18);
+mp_ps_print_char(mp, ' ');
+ds=(mp->font_dsize[gr_font_n(p)]+8) / 16;
+mp_ps_print_scaled(mp, mp_take_scaled(mp, ds,scf));
+mp_ps_print(mp, " fshow");
+if ( transformed )
+ mp_ps_print_cmd(mp, " grestore"," Q")
+
+
+
+@ @<Shift or transform as necessary before outputting text node~|p| at...@>=
+transformed=(gr_txx_val(p)!=scf)||(gr_tyy_val(p)!=scf)||
+ (gr_txy_val(p)!=0)||(gr_tyx_val(p)!=0);
+if ( transformed ) {
+ mp_ps_print_cmd(mp, "gsave [", "q [");
+ mp_ps_pair_out(mp, mp_make_scaled(mp, gr_txx_val(p),scf),
+ mp_make_scaled(mp, gr_tyx_val(p),scf));
+ mp_ps_pair_out(mp, mp_make_scaled(mp, gr_txy_val(p),scf),
+ mp_make_scaled(mp, gr_tyy_val(p),scf));
+ mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p));
+ mp_ps_print_cmd(mp, "] concat 0 0 moveto","] t 0 0 m");
+} else {
+ mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p));
+ mp_ps_print_cmd(mp, "moveto","m");
+}
+mp_ps_print_ln(mp)
+
+
+@ @<Exported function headers@>=
+void mp_gr_toss_objects ( mp_edge_object *hh) ;
+void mp_gr_toss_object (mp_graphic_object *p) ;
+
+@ @c
+void mp_gr_toss_object (mp_graphic_object *p) {
+ mp_fill_object *tf;
+ mp_stroked_object *ts;
+ mp_text_object *tt;
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ tf = (mp_fill_object *)p;
+ mp_xfree(gr_pre_script(tf));
+ mp_xfree(gr_post_script(tf));
+ mp_gr_toss_knot_list(mp,gr_pen_p(tf));
+ mp_gr_toss_knot_list(mp,gr_path_p(tf));
+ mp_gr_toss_knot_list(mp,gr_htap_p(p));
+ break;
+ case mp_stroked_code:
+ ts = (mp_stroked_object *)p;
+ mp_xfree(gr_pre_script(ts));
+ mp_xfree(gr_post_script(ts));
+ mp_gr_toss_knot_list(mp,gr_pen_p(ts));
+ mp_gr_toss_knot_list(mp,gr_path_p(ts));
+ if (gr_dash_p(p)!=NULL)
+ mp_gr_toss_dashes (mp,gr_dash_p(p));
+ break;
+ case mp_text_code:
+ tt = (mp_text_object *)p;
+ mp_xfree(gr_pre_script(tt));
+ mp_xfree(gr_post_script(tt));
+ mp_xfree(gr_text_p(p));
+ mp_xfree(gr_font_name(p));
+ break;
+ case mp_start_clip_code:
+ mp_gr_toss_knot_list(mp,gr_path_p((mp_clip_object *)p));
+ break;
+ case mp_start_bounds_code:
+ mp_gr_toss_knot_list(mp,gr_path_p((mp_bounds_object *)p));
+ break;
+ case mp_stop_clip_code:
+ case mp_stop_bounds_code:
+ break;
+ case mp_special_code:
+ mp_xfree(gr_pre_script((mp_special_object *)p));
+ break;
+ } /* all cases are enumerated */
+ mp_xfree(p);
+}
+
+
+@ @c
+void mp_gr_toss_objects (mp_edge_object *hh) {
+ mp_graphic_object *p, *q;
+ p = hh->body;
+ while ( p!=NULL ) {
+ q = gr_link(p);
+ mp_gr_toss_object(p);
+ p=q;
+ }
+ mp_xfree(hh);
+}
+
+@ @<Exported function headers@>=
+mp_graphic_object *mp_gr_copy_object (MP mp, mp_graphic_object *p) ;
+
+@ @c
+mp_graphic_object *
+mp_gr_copy_object (MP mp, mp_graphic_object *p) {
+ mp_fill_object *tf;
+ mp_stroked_object *ts;
+ mp_text_object *tt;
+ mp_clip_object *tc;
+ mp_bounds_object *tb;
+ mp_special_object *tp;
+ mp_graphic_object *q = NULL;
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ tf = (mp_fill_object *)mp_new_graphic_object(mp, mp_fill_code);
+ gr_pre_script(tf) = mp_xstrdup(mp, gr_pre_script((mp_fill_object *)p));
+ gr_post_script(tf) = mp_xstrdup(mp, gr_post_script((mp_fill_object *)p));
+ gr_path_p(tf) = mp_gr_copy_path(mp,gr_path_p((mp_fill_object *)p));
+ gr_htap_p(tf) = mp_gr_copy_path(mp,gr_htap_p(p));
+ gr_pen_p(tf) = mp_gr_copy_path(mp,gr_pen_p((mp_fill_object *)p));
+ q = (mp_graphic_object *)tf;
+ break;
+ case mp_stroked_code:
+ ts = (mp_stroked_object *)mp_new_graphic_object(mp, mp_stroked_code);
+ gr_pre_script(ts) = mp_xstrdup(mp, gr_pre_script((mp_stroked_object *)p));
+ gr_post_script(ts) = mp_xstrdup(mp, gr_post_script((mp_stroked_object *)p));
+ gr_path_p(ts) = mp_gr_copy_path(mp,gr_path_p((mp_stroked_object *)p));
+ gr_pen_p(ts) = mp_gr_copy_path(mp,gr_pen_p((mp_stroked_object *)p));
+ gr_dash_p(ts) = mp_gr_copy_dashes(mp,gr_dash_p(p));
+ q = (mp_graphic_object *)ts;
+ break;
+ case mp_text_code:
+ tt = (mp_text_object *)mp_new_graphic_object(mp, mp_text_code);
+ gr_pre_script(tt) = mp_xstrdup(mp, gr_pre_script((mp_text_object *)p));
+ gr_post_script(tt) = mp_xstrdup(mp, gr_post_script((mp_text_object *)p));
+ gr_text_p(tt) = mp_xstrdup(mp, gr_text_p(p));
+ gr_font_name(tt) = mp_xstrdup(mp, gr_font_name(p));
+ q = (mp_graphic_object *)tt;
+ break;
+ case mp_start_clip_code:
+ tc = (mp_clip_object *)mp_new_graphic_object(mp, mp_start_clip_code);
+ gr_path_p(tc) = mp_gr_copy_path(mp,gr_path_p((mp_clip_object *)p));
+ q = (mp_graphic_object *)tc;
+ break;
+ case mp_start_bounds_code:
+ tb = (mp_bounds_object *)mp_new_graphic_object(mp, mp_start_bounds_code);
+ gr_path_p(tb) = mp_gr_copy_path(mp,gr_path_p((mp_bounds_object *)p));
+ q = (mp_graphic_object *)tb;
+ break;
+ case mp_special_code:
+ tp = (mp_special_object *)mp_new_graphic_object(mp, mp_special_code);
+ gr_pre_script(tp) = mp_xstrdup(mp, gr_pre_script((mp_special_object *)p));
+ q = (mp_graphic_object *)tp;
+ break;
+ case mp_stop_clip_code:
+ q = mp_new_graphic_object(mp, mp_stop_clip_code);
+ break;
+ case mp_stop_bounds_code:
+ q = mp_new_graphic_object(mp, mp_stop_bounds_code);
+ break;
+ } /* all cases are enumerated */
+ return q;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/lua/texluac.c b/Build/source/texk/web2c/luatexdir/lua/texluac.c
new file mode 100644
index 00000000000..4bc13458d13
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/lua/texluac.c
@@ -0,0 +1,199 @@
+/*
+** $Id: texluac.c 1013 2008-02-14 00:09:02Z oneiros $
+** Lua compiler (saves bytecodes to files; also list bytecodes)
+** See Copyright Notice in lua.h
+*/
+
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#define luac_c
+#define LUA_CORE
+
+#include <../lua51/lua.h>
+#include <../lua51/lauxlib.h>
+
+#include <../lua51/ldo.h>
+#include <../lua51/lfunc.h>
+#include <../lua51/lmem.h>
+#include <../lua51/lobject.h>
+#include <../lua51/lopcodes.h>
+#include <../lua51/lstring.h>
+#include <../lua51/lundump.h>
+
+#define PROGNAME "texluac" /* default program name */
+#define OUTPUT PROGNAME ".out" /* default output file */
+
+static int dumping=1; /* dump bytecodes? */
+static int stripping=0; /* strip debug information? */
+static char Output[]={ OUTPUT }; /* default output file name */
+static const char* output=Output; /* actual output file name */
+static const char* progname=PROGNAME; /* actual program name */
+
+static void fatal(const char* message)
+{
+ fprintf(stderr,"%s: %s\n",progname,message);
+ exit(EXIT_FAILURE);
+}
+
+static void cannot(const char* what)
+{
+ fprintf(stderr,"%s: cannot %s %s: %s\n",progname,what,output,strerror(errno));
+ exit(EXIT_FAILURE);
+}
+
+static void usage(const char* message)
+{
+ if (*message=='-')
+ fprintf(stderr,"%s: unrecognized option " LUA_QS "\n",progname,message);
+ else
+ fprintf(stderr,"%s: %s\n",progname,message);
+ fprintf(stderr,
+ "usage: %s [options] [filenames].\n"
+ "Available options are:\n"
+ " - process stdin\n"
+ " -o name output to file " LUA_QL("name") " (default is \"%s\")\n"
+ " -p parse only\n"
+ " -s strip debug information\n"
+ " -v show version information\n"
+ " -- stop handling options\n",
+ progname,Output);
+ exit(EXIT_FAILURE);
+}
+
+#define IS(s) (strcmp(argv[i],s)==0)
+
+static int doargs(int argc, char* argv[])
+{
+ int i;
+ int version=0;
+ if (argv[0]!=NULL && *argv[0]!=0) progname=argv[0];
+ for (i=1; i<argc; i++)
+ {
+ if (*argv[i]!='-') /* end of options; keep it */
+ break;
+ else if (IS("--")) /* end of options; skip it */
+ {
+ ++i;
+ if (version) ++version;
+ break;
+ }
+ else if (IS("-")) /* end of options; use stdin */
+ break;
+ else if (IS("-o")) /* output file */
+ {
+ output=argv[++i];
+ if (output==NULL || *output==0) usage(LUA_QL("-o") " needs argument");
+ if (IS("-")) output=NULL;
+ }
+ else if (IS("-p")) /* parse only */
+ dumping=0;
+ else if (IS("-s")) /* strip debug information */
+ stripping=1;
+ else if (IS("-v")) /* show version */
+ ++version;
+ else if (IS("--luaconly")) /* ignore */
+ ;
+ else if (IS("--luac")) /* ignore */
+ ;
+ else /* unknown option */
+ usage(argv[i]);
+ }
+ if (i==argc && (!dumping))
+ {
+ dumping=0;
+ argv[--i]=Output;
+ }
+ if (version)
+ {
+ printf("%s %s\n",LUA_RELEASE,LUA_COPYRIGHT);
+ if (version==argc-1) exit(EXIT_SUCCESS);
+ }
+ return i;
+}
+
+#define toproto(L,i) (clvalue(L->top+(i))->l.p)
+
+static const Proto* combine(lua_State* L, int n)
+{
+ if (n==1)
+ return toproto(L,-1);
+ else
+ {
+ int i,pc;
+ Proto* f=luaF_newproto(L);
+ setptvalue2s(L,L->top,f); incr_top(L);
+ f->source=luaS_newliteral(L,"=(" PROGNAME ")");
+ f->maxstacksize=1;
+ pc=2*n+1;
+ f->code=luaM_newvector(L,pc,Instruction);
+ f->sizecode=pc;
+ f->p=luaM_newvector(L,n,Proto*);
+ f->sizep=n;
+ pc=0;
+ for (i=0; i<n; i++)
+ {
+ f->p[i]=toproto(L,i-n-1);
+ f->code[pc++]=CREATE_ABx(OP_CLOSURE,0,i);
+ f->code[pc++]=CREATE_ABC(OP_CALL,0,1,1);
+ }
+ f->code[pc++]=CREATE_ABC(OP_RETURN,0,1,0);
+ return f;
+ }
+}
+
+static int writer(lua_State* L, const void* p, size_t size, void* u)
+{
+ UNUSED(L);
+ return (fwrite(p,size,1,(FILE*)u)!=1) && (size!=0);
+}
+
+struct Smain {
+ int argc;
+ char** argv;
+};
+
+static int pmain(lua_State* L)
+{
+ struct Smain* s = (struct Smain*)lua_touserdata(L, 1);
+ int argc=s->argc;
+ char** argv=s->argv;
+ const Proto* f;
+ int i;
+ if (!lua_checkstack(L,argc)) fatal("too many input files");
+ for (i=0; i<argc; i++)
+ {
+ const char* filename=IS("-") ? NULL : argv[i];
+ if (luaL_loadfile(L,filename)!=0) fatal(lua_tostring(L,-1));
+ }
+ f=combine(L,argc);
+ if (dumping)
+ {
+ FILE* D= (output==NULL) ? stdout : fopen(output,"wb");
+ if (D==NULL) cannot("open");
+ lua_lock(L);
+ luaU_dump(L,f,writer,D,stripping);
+ lua_unlock(L);
+ if (ferror(D)) cannot("write");
+ if (fclose(D)) cannot("close");
+ }
+ return 0;
+}
+
+int luac_main(int argc, char* argv[])
+{
+ lua_State* L;
+ struct Smain s;
+ int i=doargs(argc,argv);
+ argc-=i; argv+=i;
+ if (argc<=0) usage("no input files given");
+ L=lua_open();
+ if (L==NULL) fatal("not enough memory for state");
+ s.argc=argc;
+ s.argv=argv;
+ if (lua_cpcall(L,pmain,&s)!=0) fatal(lua_tostring(L,-1));
+ lua_close(L);
+ return EXIT_SUCCESS;
+}
diff --git a/Build/source/texk/web2c/luatexdir/luatangle.ch b/Build/source/texk/web2c/luatexdir/luatangle.ch
new file mode 100644
index 00000000000..578238d722a
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatangle.ch
@@ -0,0 +1,492 @@
+% otangle.ch: web2c changes to file tangle.ch
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original tangle.ch.
+%
+% otangle.ch for C compilation with web2c.
+%
+% 10/9/82 (HT) Original version
+% 11/29 (HT) New version, with conversion to lowercase handled properly
+% Also, new control sequence:
+% @=...text...@> Put ...text... verbatim on a line
+% by itself in the Pascal output.
+% (argument must fit on one line)
+% This control sequence facilitates putting #include "gcons.h"
+% (for example) in files meant for the pc compiler.
+% Also, changed command line usage, so that the absence of a
+% change file implies no change file, rather than one with the
+% same name as the web file, with .ch at the end.
+% 1/15/83 (HT) Changed to work with version 1.2, which incorporates the
+% above change (though unbundling the output line breaking),
+% so mainly had to remove stuff.
+% 2/17 (HT) Fixed bug that caused 0-9 in identifiers to be converted to
+% Q-Y on output.
+% 3/18 (HT) Brought up to work with Version 1.5. Added -r command line
+% flag to cause a .rpl file to be written with all the lines
+% of the .web file that were replaced because of the .ch file
+% (useful for comparing with previous .rpl files, to see if a
+% change file will still work with a new version of a .web file)
+% Also, made it write a newline just before exit.
+% 4/12 (PC) Merged with Pavel's version, including adding a call to exit()
+% at the end depending upon the value of history.
+% 4/16 (PC) Brought up to date with version 1.5 released April, 1983.
+% 6/28 (HWT) Brought up to date with version 1.7 released June, 1983.
+% With new change file format, the -r option is now unnecessary.
+% 7/17 (HWT) Brought up to date with version 2.0 released July, 1983.
+% 12/18/83 (ETM) Brought up to date with version 2.5 released November, 1983.
+% 11/07/84 (ETM) Brought up to date with version 2.6.
+% 12/15/85 (ETM) Brought up to date with version 2.8.
+% 03/07/88 (ETM) Converted for use with WEB2C
+% 01/02/89 (PAM) Cosmetic upgrade to version 2.9
+% 11/30/89 (KB) Version 4.
+% (more recent changes in the ChangeLog)
+
+@x [0] Print only changes.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+\let\maybe=\iffalse
+\def\title{TANGLE changes for C}
+@z
+
+@x [?] Define and call parse_arguments.
+procedure initialize;
+ var @<Local variables for initialization@>@/
+ begin @<Set initial values@>@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize;
+ var @<Local variables for initialization@>@/
+ begin
+ kpse_set_progname (argv[0]);
+ parse_arguments;
+ @<Set initial values@>@/
+@z
+
+@x [8] Constants: increase id lengths, for TeX--XeT and tex2pdf.
+@!buf_size=100; {maximum length of input line}
+@y
+@!buf_size=3000; {maximum length of input line}
+@z
+@x
+@!max_names=10239; {number of identifiers, strings, module names;
+ must be less than 10240}
+@!max_texts=10239; {number of replacement texts, must be less than 10240}
+@y
+@!max_names=10239; {number of identifiers, strings, module names;
+ must be less than 10240}
+@!max_texts=10239; {number of replacement texts, must be less than 10240}
+@z
+
+@x
+@!stack_size=50; {number of simultaneous levels of macro expansion}
+@!max_id_length=12; {long identifiers are chopped to this length, which must
+ not exceed |line_length|}
+@!unambig_length=7; {identifiers must be unique if chopped to this length}
+ {note that 7 is more strict than \PASCAL's 8, but this can be varied}
+@y
+@!stack_size=100; {number of simultaneous levels of macro expansion}
+@!max_id_length=64; {long identifiers are chopped to this length, which must
+ not exceed |line_length|}
+@!unambig_length=64; {identifiers must be unique if chopped to this length}
+@z
+
+% [??] The text_char type is used as an array index into xord. The
+% default type `char' produces signed integers, which are bad array
+% indices in C.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@d text_char == char {the data type of characters in text files}
+@y
+@d text_char == ASCII_code {the data type of characters in text files}
+@z
+
+@x [17] enable maximum character set
+for i:=1 to @'37 do xchr[i]:=' ';
+for i:=@'200 to @'377 do xchr[i]:=' ';
+@y
+for i:=1 to @'37 do xchr[i]:=chr(i);
+for i:=@'200 to @'377 do xchr[i]:=chr(i);
+@z
+
+@x [20] terminal output: use standard i/o
+@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
+@y
+@d term_out==stdout
+@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
+@z
+
+@x
+@<Globals...@>=
+@!term_out:text_file; {the terminal as an output file}
+@y
+@z
+
+@x [21] init terminal
+@ Different systems have different ways of specifying that the output on a
+certain file will appear on the user's terminal. Here is one way to do this
+on the \PASCAL\ system that was used in \.{TANGLE}'s initial development:
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(term_out,'TTY:'); {send |term_out| output to the terminal}
+@y
+@ Different systems have different ways of specifying that the output on a
+certain file will appear on the user's terminal.
+@^system dependencies@>
+
+@<Set init...@>=
+ {Nothing need be done for C.}
+@z
+
+@x [22] flush terminal buffer
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+@y
+@d update_terminal == fflush(term_out) {empty the terminal output buffer}
+@z
+
+@x [24] open input files
+begin reset(web_file); reset(change_file);
+@y
+begin reset(web_file, web_name);
+if chg_name then reset(change_file, chg_name);
+@z
+
+@x [26] Open output files (except for the pool file).
+rewrite(Pascal_file); rewrite(pool);
+@y
+rewrite (Pascal_file, pascal_name);
+@z
+
+@x [28] Fix f^.
+ begin buffer[limit]:=xord[f^]; get(f);
+ incr(limit);
+ if buffer[limit-1]<>" " then final_limit:=limit;
+ if limit=buf_size then
+ begin while not eoln(f) do get(f);
+@y
+ begin buffer[limit]:=xord[getc(f)];
+ incr(limit);
+ if buffer[limit-1]<>" " then final_limit:=limit;
+ if limit=buf_size then
+ begin while not eoln(f) do vgetc(f);
+@z
+
+@x [??] Fix `jump_out'.
+@d fatal_error(#)==begin new_line; print(#); error; mark_fatal; jump_out;
+ end
+
+@<Error handling...@>=
+procedure jump_out;
+begin goto end_of_TANGLE;
+end;
+@y
+@d jump_out==uexit(1)
+@d fatal_error(#)==begin new_line; write(stderr, #);
+ error; mark_fatal; uexit(1);
+ end
+@z
+
+@x [38] Provide for a larger `byte_mem' and `tok_mem'. Extra capacity:
+@d ww=2 {we multiply the byte capacity by approximately this amount}
+@d zz=3 {we multiply the token capacity by approximately this amount}
+@y
+@d ww=3 {we multiply the byte capacity by approximately this amount}
+@d zz=5 {we multiply the token capacity by approximately this amount}
+@z
+
+@x [58] Case smashing options/strict checking.
+ begin if buffer[i]<>"_" then
+ begin if buffer[i]>="a" then chopped_id[s]:=buffer[i]-@'40
+ else chopped_id[s]:=buffer[i];
+@y
+ begin if (buffer[i]<>"_") or (allow_underlines) then
+ begin chopped_id[s]:=buffer[i];
+@z
+
+@x [63] Case smashing options/strict checking.
+ if c<>"_" then
+ begin if c>="a" then c:=c-@'40; {merge lowercase with uppercase}
+@y
+ if c<>"_" or (allow_underlines) then
+ begin
+@z
+
+@x [64] Delayed pool file opening.
+@<Define and output a new string...@>=
+begin ilk[p]:=numeric; {strings are like numeric macros}
+if l-double_chars=2 then {this string is for a single character}
+ equiv[p]:=buffer[id_first+1]+1073741824
+else begin equiv[p]:=string_ptr+1073741824;
+ l:=l-double_chars-1;
+@y
+@<Define and output a new string...@>=
+begin ilk[p]:=numeric; {strings are like numeric macros}
+if l-double_chars=2 then {this string is for a single character}
+ equiv[p]:=buffer[id_first+1]+1073741824
+else begin
+ {Avoid creating empty pool files.}
+ if string_ptr = 2097152 then begin
+ {Change |".web"| to |".pool"| and use the current directory.}
+ pool_name := basename_change_suffix (web_name, '.web', '.pool');
+ rewrite (pool, pool_name);
+ end;
+ equiv[p]:=string_ptr+1073741824;
+ l:=l-double_chars-1;
+@z
+
+@x [105] Accept DIV, div, MOD, and mod
+ (((out_contrib[1]="D")and(out_contrib[2]="I")and(out_contrib[3]="V")) or@|
+ ((out_contrib[1]="M")and(out_contrib[2]="O")and(out_contrib[3]="D")) ))or@|
+@^uppercase@>
+@y
+ (((out_contrib[1]="D")and(out_contrib[2]="I")and(out_contrib[3]="V")) or@|
+ ((out_contrib[1]="d")and(out_contrib[2]="i")and(out_contrib[3]="v")) or@|
+ ((out_contrib[1]="M")and(out_contrib[2]="O")and(out_contrib[3]="D")) or@|
+ ((out_contrib[1]="m")and(out_contrib[2]="o")and(out_contrib[3]="d")) ))or@|
+@z
+
+@x [110] lowercase ids
+@^uppercase@>
+ if ((out_buf[out_ptr-3]="D")and(out_buf[out_ptr-2]="I")and
+ (out_buf[out_ptr-1]="V"))or @/
+ ((out_buf[out_ptr-3]="M")and(out_buf[out_ptr-2]="O")and
+ (out_buf[out_ptr-1]="D")) then@/ goto bad_case
+@y
+ if ((out_buf[out_ptr-3]="D")and(out_buf[out_ptr-2]="I")and
+ (out_buf[out_ptr-1]="V"))or @/
+ ((out_buf[out_ptr-3]="d")and(out_buf[out_ptr-2]="i")and
+ (out_buf[out_ptr-1]="v"))or @/
+ ((out_buf[out_ptr-3]="M")and(out_buf[out_ptr-2]="O")and
+ (out_buf[out_ptr-1]="D"))or @/
+ ((out_buf[out_ptr-3]="m")and(out_buf[out_ptr-2]="o")and
+ (out_buf[out_ptr-1]="d")) then@/ goto bad_case
+@z
+
+@x [114] lowercase operators (`and', `or', etc.)
+and_sign: begin out_contrib[1]:="A"; out_contrib[2]:="N"; out_contrib[3]:="D";
+@^uppercase@>
+ send_out(ident,3);
+ end;
+not_sign: begin out_contrib[1]:="N"; out_contrib[2]:="O"; out_contrib[3]:="T";
+ send_out(ident,3);
+ end;
+set_element_sign: begin out_contrib[1]:="I"; out_contrib[2]:="N";
+ send_out(ident,2);
+ end;
+or_sign: begin out_contrib[1]:="O"; out_contrib[2]:="R"; send_out(ident,2);
+@y
+and_sign: begin out_contrib[1]:="a"; out_contrib[2]:="n"; out_contrib[3]:="d";
+ send_out(ident,3);
+ end;
+not_sign: begin out_contrib[1]:="n"; out_contrib[2]:="o"; out_contrib[3]:="t";
+ send_out(ident,3);
+ end;
+set_element_sign: begin out_contrib[1]:="i"; out_contrib[2]:="n";
+ send_out(ident,2);
+ end;
+or_sign: begin out_contrib[1]:="o"; out_contrib[2]:="r"; send_out(ident,2);
+@z
+
+@x [116] Remove conversion to uppercase
+@ Single-character identifiers represent themselves, while longer ones
+appear in |byte_mem|. All must be converted to uppercase,
+with underlines removed. Extremely long identifiers must be chopped.
+
+(Some \PASCAL\ compilers work with lowercase letters instead of
+uppercase. If this module of \.{TANGLE} is changed, it's also necessary
+to change from uppercase to lowercase in the modules that are
+listed in the index under ``uppercase''.)
+@^system dependencies@>
+@^uppercase@>
+
+@d up_to(#)==#-24,#-23,#-22,#-21,#-20,#-19,#-18,#-17,#-16,#-15,#-14,
+ #-13,#-12,#-11,#-10,#-9,#-8,#-7,#-6,#-5,#-4,#-3,#-2,#-1,#
+
+@<Cases related to identifiers@>=
+"A",up_to("Z"): begin out_contrib[1]:=cur_char; send_out(ident,1);
+ end;
+"a",up_to("z"): begin out_contrib[1]:=cur_char-@'40; send_out(ident,1);
+ end;
+identifier: begin k:=0; j:=byte_start[cur_val]; w:=cur_val mod ww;
+ while (k<max_id_length)and(j<byte_start[cur_val+ww]) do
+ begin incr(k); out_contrib[k]:=byte_mem[w,j]; incr(j);
+ if out_contrib[k]>="a" then out_contrib[k]:=out_contrib[k]-@'40
+ else if out_contrib[k]="_" then decr(k);
+ end;
+ send_out(ident,k);
+ end;
+@y
+@ Single-character identifiers represent themselves, while longer ones
+appear in |byte_mem|. All must be converted to lowercase,
+with underlines removed. Extremely long identifiers must be chopped.
+@^system dependencies@>
+
+@d up_to(#)==#-24,#-23,#-22,#-21,#-20,#-19,#-18,#-17,#-16,#-15,#-14,
+ #-13,#-12,#-11,#-10,#-9,#-8,#-7,#-6,#-5,#-4,#-3,#-2,#-1,#
+
+@<Cases related to identifiers@>=
+"A",up_to("Z"),
+"a",up_to("z"): begin out_contrib[1]:=cur_char; send_out(ident,1);
+ end;
+identifier: begin k:=0; j:=byte_start[cur_val]; w:=cur_val mod ww;
+ while (k<max_id_length)and(j<byte_start[cur_val+ww]) do
+ begin incr(k); out_contrib[k]:=byte_mem[w,j]; incr(j);
+ if not allow_underlines and (out_contrib[k]="_") then decr(k);
+ end;
+ send_out(ident,k);
+ end;
+@z
+
+@x [??] Fix casting bug
+@d add_in(#)==begin accumulator:=accumulator+next_sign*(#); next_sign:=+1;
+ end
+@y
+@d add_in(#)==begin accumulator:=accumulator+next_sign*intcast(#); next_sign:=+1;
+ end
+@z
+
+@x [179] make term_in = input
+any error stop will set |debug_cycle| to zero.
+@y
+any error stop will set |debug_cycle| to zero.
+
+@d term_in==stdin
+@z
+
+@x
+@!term_in:text_file; {the user's terminal as an input file}
+@y
+@z
+
+@x [180] remove term_in reset
+reset(term_in,'TTY:','/I'); {open |term_in| as the terminal, don't do a |get|}
+@y
+@z
+
+@x [182] write newline just before exit; use value of |history|
+print_ln(banner); {print a ``banner line''}
+@y
+print (banner); {print a ``banner line''}
+print_ln (version_string);
+@z
+
+@x
+@<Print the job |history|@>;
+@y
+@<Print the job |history|@>;
+new_line;
+if (history <> spotless) and (history <> harmless_message)
+then uexit (1)
+else uexit (0);
+@z
+
+@x [188] System-dependent changes.
+This module should be replaced, if necessary, by changes to the program
+that are necessary to make \.{TANGLE} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous modules preserve the module numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new modules, can be inserted here; then only the index
+itself will get a new module number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 4; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+begin
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('luatangle');
+
+ end else if argument_is ('underlines') then begin
+ allow_underlines := true;
+
+ end else if argument_is ('help') then begin
+ usage_help (LUATANGLE_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth', nil);
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.}
+ if (optind + 1 <> argc) and (optind + 2 <> argc) then begin
+ write_ln (stderr, 'otangle: Need one or two file arguments.');
+ usage ('otangle');
+ end;
+
+ {Supply |".web"| and |".ch"| extensions if necessary.}
+ web_name := extend_filename (cmdline (optind), 'web');
+ if optind + 2 = argc then begin
+ chg_name := extend_filename (cmdline (optind + 1), 'ch');
+ end;
+
+ {Change |".web"| to |".p"| and use the current directory.}
+ pascal_name := basename_change_suffix (web_name, '.web', '.p');
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Allow underlines.
+@.-underlines@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'underlines';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ Global filenames.
+
+@<Globals...@>=
+@!web_name,@!chg_name,@!pascal_name,@!pool_name:c_string;
+@!@!allow_underlines:boolean;
+@z
diff --git a/Build/source/texk/web2c/luatexdir/luatangle.web b/Build/source/texk/web2c/luatexdir/luatangle.web
new file mode 100644
index 00000000000..0cc3e8416c6
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatangle.web
@@ -0,0 +1,3328 @@
+% otangle.web: Omega version of file tangle.web
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original tangle.web.
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 0 was released in December, 1981.
+% Version 1 was released in September, 1982, with version 0 of TeX.
+% Slight changes were made in October, 1982, for version 0.6 of TeX.
+% Version 1.2 introduced {:nnn} comments, added @@= and @@\ (December, 1982).
+% Version 1.4 added "history" (February, 1983).
+% Version 1.5 conformed to TeX version 0.96 and fixed @@\ (March, 1983).
+% Version 1.7 introduced the new change file format (June, 1983).
+% Version 2.0 was released in July, 1983, with version 0.999 of TeX.
+% Version 2.5 was released in November, 1983, with version 1.0 of TeX.
+% Version 2.6 fixed a bug: force-line-break after a constant (August, 1984).
+% Version 2.7 fixed the definition of check_sum_prime (May, 1985).
+% Version 2.8 fixed a bug in change_buffer movement (August, 1985).
+% Version 2.9 allows nonnumeric macros before their def (December, 1988).
+% Version 3, for Sewell's book, fixed long-line bug in input_ln (March, 1989).
+% Version 4 was major change to allow 8-bit input (September, 1989).
+% Version 4.1 conforms to ANSI standard for-loop rules (September, 1990).
+% Version 4.2 fixes stat report if phase one dies (March, 1991).
+% Version 4.3 fixes @@ bug in verbatim, catches extra } (September, 1991).
+% Version 4.4 activates debug_help on errors as advertised (February, 1993).
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+\def\pb{$\.|\ldots\.|$} % Pascal brackets (|...|)
+\def\v{\.{\char'174}} % vertical (|) in typewriter font
+\mathchardef\BA="3224 % double arrow
+\def\({} % kludge for alphabetizing certain module names
+
+\def\title{OTANGLE}
+\def\contentspagenumber{123} % should be odd
+\def\topofcontents{\null\vfill
+ \titlefalse % include headline on the contents page
+ \def\rheader{\mainfont Appendix E\hfil \contentspagenumber}
+ \centerline{\titlefont The {\ttitlefont OTANGLE} processor}
+ \vskip 15pt
+ \centerline{(Version 4.4)}
+ \vfill}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+This program converts a \.{WEB} file to a \PASCAL\ file. It was written
+by D. E. Knuth in September, 1981; a somewhat similar {\mc SAIL} program had
+been developed in March, 1979. Since this program describes itself, a
+bootstrapping process involving hand-translation had to be used to get started.
+
+For large \.{WEB} files one should have a large memory, since \.{TANGLE} keeps
+all the \PASCAL\ text in memory (in an abbreviated form). The program uses
+a few features of the local \PASCAL\ compiler that may need to be changed in
+other installations:
+
+\yskip\item{1)} Case statements have a default.
+\item{2)} Input-output routines may need to be adapted for use with a particular
+character set and/or for printing messages on the user's terminal.
+
+\yskip\noindent
+These features are also present in the \PASCAL\ version of \TeX, where they
+are used in a similar (but more complex) way. System-dependent portions
+of \.{TANGLE} can be identified by looking at the entries for `system
+dependencies' in the index below.
+@!@^system dependencies@>
+
+The ``banner line'' defined here should be changed whenever \.{TANGLE}
+is modified.
+
+@d banner=='This is OTANGLE, Version 4.4'
+
+@ The program begins with a fairly normal header, made up of pieces that
+@^system dependencies@>
+will mostly be filled in later. The \.{WEB} input comes from files |web_file|
+and |change_file|, the \PASCAL\ output goes to file |Pascal_file|,
+and the string pool output goes to file |pool|.
+
+If it is necessary to abort the job because of a fatal error, the program
+calls the `|jump_out|' procedure, which goes to the label |end_of_TANGLE|.
+
+@d end_of_TANGLE = 9999 {go here to wrap it up}
+
+@p @t\4@>@<Compiler directives@>@/
+program OTANGLE(@!web_file,@!change_file,@!Pascal_file,@!pool);
+label end_of_TANGLE; {go here to finish}
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+@<Error handling procedures@>@/
+procedure initialize;
+ var @<Local variables for initialization@>@/
+ begin @<Set initial values@>@/
+ end;
+
+@ Some of this code is optional for use when debugging only;
+such material is enclosed between the delimiters |debug| and $|gubed|$.
+Other parts, delimited by |stat| and $|tats|$, are optionally included if
+statistics about \.{TANGLE}'s memory usage are desired.
+
+@d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging}
+@d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging}
+@f debug==begin
+@f gubed==end
+@#
+@d stat==@{ {change this to `$\\{stat}\equiv\null$'
+ when gathering usage statistics}
+@d tats==@t@>@} {change this to `$\\{tats}\equiv\null$'
+ when gathering usage statistics}
+@f stat==begin
+@f tats==end
+
+@ The \PASCAL\ compiler used to develop this system has ``compiler
+directives'' that can appear in comments whose first character is a dollar sign.
+In production versions of \.{TANGLE} these directives tell the compiler that
+@^system dependencies@>
+it is safe to avoid range checks and to leave out the extra code it inserts
+for the \PASCAL\ debugger's benefit, although interrupts will occur if
+there is arithmetic overflow.
+
+@<Compiler directives@>=
+@{@&$C-,A+,D-@} {no range check, catch arithmetic overflow, no debug overhead}
+@!debug @{@&$C+,D+@}@+ gubed {but turn everything on when debugging}
+
+@ Labels are given symbolic names by the following definitions. We insert
+the label `|exit|:' just before the `\ignorespaces|end|\unskip' of a
+procedure in which we have used the `|return|' statement defined below;
+the label `|restart|' is occasionally used at the very beginning of a
+procedure; and the label `|reswitch|' is occasionally used just prior to
+a \&{case} statement in which some cases change the conditions and we wish to
+branch to the newly applicable case.
+Loops that are set up with the \&{loop} construction defined below are
+commonly exited by going to `|done|' or to `|found|' or to `|not_found|',
+and they are sometimes repeated by going to `|continue|'.
+
+@d exit=10 {go here to leave a procedure}
+@d restart=20 {go here to start a procedure again}
+@d reswitch=21 {go here to start a case statement again}
+@d continue=22 {go here to resume a loop}
+@d done=30 {go here to exit a loop}
+@d found=31 {go here when you've found it}
+@d not_found=32 {go here when you've found something else}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
+@d do_nothing == {empty statement}
+@d return == goto exit {terminate a procedure call}
+@f return == nil
+@f loop == xclause
+
+@ We assume that |case| statements may include a default case that applies
+if no matching label is found. Thus, we shall use constructions like
+@^system dependencies@>
+$$\vbox{\halign{#\hfil\cr
+|case x of|\cr
+1: $\langle\,$code for $x=1\,\rangle$;\cr
+3: $\langle\,$code for $x=3\,\rangle$;\cr
+|othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr
+|endcases|\cr}}$$
+since most \PASCAL\ compilers have plugged this hole in the language by
+incorporating some sort of default mechanism. For example, the compiler
+used to develop \.{WEB} and \TeX\ allows `|others|:' as a default label,
+and other \PASCAL s allow syntaxes like `\ignorespaces|else|\unskip' or
+`\&{otherwise}' or `\\{otherwise}:', etc. The definitions of |othercases|
+and |endcases| should be changed to agree with local conventions. (Of
+course, if no default mechanism is available, the |case| statements of
+this program must be extended by listing all remaining cases. The author
+would have taken the trouble to modify \.{TANGLE} so that such extensions
+were done automatically, if he had not wanted to encourage \PASCAL\
+compiler writers to make this important change in \PASCAL, where it belongs.)
+
+@d othercases == others: {default for cases not listed explicitly}
+@d endcases == @+end {follows the default case in an extended |case| statement}
+@f othercases == else
+@f endcases == end
+
+@ The following parameters are set big enough to handle \TeX, so they
+should be sufficient for most applications of \.{TANGLE}.
+
+@<Constants...@>=
+@!buf_size=100; {maximum length of input line}
+@!max_bytes=65535; {|1/ww| times the number of bytes in identifiers,
+ strings, and module names; must be less than 65536}
+@!max_toks=65535; {|1/zz| times the number of bytes in compressed \PASCAL\ code;
+ must be less than 65536}
+@!max_names=10239; {number of identifiers, strings, module names;
+ must be less than 10240}
+@!max_texts=10239; {number of replacement texts, must be less than 10240}
+@!hash_size=353; {should be prime}
+@!longest_name=400; {module names shouldn't be longer than this}
+@!line_length=72; {lines of \PASCAL\ output have at most this many characters}
+@!out_buf_size=144; {length of output buffer, should be twice |line_length|}
+@!stack_size=50; {number of simultaneous levels of macro expansion}
+@!max_id_length=12; {long identifiers are chopped to this length, which must
+ not exceed |line_length|}
+@!unambig_length=7; {identifiers must be unique if chopped to this length}
+ {note that 7 is more strict than \PASCAL's 8, but this can be varied}
+
+@ A global variable called |history| will contain one of four values
+at the end of every run: |spotless| means that no unusual messages were
+printed; |harmless_message| means that a message of possible interest
+was printed but no serious errors were detected; |error_message| means that
+at least one error was found; |fatal_message| means that the program
+terminated abnormally. The value of |history| does not influence the
+behavior of the program; it is simply computed for the convenience
+of systems that might want to use such information.
+
+@d spotless=0 {|history| value for normal jobs}
+@d harmless_message=1 {|history| value when non-serious info was printed}
+@d error_message=2 {|history| value when an error was noted}
+@d fatal_message=3 {|history| value when we had to stop prematurely}
+@#
+@d mark_harmless==@t@>@+if history=spotless then history:=harmless_message
+@d mark_error==history:=error_message
+@d mark_fatal==history:=fatal_message
+@d biggest_char=2097151
+@d number_chars=2097152
+
+@<Glob...@>=@!history:spotless..fatal_message; {how bad was this run?}
+
+@ @<Set init...@>=history:=spotless;
+
+@* The character set.
+One of the main goals in the design of \.{WEB} has been to make it readily
+portable between a wide variety of computers. Yet \.{WEB} by its very
+nature must use a greater variety of characters than most computer
+programs deal with, and character encoding is one of the areas in which
+existing machines differ most widely from each other.
+
+To resolve this problem, all input to \.{WEAVE} and \.{TANGLE} is converted
+to an internal eight-bit code that is essentially standard ASCII, the ``American
+Standard Code for Information Interchange.'' The conversion is done
+immediately when each character is read in. Conversely, characters are
+converted from ASCII to the user's external representation just before
+they are output. (The original ASCII code was seven bits only; \.{WEB} now
+allows eight bits in an attempt to keep up with modern times.)
+
+Such an internal code is relevant to users of \.{WEB} only because it is
+the code used for preprocessed constants like \.{"A"}. If you are writing
+a program in \.{WEB} that makes use of such one-character constants, you
+should convert your input to ASCII form, like \.{WEAVE} and \.{TANGLE} do.
+Otherwise \.{WEB}'s internal coding scheme does not affect you.
+@^ASCII code@>
+
+Here is a table of the standard visible ASCII codes:
+$$\def\:{\char\count255\global\advance\count255 by 1}
+\count255='40
+\vbox{
+\hbox{\hbox to 40pt{\it\hfill0\/\hfill}%
+\hbox to 40pt{\it\hfill1\/\hfill}%
+\hbox to 40pt{\it\hfill2\/\hfill}%
+\hbox to 40pt{\it\hfill3\/\hfill}%
+\hbox to 40pt{\it\hfill4\/\hfill}%
+\hbox to 40pt{\it\hfill5\/\hfill}%
+\hbox to 40pt{\it\hfill6\/\hfill}%
+\hbox to 40pt{\it\hfill7\/\hfill}}
+\vskip 4pt
+\hrule
+\def\^{\vrule height 10.5pt depth 4.5pt}
+\halign{\hbox to 0pt{\hskip -24pt\O{#0}\hfill}&\^
+\hbox to 40pt{\tt\hfill#\hfill\^}&
+&\hbox to 40pt{\tt\hfill#\hfill\^}\cr
+04&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+05&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+06&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+07&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+10&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+11&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+12&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+13&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+14&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+15&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+16&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+17&\:&\:&\:&\:&\:&\:&\:\cr}
+\hrule width 280pt}$$
+(Actually, of course, code @'040 is an invisible blank space.) Code @'136
+was once an upward arrow (\.{\char'13}), and code @'137 was
+once a left arrow (\.^^X), in olden times when the first draft
+of ASCII code was prepared; but \.{WEB} works with today's standard
+ASCII in which those codes represent circumflex and underline as shown.
+
+@<Types...@>=
+@!ASCII_code=0..255; {eight-bit numbers, a subrange of the integers}
+
+@ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
+character sets were common, so it did not make provision for lowercase
+letters. Nowadays, of course, we need to deal with both capital and small
+letters in a convenient way, so \.{WEB} assumes that it is being used
+with a \PASCAL\ whose character set contains at least the characters of
+standard ASCII as listed above. Some \PASCAL\ compilers use the original
+name |char| for the data type associated with the characters in text files,
+while other \PASCAL s consider |char| to be a 64-element subrange of a larger
+data type that has some other name.
+
+In order to accommodate this difference, we shall use the name |text_char|
+to stand for the data type of the characters in the input and output
+files. We shall also assume that |text_char| consists of the elements
+|chr(first_text_char)| through |chr(last_text_char)|, inclusive. The
+following definitions should be adjusted if necessary.
+@^system dependencies@>
+
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=255 {ordinal number of the largest element of |text_char|}
+
+@<Types...@>=
+@!text_file=packed file of text_char;
+
+@ The \.{WEAVE} and \.{TANGLE} processors convert between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to \PASCAL's |ord| and |chr| functions.
+
+@<Globals...@>=
+@!xord: array [text_char] of ASCII_code;
+ {specifies conversion of input characters}
+@!xchr: array [ASCII_code] of text_char;
+ {specifies conversion of output characters}
+
+@ If we assume that every system using \.{WEB} is able to read and write the
+visible characters of standard ASCII (although not necessarily using the
+ASCII codes to represent them), the following assignment statements initialize
+most of the |xchr| array properly, without needing any system-dependent
+changes. For example, the statement \.{xchr[@@\'101]:=\'A\'} that appears
+in the present \.{WEB} file might be encoded in, say, {\mc EBCDIC} code
+on the external medium on which it resides, but \.{TANGLE} will convert from
+this external code to ASCII and back again. Therefore the assignment
+statement \.{XCHR[65]:=\'A\'} will appear in the corresponding \PASCAL\ file,
+and \PASCAL\ will compile this statement so that |xchr[65]| receives the
+character \.A in the external (|char|) code. Note that it would be quite
+incorrect to say \.{xchr[@@\'101]:="A"}, because |"A"| is a constant of
+type |integer|, not |char|, and because we have $|"A"|=65$ regardless of
+the external character set.
+
+@<Set init...@>=
+xchr[@'40]:=' ';
+xchr[@'41]:='!';
+xchr[@'42]:='"';
+xchr[@'43]:='#';
+xchr[@'44]:='$';
+xchr[@'45]:='%';
+xchr[@'46]:='&';
+xchr[@'47]:='''';@/
+xchr[@'50]:='(';
+xchr[@'51]:=')';
+xchr[@'52]:='*';
+xchr[@'53]:='+';
+xchr[@'54]:=',';
+xchr[@'55]:='-';
+xchr[@'56]:='.';
+xchr[@'57]:='/';@/
+xchr[@'60]:='0';
+xchr[@'61]:='1';
+xchr[@'62]:='2';
+xchr[@'63]:='3';
+xchr[@'64]:='4';
+xchr[@'65]:='5';
+xchr[@'66]:='6';
+xchr[@'67]:='7';@/
+xchr[@'70]:='8';
+xchr[@'71]:='9';
+xchr[@'72]:=':';
+xchr[@'73]:=';';
+xchr[@'74]:='<';
+xchr[@'75]:='=';
+xchr[@'76]:='>';
+xchr[@'77]:='?';@/
+xchr[@'100]:='@@';
+xchr[@'101]:='A';
+xchr[@'102]:='B';
+xchr[@'103]:='C';
+xchr[@'104]:='D';
+xchr[@'105]:='E';
+xchr[@'106]:='F';
+xchr[@'107]:='G';@/
+xchr[@'110]:='H';
+xchr[@'111]:='I';
+xchr[@'112]:='J';
+xchr[@'113]:='K';
+xchr[@'114]:='L';
+xchr[@'115]:='M';
+xchr[@'116]:='N';
+xchr[@'117]:='O';@/
+xchr[@'120]:='P';
+xchr[@'121]:='Q';
+xchr[@'122]:='R';
+xchr[@'123]:='S';
+xchr[@'124]:='T';
+xchr[@'125]:='U';
+xchr[@'126]:='V';
+xchr[@'127]:='W';@/
+xchr[@'130]:='X';
+xchr[@'131]:='Y';
+xchr[@'132]:='Z';
+xchr[@'133]:='[';
+xchr[@'134]:='\';
+xchr[@'135]:=']';
+xchr[@'136]:='^';
+xchr[@'137]:='_';@/
+xchr[@'140]:='`';
+xchr[@'141]:='a';
+xchr[@'142]:='b';
+xchr[@'143]:='c';
+xchr[@'144]:='d';
+xchr[@'145]:='e';
+xchr[@'146]:='f';
+xchr[@'147]:='g';@/
+xchr[@'150]:='h';
+xchr[@'151]:='i';
+xchr[@'152]:='j';
+xchr[@'153]:='k';
+xchr[@'154]:='l';
+xchr[@'155]:='m';
+xchr[@'156]:='n';
+xchr[@'157]:='o';@/
+xchr[@'160]:='p';
+xchr[@'161]:='q';
+xchr[@'162]:='r';
+xchr[@'163]:='s';
+xchr[@'164]:='t';
+xchr[@'165]:='u';
+xchr[@'166]:='v';
+xchr[@'167]:='w';@/
+xchr[@'170]:='x';
+xchr[@'171]:='y';
+xchr[@'172]:='z';
+xchr[@'173]:='{';
+xchr[@'174]:='|';
+xchr[@'175]:='}';
+xchr[@'176]:='~';@/
+xchr[0]:=' '; xchr[@'177]:=' '; {these ASCII codes are not used}
+
+@ Some of the ASCII codes below @'40 have been given symbolic names in
+\.{WEAVE} and \.{TANGLE} because they are used with a special meaning.
+
+@d and_sign=@'4 {equivalent to `\.{and}'}
+@d not_sign=@'5 {equivalent to `\.{not}'}
+@d set_element_sign=@'6 {equivalent to `\.{in}'}
+@d tab_mark=@'11 {ASCII code used as tab-skip}
+@d line_feed=@'12 {ASCII code thrown away at end of line}
+@d form_feed=@'14 {ASCII code used at end of page}
+@d carriage_return=@'15 {ASCII code used at end of line}
+@d left_arrow=@'30 {equivalent to `\.{:=}'}
+@d not_equal=@'32 {equivalent to `\.{<>}'}
+@d less_or_equal=@'34 {equivalent to `\.{<=}'}
+@d greater_or_equal=@'35 {equivalent to `\.{>=}'}
+@d equivalence_sign=@'36 {equivalent to `\.{==}'}
+@d or_sign=@'37 {equivalent to `\.{or}'}
+
+@ When we initialize the |xord| array and the remaining parts of |xchr|,
+it will be convenient to make use of an index variable, |i|.
+
+@<Local variables for init...@>=
+@!i:0..255;
+
+@ Here now is the system-dependent part of the character set.
+If \.{WEB} is being implemented on a garden-variety \PASCAL\ for which
+only standard ASCII codes will appear in the input and output files, you
+don't need to make any changes here. But if you have, for example, an extended
+character set like the one in Appendix~C of {\sl The \TeX book}, the first
+line of code in this module should be changed to
+$$\hbox{|for i:=1 to @'37 do xchr[i]:=chr(i);|}$$
+\.{WEB}'s character set is essentially identical to \TeX's, even with respect to
+characters less than @'40.
+@^system dependencies@>
+
+Changes to the present module will make \.{WEB} more friendly on computers
+that have an extended character set, so that one can type things like
+\.^^Z\ instead of \.{<>}. If you have an extended set of characters that
+are easily incorporated into text files, you can assign codes arbitrarily
+here, giving an |xchr| equivalent to whatever characters the users of
+\.{WEB} are allowed to have in their input files, provided that unsuitable
+characters do not correspond to special codes like |carriage_return|
+that are listed above.
+
+(The present file \.{TANGLE.WEB} does not contain any of the non-ASCII
+characters, because it is intended to be used with all implementations of
+\.{WEB}. It was originally created on a Stanford system that has a
+convenient extended character set, then ``sanitized'' by applying another
+program that transliterated all of the non-standard characters into
+standard equivalents.)
+
+@<Set init...@>=
+for i:=1 to @'37 do xchr[i]:=' ';
+for i:=@'200 to @'377 do xchr[i]:=' ';
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|.
+
+@<Set init...@>=
+for i:=first_text_char to last_text_char do xord[chr(i)]:=" ";
+for i:=1 to @'377 do xord[xchr[i]]:=i;
+xord[' ']:=" ";
+
+@* Input and output.
+The input conventions of this program are intended to be very much like those
+of \TeX\ (except, of course, that they are much simpler, because much less
+needs to be done). Furthermore they are identical to those of \.{WEAVE}.
+Therefore people who need to make modifications to all three systems
+should be able to do so without too many headaches.
+
+We use the standard \PASCAL\ input/output procedures in several places that
+\TeX\ cannot, since \.{TANGLE} does not have to deal with files that are named
+dynamically by the user, and since there is no input from the terminal.
+
+@ Terminal output is done by writing on file |term_out|, which is assumed to
+consist of characters of type |text_char|:
+@^system dependencies@>
+
+@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
+@d print_ln(#)==write_ln(term_out,#) {`|print|' and then start new line}
+@d new_line==write_ln(term_out) {start new line}
+@d print_nl(#)== {print information starting on a new line}
+ begin new_line; print(#);
+ end
+
+@<Globals...@>=
+@!term_out:text_file; {the terminal as an output file}
+
+@ Different systems have different ways of specifying that the output on a
+certain file will appear on the user's terminal. Here is one way to do this
+on the \PASCAL\ system that was used in \.{TANGLE}'s initial development:
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(term_out,'TTY:'); {send |term_out| output to the terminal}
+
+@ The |update_terminal| procedure is called when we want
+to make sure that everything we have output to the terminal so far has
+actually left the computer's internal buffers and been sent.
+@^system dependencies@>
+
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+
+@ The main input comes from |web_file|; this input may be overridden
+by changes in |change_file|. (If |change_file| is empty, there are no changes.)
+
+@<Globals...@>=
+@!web_file:text_file; {primary input}
+@!change_file:text_file; {updates}
+
+@ The following code opens the input files. Since these files were listed
+in the program header, we assume that the \PASCAL\ runtime system has
+already checked that suitable file names have been given; therefore no
+additional error checking needs to be done.
+@^system dependencies@>
+
+@p procedure open_input; {prepare to read |web_file| and |change_file|}
+begin reset(web_file); reset(change_file);
+end;
+
+@ The main output goes to |Pascal_file|, and string pool constants are
+written to the |pool| file.
+
+@<Globals...@>=
+@!Pascal_file: text_file;
+@!pool: text_file;
+
+@ The following code opens |Pascal_file| and |pool|.
+Since these files were listed in the program header, we assume that the
+\PASCAL\ runtime system has checked that suitable external file names have
+been given.
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(Pascal_file); rewrite(pool);
+
+@ Input goes into an array called |buffer|.
+
+@<Globals...@>=@!buffer: array[0..buf_size] of ASCII_code;
+
+@ The |input_ln| procedure brings the next line of input from the specified
+file into the |buffer| array and returns the value |true|, unless the file has
+already been entirely read, in which case it returns |false|. The conventions
+of \TeX\ are followed; i.e., |ASCII_code| numbers representing the next line
+of the file are input into |buffer[0]|, |buffer[1]|, \dots,
+|buffer[limit-1]|; trailing blanks are ignored;
+and the global variable |limit| is set to the length of the
+@^system dependencies@>
+line. The value of |limit| must be strictly less than |buf_size|.
+
+We assume that none of the |ASCII_code| values
+of |buffer[j]| for |0<=j<limit| is equal to 0, @'177, |line_feed|, |form_feed|,
+or |carriage_return|.
+
+@p function input_ln(var f:text_file):boolean;
+ {inputs a line or returns |false|}
+var final_limit:0..buf_size; {|limit| without trailing blanks}
+begin limit:=0; final_limit:=0;
+if eof(f) then input_ln:=false
+else begin while not eoln(f) do
+ begin buffer[limit]:=xord[f^]; get(f);
+ incr(limit);
+ if buffer[limit-1]<>" " then final_limit:=limit;
+ if limit=buf_size then
+ begin while not eoln(f) do get(f);
+ decr(limit); {keep |buffer[buf_size]| empty}
+ if final_limit>limit then final_limit:=limit;
+ print_nl('! Input line too long'); loc:=0; error;
+@.Input line too long@>
+ end;
+ end;
+ read_ln(f); limit:=final_limit; input_ln:=true;
+ end;
+end;
+
+@* Reporting errors to the user.
+The \.{TANGLE} processor operates in two phases: first it inputs the source
+file and stores a compressed representation of the program, then it produces
+the \PASCAL\ output from the compressed representation.
+
+The global variable |phase_one| tells whether we are in Phase I or not.
+
+@<Globals...@>=
+@!phase_one: boolean; {|true| in Phase I, |false| in Phase II}
+
+@ If an error is detected while we are debugging,
+we usually want to look at the contents of memory.
+A special procedure will be declared later for this purpose.
+
+@<Error handling...@>=
+@!debug @+ procedure debug_help; forward;@+ gubed
+
+@ During the first phase, syntax errors are reported to the user by saying
+$$\hbox{`|err_print('! Error message')|'},$$
+followed by `|jump_out|' if no recovery from the error is provided.
+This will print the error message followed by an indication of where the error
+was spotted in the source file. Note that no period follows the error message,
+since the error routine will automatically supply a period.
+
+Errors that are noticed during the second phase are reported to the user
+in the same fashion, but the error message will be
+followed by an indication of where the error was spotted in the output file.
+
+The actual error indications are provided by a procedure called |error|.
+
+@d err_print(#)==begin new_line; print(#); error;
+ end
+
+@<Error handling...@>=
+procedure error; {prints '\..' and location of error message}
+var j: 0..out_buf_size; {index into |out_buf|}
+@!k,@!l: 0..buf_size; {indices into |buffer|}
+begin if phase_one then @<Print error location based on input buffer@>
+else @<Print error location based on output buffer@>;
+update_terminal; mark_error;
+@!debug debug_skipped:=debug_cycle; debug_help;@+gubed
+end;
+
+@ The error locations during Phase I can be indicated by using the global
+variables |loc|, |line|, and |changing|, which tell respectively the first
+unlooked-at position in |buffer|, the current line number, and whether or not
+the current line is from |change_file| or |web_file|.
+This routine should be modified on systems whose standard text editor
+has special line-numbering conventions.
+@^system dependencies@>
+
+@<Print error location based on input buffer@>=
+begin if changing then print('. (change file ')@+else print('. (');
+print_ln('l.', line:1, ')');
+if loc>=limit then l:=limit else l:=loc;
+for k:=1 to l do
+ if buffer[k-1]=tab_mark then print(' ')
+ else print(xchr[buffer[k-1]]); {print the characters already read}
+new_line;
+for k:=1 to l do print(' '); {space out the next line}
+for k:=l+1 to limit do print(xchr[buffer[k-1]]); {print the part not yet read}
+print(' '); {this space separates the message from future asterisks}
+end
+
+@ The position of errors detected during the second phase can be indicated
+by outputting the partially-filled output buffer, which contains |out_ptr|
+entries.
+
+@<Print error location based on output...@>=
+begin print_ln('. (l.',line:1,')');
+for j:=1 to out_ptr do print(xchr[out_buf[j-1]]); {print current partial line}
+print('... '); {indicate that this information is partial}
+end
+
+@ The |jump_out| procedure just cuts across all active procedure levels
+and jumps out of the program. This is the only non-local |goto| statement
+in \.{TANGLE}. It is used when no recovery from a particular error has
+been provided.
+
+Some \PASCAL\ compilers do not implement non-local |goto| statements.
+@^system dependencies@>
+In such cases the code that appears at label |end_of_TANGLE| should be
+copied into the |jump_out| procedure, followed by a call to a system procedure
+that terminates the program.
+
+@d fatal_error(#)==begin new_line; print(#); error; mark_fatal; jump_out;
+ end
+
+@<Error handling...@>=
+procedure jump_out;
+begin goto end_of_TANGLE;
+end;
+
+@ Sometimes the program's behavior is far different from what it should be,
+and \.{TANGLE} prints an error message that is really for the \.{TANGLE}
+maintenance person, not the user. In such cases the program says
+|confusion('indication of where we are')|.
+
+@d confusion(#)==fatal_error('! This can''t happen (',#,')')
+@.This can't happen@>
+
+@ An overflow stop occurs if \.{TANGLE}'s tables aren't large enough.
+
+@d overflow(#)==fatal_error('! Sorry, ',#,' capacity exceeded')
+@.Sorry, x capacity exceeded@>
+
+
+@* Data structures.
+Most of the user's \PASCAL\ code is packed into eight-bit integers
+in two large arrays called |byte_mem| and |tok_mem|.
+The |byte_mem| array holds the names of identifiers, strings, and modules;
+the |tok_mem| array holds the replacement texts
+for macros and modules. Allocation is sequential, since things are deleted only
+during Phase II, and only in a last-in-first-out manner.
+
+Auxiliary arrays |byte_start| and |tok_start| are used as directories to
+|byte_mem| and |tok_mem|, and the |link|, |ilk|, |equiv|, and |text_link|
+arrays give further information about names. These auxiliary arrays
+consist of sixteen-bit items.
+
+@<Types...@>=
+@!eight_bits=0..255; {unsigned one-byte quantity}
+@!sixteen_bits=integer; {not quite a two-byte quantity}
+
+@ \.{TANGLE} has been designed to avoid the need for indices that are more
+than sixteen bits wide, so that it can be used on most computers. But
+there are programs that need more than 65536 tokens, and some programs
+even need more than 65536 bytes; \TeX\ is one of these. To get around
+this problem, a slight complication has been added to the data structures:
+|byte_mem| and |tok_mem| are two-dimensional arrays, whose first index is
+either 0 or 1. (For generality, the first index is actually allowed to run
+between 0 and |ww-1| in |byte_mem|, or between 0 and |zz-1| in |tok_mem|,
+where |ww| and |zz| are set to 2 and~3; the program will work for any
+positive values of |ww| and |zz|, and it can be simplified in obvious ways
+if |ww=1| or |zz=1|.)
+
+@d ww=2 {we multiply the byte capacity by approximately this amount}
+@d zz=3 {we multiply the token capacity by approximately this amount}
+
+@<Globals...@>=
+@!byte_mem: packed array [0..ww-1,0..max_bytes] of ASCII_code;
+ {characters of names}
+@!tok_mem: packed array [0..zz-1,0..max_toks] of eight_bits; {tokens}
+@!byte_start: array [0..max_names] of sixteen_bits; {directory into |byte_mem|}
+@!tok_start: array [0..max_texts] of sixteen_bits; {directory into |tok_mem|}
+@!link: array [0..max_names] of sixteen_bits; {hash table or tree links}
+@!ilk: array [0..max_names] of sixteen_bits; {type codes or tree links}
+@!equiv: array [0..max_names] of sixteen_bits; {info corresponding to names}
+@!text_link: array [0..max_texts] of sixteen_bits; {relates replacement texts}
+
+@ The names of identifiers are found by computing a hash address |h| and
+then looking at strings of bytes signified by |hash[h]|, |link[hash[h]]|,
+|link[link[hash[h]]]|, \dots, until either finding the desired name
+or encountering a zero.
+
+A `|name_pointer|' variable, which signifies a name, is an index into
+|byte_start|. The actual sequence of characters in the name pointed to by
+|p| appears in positions |byte_start[p]| to |byte_start[p+ww]-1|, inclusive,
+in the segment of |byte_mem| whose first index is |p mod ww|. Thus, when
+|ww=2| the even-numbered name bytes appear in |byte_mem[0,@t$*$@>]|
+and the odd-numbered ones appear in |byte_mem[1,@t$*$@>]|.
+The pointer 0 is used for undefined module names; we don't
+want to use it for the names of identifiers, since 0 stands for a null
+pointer in a linked list.
+
+Strings are treated like identifiers; the first character (a double-quote)
+distinguishes a string from an alphabetic name, but for \.{TANGLE}'s purposes
+strings behave like numeric macros. (A `string' here refers to the
+strings delimited by double-quotes that \.{TANGLE} processes. \PASCAL\
+string constants delimited by single-quote marks are not given such special
+treatment; they simply appear as sequences of characters in the \PASCAL\
+texts.) The total number of strings in the string
+pool is called |string_ptr|, and the total number of names in |byte_mem|
+is called |name_ptr|. The total number of bytes occupied in
+|byte_mem[w,@t$*$@>]| is called |byte_ptr[w]|.
+
+We usually have |byte_start[name_ptr+w]=byte_ptr[(name_ptr+w) mod ww]|
+for |0<=w<ww|, since these are the starting positions for the next |ww|
+names to be stored in |byte_mem|.
+
+@d length(#)==byte_start[#+ww]-byte_start[#] {the length of a name}
+
+@<Types...@>=
+@!name_pointer=0..max_names; {identifies a name}
+
+@ @<Global...@>=
+@!name_ptr:name_pointer; {first unused position in |byte_start|}
+@!string_ptr:name_pointer; {next number to be given to a string of length |<>1|}
+@!byte_ptr:array [0..ww-1] of 0..max_bytes;
+ {first unused position in |byte_mem|}
+@!pool_check_sum:integer; {sort of a hash for the whole string pool}
+
+@ @<Local variables for init...@>=
+@!wi: 0..ww-1; {to initialize the |byte_mem| indices}
+
+@ @<Set init...@>=
+for wi:=0 to ww-1 do
+ begin byte_start[wi]:=0; byte_ptr[wi]:=0;
+ end;
+byte_start[ww]:=0; {this makes name 0 of length zero}
+name_ptr:=1; string_ptr:=number_chars; pool_check_sum:=271828;
+
+@ Replacement texts are stored in |tok_mem|, using similar conventions.
+A `|text_pointer|' variable is an index into |tok_start|, and the
+replacement text that corresponds to |p| runs from positions
+|tok_start[p]| to |tok_start[p+zz]-1|, inclusive, in the segment of
+|tok_mem| whose first index is |p mod zz|. Thus, when |zz=2| the
+even-numbered replacement texts appear in |tok_mem[0,@t$*$@>]| and the
+odd-numbered ones appear in |tok_mem[1,@t$*$@>]|. Furthermore,
+|text_link[p]| is used to connect pieces of text that have the same name,
+as we shall see later. The pointer 0 is used for undefined replacement
+texts.
+
+The first position of |tok_mem[z,@t$*$@>]| that is unoccupied by
+replacement text is called |tok_ptr[z]|, and the first unused location of
+|tok_start| is called |text_ptr|. We usually have the identity
+|tok_start[text_ptr+z]=tok_ptr[(text_ptr+z) mod zz]|, for |0<=z<zz|, since
+these are the starting positions for the next |zz| replacement texts to
+be stored in |tok_mem|.
+
+@<Types...@>=
+@!text_pointer=0..max_texts; {identifies a replacement text}
+
+@ It is convenient to maintain a variable |z| that is equal to |text_ptr
+mod zz|, so that we always insert tokens into segment |z| of |tok_mem|.
+
+@<Glob...@>=
+@t\hskip1em@>@!text_ptr:text_pointer; {first unused position in |tok_start|}
+@t\hskip1em@>@!tok_ptr:array[0..zz-1] of 0..max_toks;
+ {first unused position in a given segment of |tok_mem|}
+@t\hskip1em@>@!z:0..zz-1; {current segment of |tok_mem|}
+stat @!max_tok_ptr:array[0..zz-1] of 0..max_toks;
+ {largest values assumed by |tok_ptr|}
+tats
+
+@ @<Local variables for init...@>=
+@!zi:0..zz-1; {to initialize the |tok_mem| indices}
+
+@ @<Set init...@>=
+for zi:=0 to zz-1 do
+ begin tok_start[zi]:=0; tok_ptr[zi]:=0;
+ end;
+tok_start[zz]:=0; {this makes replacement text 0 of length zero}
+text_ptr:=1; z:=1 mod zz;
+
+@ Four types of identifiers are distinguished by their |ilk|:
+
+\yskip\hang |normal| identifiers will appear in the \PASCAL\ program as
+ordinary identifiers since they have not been defined to be macros; the
+corresponding value in the |equiv| array
+for such identifiers is a link in a secondary hash table that
+is used to check whether any two of them agree in their first |unambig_length|
+characters after underline symbols are removed and lowercase letters are
+changed to uppercase.
+
+\yskip\hang |numeric| identifiers have been defined to be numeric macros;
+their |equiv| value contains the corresponding numeric value plus $2^{15}$.
+Strings are treated as numeric macros.
+
+\yskip\hang |simple| identifiers have been defined to be simple macros;
+their |equiv| value points to the corresponding replacement text.
+
+\yskip\hang |parametric| identifiers have been defined to be parametric macros;
+like simple identifiers, their |equiv| value points to the replacement text.
+
+@d normal=0 {ordinary identifiers have |normal| ilk}
+@d numeric=1 {numeric macros and strings have |numeric| ilk}
+@d simple=2 {simple macros have |simple| ilk}
+@d parametric=3 {parametric macros have |parametric| ilk}
+
+@ The names of modules are stored in |byte_mem| together
+with the identifier names, but a hash table is not used for them because
+\.{TANGLE} needs to be able to recognize a module name when given a prefix of
+that name. A conventional binary seach tree is used to retrieve module names,
+with fields called |llink| and |rlink| in place of |link| and |ilk|. The
+root of this tree is |rlink[0]|. If |p| is a pointer to a module name,
+|equiv[p]| points to its replacement text, just as in simple and parametric
+macros, unless this replacement text has not yet been defined (in which case
+|equiv[p]=0|).
+
+@d llink==link {left link in binary search tree for module names}
+@d rlink==ilk {right link in binary search tree for module names}
+
+@<Set init...@>=
+rlink[0]:=0; {the binary search tree starts out with nothing in it}
+equiv[0]:=0; {the undefined module has no replacement text}
+
+@ Here is a little procedure that prints the text of a given name.
+
+@p procedure print_id(@!p:name_pointer); {print identifier or module name}
+var k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+begin if p>=name_ptr then print('IMPOSSIBLE')
+else begin w:=p mod ww;
+ for k:=byte_start[p] to byte_start[p+ww]-1 do print(xchr[byte_mem[w,k]]);
+ end;
+end;
+
+@* Searching for identifiers.
+The hash table described above is updated by the |id_lookup| procedure,
+which finds a given identifier and returns a pointer to its index in
+|byte_start|. If the identifier was not already present, it is inserted with
+a given |ilk| code; and an error message is printed if the identifier is being
+doubly defined.
+
+Because of the way \.{TANGLE}'s scanning mechanism works, it is most convenient
+to let |id_lookup| search for an identifier that is present in the |buffer|
+array. Two other global variables specify its position in the buffer: the
+first character is |buffer[id_first]|, and the last is |buffer[id_loc-1]|.
+Furthermore, if the identifier is really a string, the global variable
+|double_chars| tells how many of the characters in the buffer appear
+twice (namely \.{@@@@} and \.{""}), since this additional information makes
+it easy to calculate the true length of the string. The final double-quote
+of the string is not included in its ``identifier,'' but the first one is,
+so the string length is |id_loc-id_first-double_chars-1|.
+
+We have mentioned that |normal| identifiers belong to two hash tables,
+one for their true names as they appear in the \.{WEB} file and the other
+when they have been reduced to their first |unambig_length| characters.
+The hash tables are kept by the method of simple chaining, where the
+heads of the individual lists appear in the |hash| and |chop_hash| arrays.
+If |h| is a hash code, the primary hash table list starts at |hash[h]| and
+proceeds through |link| pointers; the secondary hash table list starts at
+|chop_hash[h]| and proceeds through |equiv| pointers. Of course, the same
+identifier will probably have two different values of |h|.
+
+The |id_lookup| procedure uses an auxiliary array called |chopped_id| to
+contain up to |unambig_length| characters of the current identifier, if
+it is necessary to compute the secondary hash code. (This array could be
+declared local to |id_lookup|, but in general we are making all array
+declarations global in this program, because some compilers and some machine
+architectures make dynamic array allocation inefficient.)
+
+@<Glob...@>=
+@!id_first:0..buf_size; {where the current identifier begins in the buffer}
+@!id_loc:0..buf_size; {just after the current identifier in the buffer}
+@!double_chars:0..buf_size; {correction to length in case of strings}
+@#
+@!hash,@!chop_hash:array [0..hash_size] of sixteen_bits; {heads of hash lists}
+@!chopped_id:array [0..unambig_length] of ASCII_code; {chopped identifier}
+
+@ Initially all the hash lists are empty.
+
+@<Local variables for init...@>=
+@!h:0..hash_size; {index into hash-head arrays}
+
+@ @<Set init...@>=
+for h:=0 to hash_size-1 do
+ begin hash[h]:=0; chop_hash[h]:=0;
+ end;
+
+@ Here now is the main procedure for finding identifiers (and strings).
+The parameter |t| is set to |normal| except when the identifier is
+a macro name that is just being defined; in the latter case, |t| will be
+|numeric|, |simple|, or |parametric|.
+
+@p function id_lookup(@!t:eight_bits):name_pointer; {finds current identifier}
+label found, not_found;
+var c:eight_bits; {byte being chopped}
+@!i:0..buf_size; {index into |buffer|}
+@!h:0..hash_size; {hash code}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+@!l:0..buf_size; {length of the given identifier}
+@!p,@!q:name_pointer; {where the identifier is being sought}
+@!s:0..unambig_length; {index into |chopped_id|}
+begin l:=id_loc-id_first; {compute the length}
+@<Compute the hash code |h|@>;
+@<Compute the name location |p|@>;
+if (p=name_ptr)or(t<>normal) then
+ @<Update the tables and check for possible errors@>;
+id_lookup:=p;
+end;
+
+@ A simple hash code is used: If the sequence of
+ASCII codes is $c_1c_2\ldots c_m$, its hash value will be
+$$(2^{n-1}c_1+2^{n-2}c_2+\cdots+c_n)\,\bmod\,|hash_size|.$$
+
+@<Compute the hash...@>=
+h:=buffer[id_first]; i:=id_first+1;
+while i<id_loc do
+ begin h:=(h+h+buffer[i]) mod hash_size; incr(i);
+ end
+
+@ If the identifier is new, it will be placed in position |p=name_ptr|,
+otherwise |p| will point to its existing location.
+
+@<Compute the name location...@>=
+p:=hash[h];
+while p<>0 do
+ begin if length(p)=l then
+ @<Compare name |p| with current identifier, |goto found| if equal@>;
+ p:=link[p];
+ end;
+p:=name_ptr; {the current identifier is new}
+link[p]:=hash[h]; hash[h]:=p; {insert |p| at beginning of hash list}
+found:
+
+@ @<Compare name |p|...@>=
+begin i:=id_first; k:=byte_start[p]; w:=p mod ww;
+while (i<id_loc)and(buffer[i]=byte_mem[w,k]) do
+ begin incr(i); incr(k);
+ end;
+if i=id_loc then goto found; {all characters agree}
+end
+
+@ @<Update the tables...@>=
+begin if ((p<>name_ptr)and(t<>normal)and(ilk[p]=normal)) or
+ ((p=name_ptr)and(t=normal)and(buffer[id_first]<>"""")) then
+ @<Compute the secondary hash code |h| and put the first characters
+ into the auxiliary array |chopped_id|@>;
+if p<>name_ptr then
+ @<Give double-definition error, if necessary, and change |p| to type |t|@>
+else @<Enter a new identifier into the table at position |p|@>;
+end
+
+@ The following routine, which is called into play when it is necessary to
+look at the secondary hash table, computes the same hash function as before
+(but on the chopped data), and places a zero after the chopped identifier
+in |chopped_id| to serve as a convenient sentinel.
+
+@<Compute the secondary...@>=
+begin i:=id_first; s:=0; h:=0;
+while (i<id_loc)and(s<unambig_length) do
+ begin if buffer[i]<>"_" then
+ begin if buffer[i]>="a" then chopped_id[s]:=buffer[i]-@'40
+ else chopped_id[s]:=buffer[i];
+ h:=(h+h+chopped_id[s]) mod hash_size; incr(s);
+ end;
+ incr(i);
+ end;
+chopped_id[s]:=0;
+end
+
+@ If a nonnumeric macro has appeared before it was defined, \.{TANGLE}
+will still work all right; after all, such behavior is typical of the
+replacement texts for modules, which act very much like macros.
+However, an undefined numeric macro may not be used on the right-hand
+side of another numeric macro definition, so \.{TANGLE} finds it
+simplest to make a blanket rule that numeric macros should be defined
+before they are used. The following routine gives an error message and
+also fixes up any damage that may have been caused.
+
+@<Give double...@>= {now |p<>name_ptr| and |t<>normal|}
+begin if ilk[p]=normal then
+ begin if t=numeric then err_print('! This identifier has already appeared');
+@.This identifier has already...@>
+ @<Remove |p| from secondary hash table@>;
+ end
+else err_print('! This identifier was defined before');
+@.This identifier was defined...@>
+ilk[p]:=t;
+end
+
+@ When we have to remove a secondary hash entry, because a |normal| identifier
+is changing to another |ilk|, the hash code |h| and chopped identifier have
+already been computed.
+
+@<Remove |p| from secondary...@>=
+q:=chop_hash[h];
+if q=p then chop_hash[h]:=equiv[p]
+else begin while equiv[q]<>p do q:=equiv[q];
+ equiv[q]:=equiv[p];
+ end
+
+@ The following routine could make good use of a generalized |pack| procedure
+that puts items into just part of a packed array instead of the whole thing.
+
+@<Enter a new identifier...@>=
+begin if (t=normal)and(buffer[id_first]<>"""") then
+ @<Check for ambiguity and update secondary hash@>;
+w:=name_ptr mod ww; k:=byte_ptr[w];
+if k+l>max_bytes then overflow('byte memory');
+if name_ptr>max_names-ww then overflow('name');
+i:=id_first; {get ready to move the identifier into |byte_mem|}
+while i<id_loc do
+ begin byte_mem[w,k]:=buffer[i]; incr(k); incr(i);
+ end;
+byte_ptr[w]:=k; byte_start[name_ptr+ww]:=k; incr(name_ptr);
+if buffer[id_first]<>"""" then ilk[p]:=t
+else @<Define and output a new string of the pool@>;
+end
+
+@ @<Check for ambig...@>=
+begin q:=chop_hash[h];
+while q<>0 do
+ begin @<Check if |q| conflicts with |p|@>;
+ q:=equiv[q];
+ end;
+equiv[p]:=chop_hash[h]; chop_hash[h]:=p; {put |p| at front of secondary list}
+end
+
+@ @<Check if |q| conflicts...@>=
+begin k:=byte_start[q]; s:=0; w:=q mod ww;
+while (k<byte_start[q+ww]) and (s<unambig_length) do
+ begin c:=byte_mem[w,k];
+ if c<>"_" then
+ begin if c>="a" then c:=c-@'40; {merge lowercase with uppercase}
+ if chopped_id[s]<>c then goto not_found;
+ incr(s);
+ end;
+ incr(k);
+ end;
+if (k=byte_start[q+ww])and(chopped_id[s]<>0) then goto not_found;
+print_nl('! Identifier conflict with ');
+@.Identifier conflict...@>
+for k:=byte_start[q] to byte_start[q+ww]-1 do print(xchr[byte_mem[w,k]]);
+error; q:=0; {only one conflict will be printed, since |equiv[0]=0|}
+not_found:
+end
+
+@ We compute the string pool check sum by working modulo a prime number
+that is large but not so large that overflow might occur.
+
+@d check_sum_prime==@'3777777667 {$2^{29}-73$}
+@^preprocessed strings@>
+
+@<Define and output a new string...@>=
+begin ilk[p]:=numeric; {strings are like numeric macros}
+if l-double_chars=2 then {this string is for a single character}
+ equiv[p]:=buffer[id_first+1]+1073741824
+else begin equiv[p]:=string_ptr+1073741824;
+ l:=l-double_chars-1;
+ if l>99 then err_print('! Preprocessed string is too long');
+@.Preprocessed string is too long@>
+ incr(string_ptr);
+ write(pool,xchr["0"+l div 10],xchr["0"+l mod 10]); {output the length}
+ pool_check_sum:=pool_check_sum+pool_check_sum+l;
+ while pool_check_sum>check_sum_prime do
+ pool_check_sum:=pool_check_sum-check_sum_prime;
+ i:=id_first+1;
+ while i<id_loc do
+ begin write(pool,xchr[buffer[i]]); {output characters of string}
+ pool_check_sum:=pool_check_sum+pool_check_sum+buffer[i];
+ while pool_check_sum>check_sum_prime do
+ pool_check_sum:=pool_check_sum-check_sum_prime;
+ if (buffer[i]="""") or (buffer[i]="@@") then
+ i:=i+2 {omit second appearance of doubled character}
+ else incr(i);
+ end;
+ write_ln(pool);
+ end;
+end
+
+@* Searching for module names.
+The |mod_lookup| procedure finds the module name |mod_text[1..l]| in the
+search tree, after inserting it if necessary, and returns a pointer to
+where it was found.
+
+@<Glob...@>=
+@!mod_text:array [0..longest_name] of ASCII_code; {name being sought for}
+
+@ According to the rules of \.{WEB}, no module name
+should be a proper prefix of another, so a ``clean'' comparison should
+occur between any two names. The result of |mod_lookup| is 0 if this
+prefix condition is violated. An error message is printed when such violations
+are detected during phase two of \.{WEAVE}.
+
+@d less=0 {the first name is lexicographically less than the second}
+@d equal=1 {the first name is equal to the second}
+@d greater=2 {the first name is lexicographically greater than the second}
+@d prefix=3 {the first name is a proper prefix of the second}
+@d extension=4 {the first name is a proper extension of the second}
+
+@p function mod_lookup(@!l:sixteen_bits):name_pointer; {finds module name}
+label found;
+var c:less..extension; {comparison between two names}
+@!j:0..longest_name; {index into |mod_text|}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+@!p:name_pointer; {current node of the search tree}
+@!q:name_pointer; {father of node |p|}
+begin c:=greater; q:=0; p:=rlink[0]; {|rlink[0]| is the root of the tree}
+while p<>0 do
+ begin @<Set \(|c| to the result of comparing the given name to
+ name |p|@>;
+ q:=p;
+ if c=less then p:=llink[q]
+ else if c=greater then p:=rlink[q]
+ else goto found;
+ end;
+@<Enter a new module name into the tree@>;
+found: if c<>equal then
+ begin err_print('! Incompatible section names'); p:=0;
+@.Incompatible module names@>
+ end;
+mod_lookup:=p;
+end;
+
+@ @<Enter a new module name...@>=
+w:=name_ptr mod ww; k:=byte_ptr[w];
+if k+l>max_bytes then overflow('byte memory');
+if name_ptr>max_names-ww then overflow('name');
+p:=name_ptr;
+if c=less then llink[q]:=p else rlink[q]:=p;
+llink[p]:=0; rlink[p]:=0; c:=equal; equiv[p]:=0;
+for j:=1 to l do byte_mem[w,k+j-1]:=mod_text[j];
+byte_ptr[w]:=k+l; byte_start[name_ptr+ww]:=k+l; incr(name_ptr);
+
+@ @<Set \(|c|...@>=
+begin k:=byte_start[p]; w:=p mod ww; c:=equal; j:=1;
+while (k<byte_start[p+ww]) and (j<=l) and (mod_text[j]=byte_mem[w,k]) do
+ begin incr(k); incr(j);
+ end;
+if k=byte_start[p+ww] then
+ if j>l then c:=equal
+ else c:=extension
+else if j>l then c:=prefix
+else if mod_text[j]<byte_mem[w,k] then c:=less
+else c:=greater;
+end
+
+@ The |prefix_lookup| procedure is supposed to find exactly one module
+name that has |mod_text[1..l]| as a prefix. Actually the algorithm silently
+accepts also the situation that some module name is a prefix of
+|mod_text[1..l]|, because the user who painstakingly typed in more than
+necessary probably doesn't want to be told about the wasted effort.
+
+@p function prefix_lookup(@!l:sixteen_bits):name_pointer; {finds name extension}
+var c:less..extension; {comparison between two names}
+@!count:0..max_names; {the number of hits}
+@!j:0..longest_name; {index into |mod_text|}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+@!p:name_pointer; {current node of the search tree}
+@!q:name_pointer; {another place to resume the search after one branch is done}
+@!r:name_pointer; {extension found}
+begin q:=0; p:=rlink[0]; count:=0; r:=0; {begin search at root of tree}
+while p<>0 do
+ begin @<Set \(|c|...@>;
+ if c=less then p:=llink[p]
+ else if c=greater then p:=rlink[p]
+ else begin r:=p; incr(count); q:=rlink[p]; p:=llink[p];
+ end;
+ if p=0 then
+ begin p:=q; q:=0;
+ end;
+ end;
+if count<>1 then
+ if count=0 then err_print('! Name does not match')
+@.Name does not match@>
+ else err_print('! Ambiguous prefix');
+@.Ambiguous prefix@>
+prefix_lookup:=r; {the result will be 0 if there was no match}
+end;
+
+@* Tokens.
+Replacement texts, which represent \PASCAL\ code in a compressed format,
+appear in |tok_mem| as mentioned above. The codes in
+these texts are called `tokens'; some tokens occupy two consecutive
+eight-bit byte positions, and the others take just one byte.
+
+If $p>0$ points to a replacement text, |tok_start[p]| is the |tok_mem| position
+of the first eight-bit code of that text. If |text_link[p]=0|,
+this is the replacement text for a macro, otherwise it is the replacement
+text for a module. In the latter case |text_link[p]| is either equal to
+|module_flag|, which means that there is no further text for this module, or
+|text_link[p]| points to a
+continuation of this replacement text; such links are created when
+several modules have \PASCAL\ texts with the same name, and they also
+tie together all the \PASCAL\ texts of unnamed modules.
+The replacement text pointer for the first unnamed module
+appears in |text_link[0]|, and the most recent such pointer is |last_unnamed|.
+
+@d module_flag==max_texts {final |text_link| in module replacement texts}
+
+@<Glob...@>=
+@!last_unnamed:text_pointer; {most recent replacement text of unnamed module}
+
+@ @<Set init...@>= last_unnamed:=0; text_link[0]:=0;
+
+@ If the first byte of a token is less than @'200, the token occupies a
+single byte. Otherwise we make a sixteen-bit token by combining two consecutive
+bytes |a| and |b|. If |@'200<=a<@'250|, then $(a-@'200)\times2^8+b$ points
+to an identifier; if |@'250<=a<@'320|, then
+$(a-@'250)\times2^8+b$ points to a module name; otherwise, i.e., if
+|@'320<=a<@'400|, then $(a-@'320)\times2^8+b$ is the number of the module
+in which the current replacement text appears.
+
+Codes less than @'200 are 7-bit ASCII codes that represent themselves.
+In particular, a single-character identifier like `|x|' will be a one-byte
+token, while all longer identifiers will occupy two bytes.
+
+Some of the 7-bit ASCII codes will not be present, however, so we can
+use them for special purposes. The following symbolic names are used:
+
+\yskip\hang |param| denotes insertion of a parameter. This occurs only in
+the replacement texts of parametric macros, outside of single-quoted strings
+in those texts.
+
+\hang |begin_comment| denotes \.{@@\{}, which will become either
+\.{\{} or \.{[}.
+
+\hang |end_comment| denotes \.{@@\}}, which will become either
+\.{\}} or \.{]}.
+
+\hang |octal| denotes the \.{@@\'} that precedes an octal constant.
+
+\hang |hex| denotes the \.{@@"} that precedes a hexadecimal constant.
+
+\hang |check_sum| denotes the \.{@@\char'44} that denotes the string pool
+check sum.
+
+\hang |join| denotes the concatenation of adjacent items with no
+space or line breaks allowed between them (the \.{@@\&} operation of \.{WEB}).
+
+\hang |double_dot| denotes `\.{..}' in \PASCAL.
+
+\hang |verbatim| denotes the \.{@@=} that begins a verbatim \PASCAL\ string.
+It is also used for the end of the string.
+
+\hang |force_line| denotes the \.{@@\\} that forces a new line in the
+\PASCAL\ output.
+@^ASCII code@>
+
+@d param=0 {ASCII null code will not appear}
+@d verbatim=@'2 {extended ASCII alpha should not appear}
+@d force_line=@'3 {extended ASCII beta should not appear}
+@d begin_comment=@'11 {ASCII tab mark will not appear}
+@d end_comment=@'12 {ASCII line feed will not appear}
+@d octal=@'14 {ASCII form feed will not appear}
+@d hex=@'15 {ASCII carriage return will not appear}
+@d double_dot=@'40 {ASCII space will not appear except in strings}
+@d check_sum=@'175 {will not be confused with right brace}
+@d join=@'177 {ASCII delete will not appear}
+
+@ The following procedure is used to enter a two-byte value into
+|tok_mem| when a replacement text is being generated.
+
+@p procedure store_two_bytes(@!x:sixteen_bits);
+ {stores high byte, then low byte}
+begin if tok_ptr[z]+2>max_toks then overflow('token');
+tok_mem[z,tok_ptr[z]]:=x div@'400; {this could be done by a shift command}
+tok_mem[z,tok_ptr[z]+1]:=x mod@'400; {this could be done by a logical and}
+tok_ptr[z]:=tok_ptr[z]+2;
+end;
+
+@ When \.{TANGLE} is being operated in debug mode, it has a procedure to display
+a replacement text in symbolic form. This procedure has not been spruced up to
+generate a real great format, but at least the results are not as bad as
+a memory dump.
+
+@p @!debug procedure print_repl(@!p:text_pointer);
+var k:0..max_toks; {index into |tok_mem|}
+@!a: sixteen_bits; {current byte(s)}
+@!zp: 0..zz-1; {segment of |tok_mem| being accessed}
+begin if p>=text_ptr then print('BAD')
+else begin k:=tok_start[p]; zp:=p mod zz;
+ while k<tok_start[p+zz] do
+ begin a:=tok_mem[zp,k];
+ if a>=@'200 then @<Display two-byte token starting with |a|@>
+ else @<Display one-byte token |a|@>;
+ incr(k);
+ end;
+ end;
+end;
+gubed
+
+@ @<Display two-byte...@>=
+begin incr(k);
+if a<@'250 then {identifier or string}
+ begin a:=(a-@'200)*@'400+tok_mem[zp,k]; print_id(a);
+ if byte_mem[a mod ww,byte_start[a]]="""" then print('"')
+ else print(' ');
+ end
+else if a<@'320 then {module name}
+ begin print('@@<'); print_id((a-@'250)*@'400+tok_mem[zp,k]);
+ print('@@>');
+ end
+else begin a:=(a-@'320)*@'400+tok_mem[zp,k]; {module number}
+ print('@@',xchr["{"],a:1,'@@',xchr["}"]); {can't use right brace
+ between \&{debug} and \&{gubed}}
+ end;
+end
+
+@ @<Display one-byte...@>=
+case a of
+begin_comment: print('@@',xchr["{"]);
+end_comment: print('@@',xchr["}"]); {can't use right brace
+ between \&{debug} and \&{gubed}}
+octal: print('@@''');
+hex: print('@@"');
+check_sum: print('@@$');
+param: print('#');
+"@@": print('@@@@');
+verbatim: print('@@=');
+force_line: print('@@\');
+othercases print(xchr[a])
+endcases
+
+@* Stacks for output.
+Let's make sure that our data structures contain enough information to
+produce the entire \PASCAL\ program as desired, by working next on the
+algorithms that actually do produce that program.
+
+@ The output process uses a stack to keep track of what is going on at
+different ``levels'' as the macros are being expanded.
+Entries on this stack have five parts:
+
+\yskip\hang |end_field| is the |tok_mem| location where the replacement
+text of a particular level will end;
+
+\hang |byte_field| is the |tok_mem| location from which the next token
+on a particular level will be read;
+
+\hang |name_field| points to the name corresponding to a particular level;
+
+\hang |repl_field| points to the replacement text currently being read
+at a particular level;
+
+\hang |mod_field| is the module number, or zero if this is a macro.
+
+\yskip\noindent The current values of these five quantities are referred to
+quite frequently, so they are stored in a separate place instead of in
+the |stack| array. We call the current values |cur_end|, |cur_byte|,
+|cur_name|, |cur_repl|, and |cur_mod|.
+
+The global variable |stack_ptr| tells how many levels of output are
+currently in progress. The end of all output occurs when the stack is
+empty, i.e., when |stack_ptr=0|.
+
+@<Types...@>=
+@t\4@>@!output_state=record
+ @!end_field: sixteen_bits; {ending location of replacement text}
+ @!byte_field: sixteen_bits; {present location within replacement text}
+ @!name_field: name_pointer; {|byte_start| index for text being output}
+ @!repl_field: text_pointer; {|tok_start| index for text being output}
+ @!mod_field: 0..@'27777; {module number or zero if not a module}
+ end;
+
+@ @d cur_end==cur_state.end_field {current ending location in |tok_mem|}
+@d cur_byte==cur_state.byte_field {location of next output byte in |tok_mem|}
+@d cur_name==cur_state.name_field {pointer to current name being expanded}
+@d cur_repl==cur_state.repl_field {pointer to current replacement text}
+@d cur_mod==cur_state.mod_field {current module number being expanded}
+
+@<Globals...@>=
+@!cur_state : output_state; {|cur_end|, |cur_byte|, |cur_name|,
+ |cur_repl|, |cur_mod|}
+@!stack : array [1..stack_size] of output_state; {info for non-current levels}
+@!stack_ptr: 0..stack_size; {first unused location in the output state stack}
+
+@ It is convenient to keep a global variable |zo| equal to |cur_repl mod zz|.
+
+@<Glob...@>=
+@!zo:0..zz-1; {the segment of |tok_mem| from which output is coming}
+
+@ Parameters must also be stacked. They are placed in
+|tok_mem| just above the other replacement texts, and dummy parameter
+`names' are placed in |byte_start| just after the other names.
+The variables |text_ptr| and |tok_ptr[z]| essentially serve as parameter
+stack pointers during the output phase, so there is no need for a separate
+data structure to handle this problem.
+
+@ There is an implicit stack corresponding to meta-comments that are output
+via \.{@@\{} and \.{@@\}}. But this stack need not be represented in detail,
+because we only need to know whether it is empty or not. A global variable
+|brace_level| tells how many items would be on this stack if it were present.
+
+@<Globals...@>=
+@!brace_level: eight_bits; {current depth of $\.{@@\{}\ldots\.{@@\}}$ nesting}
+
+@ To get the output process started, we will perform the following
+initialization steps. We may assume that |text_link[0]| is nonzero, since it
+points to the \PASCAL\ text in the first unnamed module that generates
+code; if there are no such modules, there is nothing to output, and an
+error message will have been generated before we do any of the initialization.
+
+@<Initialize the output stacks@>=
+stack_ptr:=1; brace_level:=0; cur_name:=0; cur_repl:=text_link[0];
+zo:=cur_repl mod zz; cur_byte:=tok_start[cur_repl];
+cur_end:=tok_start[cur_repl+zz]; cur_mod:=0;
+
+@ When the replacement text for name |p| is to be inserted into the output,
+the following subroutine is called to save the old level of output and get
+the new one going.
+
+@p procedure push_level(@!p:name_pointer); {suspends the current level}
+begin if stack_ptr=stack_size then overflow('stack')
+else begin stack[stack_ptr]:=cur_state; {save |cur_end|, |cur_byte|, etc.}
+ incr(stack_ptr);
+ cur_name:=p; cur_repl:=equiv[p]; zo:=cur_repl mod zz;
+ cur_byte:=tok_start[cur_repl]; cur_end:=tok_start[cur_repl+zz];
+ cur_mod:=0;
+ end;
+end;
+
+@ When we come to the end of a replacement text, the |pop_level| subroutine
+does the right thing: It either moves to the continuation of this replacement
+text or returns the state to the most recently stacked level. Part of this
+subroutine, which updates the parameter stack, will be given later when we
+study the parameter stack in more detail.
+
+@p procedure pop_level; {do this when |cur_byte| reaches |cur_end|}
+label exit;
+begin if text_link[cur_repl]=0 then {end of macro expansion}
+ begin if ilk[cur_name]=parametric then
+ @<Remove a parameter from the parameter stack@>;
+ end
+else if text_link[cur_repl]<module_flag then {link to a continuation}
+ begin cur_repl:=text_link[cur_repl]; {we will stay on the same level}
+ zo:=cur_repl mod zz;
+ cur_byte:=tok_start[cur_repl]; cur_end:=tok_start[cur_repl+zz];
+ return;
+ end;
+decr(stack_ptr); {we will go down to the previous level}
+if stack_ptr>0 then
+ begin cur_state:=stack[stack_ptr]; zo:=cur_repl mod zz;
+ end;
+exit: end;
+
+@ The heart of the output procedure is the |get_output| routine, which produces
+the next token of output that is not a reference to a macro. This procedure
+handles all the stacking and unstacking that is necessary. It returns the
+value |number| if the next output has a numeric value (the value of a
+numeric macro or string), in which case |cur_val| has been set to the
+number in question. The procedure also returns the value |module_number|
+if the next output begins or ends the replacement text of some module,
+in which case |cur_val| is that module's number (if beginning) or the
+negative of that value (if ending). And it returns the value |identifier|
+if the next output is an identifier of length two or more, in which case
+|cur_val| points to that identifier name.
+
+@d number=@'200 {code returned by |get_output| when next output is numeric}
+@d module_number=@'201 {code returned by |get_output| for module numbers}
+@d identifier=@'202 {code returned by |get_output| for identifiers}
+
+@<Globals...@>=
+@!cur_val:integer; {additional information corresponding to output token}
+
+@ If |get_output| finds that no more output remains, it returns the value zero.
+
+@p function get_output:sixteen_bits; {returns next token after macro expansion}
+label restart, done, found;
+var a:sixteen_bits; {value of current byte}
+@!b:eight_bits; {byte being copied}
+@!bal:sixteen_bits; {excess of \.( versus \.) while copying a parameter}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+begin restart: if stack_ptr=0 then
+ begin a:=0; goto found;
+ end;
+if cur_byte=cur_end then
+ begin cur_val:=-cur_mod; pop_level;
+ if cur_val=0 then goto restart;
+ a:=module_number; goto found;
+ end;
+a:=tok_mem[zo,cur_byte]; incr(cur_byte);
+if a<@'200 then {one-byte token}
+ if a=param then
+ @<Start scanning current macro parameter, |goto restart|@>
+ else goto found;
+a:=(a-@'200)*@'400+tok_mem[zo,cur_byte]; incr(cur_byte);
+if a<@'24000 then {|@'24000=(@'250-@'200)*@'400|}
+ @<Expand macro |a| and |goto found|, or |goto restart| if no output found@>;
+if a<@'50000 then {|@'50000=(@'320-@'200)*@'400|}
+ @<Expand module |a-@'24000|, |goto restart|@>;
+cur_val:=a-@'50000; a:=module_number; cur_mod:=cur_val;
+found:
+@!debug if trouble_shooting then debug_help;@;@+gubed@/
+get_output:=a;
+end;
+
+@ The user may have forgotten to give any \PASCAL\ text for a module name,
+or the \PASCAL\ text may have been associated with a different name by mistake.
+
+@<Expand module |a-...@>=
+begin a:=a-@'24000;
+if equiv[a]<>0 then push_level(a)
+else if a<>0 then
+ begin print_nl('! Not present: <'); print_id(a); print('>'); error;
+@.Not present: <section name>@>
+ end;
+goto restart;
+end
+
+@ @<Expand macro ...@>=
+begin case ilk[a] of
+normal: begin cur_val:=a; a:=identifier;
+ end;
+numeric: begin cur_val:=equiv[a]-1073741824; a:=number;
+ end;
+simple: begin push_level(a); goto restart;
+ end;
+parametric: begin @<Put a parameter on the parameter stack,
+ or |goto restart| if error occurs@>;
+ push_level(a); goto restart;
+ end;
+othercases confusion('output')
+endcases;@/
+goto found;
+end
+
+@ We come now to the interesting part, the job of putting a parameter on
+the parameter stack. First we pop the stack if necessary until getting to
+a level that hasn't ended. Then the next character must be a `\.(';
+and since parentheses are balanced on each level, the entire parameter must
+be present, so we can copy it without difficulty.
+
+@<Put a parameter...@>=
+while (cur_byte=cur_end)and(stack_ptr>0) do pop_level;
+if (stack_ptr=0)or(tok_mem[zo,cur_byte]<>"(") then
+ begin print_nl('! No parameter given for '); print_id(a); error;
+@.No parameter given for macro@>
+ goto restart;
+ end;
+@<Copy the parameter into |tok_mem|@>;
+equiv[name_ptr]:=text_ptr; ilk[name_ptr]:=simple; w:=name_ptr mod ww;
+k:=byte_ptr[w];
+@!debug if k=max_bytes then overflow('byte memory');
+byte_mem[w,k]:="#"; incr(k); byte_ptr[w]:=k;
+gubed {this code has set the parameter identifier for debugging printouts}
+if name_ptr>max_names-ww then overflow('name');
+byte_start[name_ptr+ww]:=k; incr(name_ptr);
+if text_ptr>max_texts-zz then overflow('text');
+text_link[text_ptr]:=0; tok_start[text_ptr+zz]:=tok_ptr[z];
+incr(text_ptr);
+z:=text_ptr mod zz
+
+@ The |pop_level| routine undoes the effect of parameter-pushing when
+a parameter macro is finished:
+
+@<Remove a parameter...@>=
+begin decr(name_ptr); decr(text_ptr);
+z:=text_ptr mod zz;
+stat if tok_ptr[z]>max_tok_ptr[z] then max_tok_ptr[z]:=tok_ptr[z];
+tats {the maximum value of |tok_ptr| occurs just before parameter popping}
+tok_ptr[z]:=tok_start[text_ptr];
+@!debug decr(byte_ptr[name_ptr mod ww]);@+gubed
+end
+
+@ When a parameter occurs in a replacement text, we treat it as a simple
+macro in position (|name_ptr-1|):
+
+@<Start scanning...@>=
+begin push_level(name_ptr-1); goto restart;
+end
+
+@ Similarly, a |param| token encountered as we copy a parameter is converted
+into a simple macro call for |name_ptr-1|.
+Some care is needed to handle cases like \\{macro}|(#; print('#)'))|; the
+\.{\#} token will have been changed to |param| outside of strings, but we
+still must distinguish `real' parentheses from those in strings.
+
+@d app_repl(#)==begin if tok_ptr[z]=max_toks then overflow('token');
+ tok_mem[z,tok_ptr[z]]:=#; incr(tok_ptr[z]); end
+
+@<Copy the parameter...@>=
+bal:=1; incr(cur_byte); {skip the opening `\.('}
+loop@+ begin b:=tok_mem[zo,cur_byte]; incr(cur_byte);
+ if b=param then store_two_bytes(name_ptr+@'77777)
+ else begin if b>=@'200 then
+ begin app_repl(b);
+ b:=tok_mem[zo,cur_byte]; incr(cur_byte);
+ end
+ else case b of
+ "(": incr(bal);
+ ")": begin decr(bal);
+ if bal=0 then goto done;
+ end;
+ "'": repeat app_repl(b);
+ b:=tok_mem[zo,cur_byte]; incr(cur_byte);
+ until b="'"; {copy string, don't change |bal|}
+ othercases do_nothing
+ endcases;
+ app_repl(b);
+ end;
+ end;
+done:
+
+@* Producing the output.
+The |get_output| routine above handles most of the complexity of output
+generation, but there are two further considerations that have a nontrivial
+effect on \.{TANGLE}'s algorithms.
+
+First, we want to make sure that the output is broken into lines not
+exceeding |line_length| characters per line, where these breaks occur at
+valid places (e.g., not in the middle of a string or a constant or an
+identifier, not between `\.<' and `\.>', not at a `\.{@@\&}' position
+where quantities are being joined together). Therefore we assemble the
+output into a buffer before deciding where the line breaks will appear.
+However, we make very little attempt to make ``logical'' line breaks that
+would enhance the readability of the output; people are supposed to read
+the input of \.{TANGLE} or the \TeX ed output of \.{WEAVE}, but not the
+tangled-up output. The only concession to readability is that a break after
+a semicolon will be made if possible, since commonly used ``pretty
+printing'' routines give better results in such cases.
+
+Second, we want to decimalize non-decimal constants, and to combine integer
+quantities that are added or subtracted, because \PASCAL\ doesn't allow
+constant expressions in subrange types or in case labels. This means we
+want to have a procedure that treats a construction like \.{(E-15+17)}
+as equivalent to `\.{(E+2)}', while also leaving `\.{(1E-15+17)}' and
+`\.{(E-15+17*y)}' untouched. Consider also `\.{-15+17.5}' versus
+`\.{-15+17..5}'. We shall not combine integers preceding or following
+\.*, \./, \.{div}, \.{mod}, or \.{@@\&}. Note that if |y| has been defined
+to equal $-2$, we must expand `\.{x*y}' into `\.{x*(-2)}'; but `\.{x-y}'
+can expand into `\.{x+2}' and we can even change `\.{x - y mod z}' to
+@^mod@>
+`\.{x + 2 mod z}' because \PASCAL\ has a nonstandard \&{mod} operation!
+
+The following solution to these problems has been adopted: An array
+|out_buf| contains characters that have been generated but not yet output,
+and there are three pointers into this array. One of these, |out_ptr|, is
+the number of characters currently in the buffer, and we will have
+|1<=out_ptr<=line_length| most of the time. The second is |break_ptr|,
+which is the largest value |<=out_ptr| such that we are definitely entitled
+to end a line by outputting the characters |out_buf[1..(break_ptr-1)]|;
+we will always have |break_ptr<=line_length|. Finally, |semi_ptr| is either
+zero or the largest known value of a legal break after a semicolon or comment
+on the current line; we will always have |semi_ptr<=break_ptr|.
+
+@<Globals...@>=
+@!out_buf: array [0..out_buf_size] of ASCII_code; {assembled characters}
+@!out_ptr: 0..out_buf_size; {first available place in |out_buf|}
+@!break_ptr: 0..out_buf_size; {last breaking place in |out_buf|}
+@!semi_ptr: 0..out_buf_size; {last semicolon breaking place in |out_buf|}
+
+@ Besides having those three pointers,
+the output process is in one of several states:
+
+\yskip\hang |num_or_id| means that the last item in the buffer is a number or
+identifier, hence a blank space or line break must be inserted if the next
+item is also a number or identifier.
+
+\yskip\hang |unbreakable| means that the last item in the buffer was followed
+by the \.{@@\&} operation that inhibits spaces between it and the next item.
+
+\yskip\hang |sign| means that the last item in the buffer is to be followed
+by \.+ or \.-, depending on whether |out_app| is positive or negative.
+
+\yskip\hang |sign_val| means that the decimal equivalent of
+$\vert|out_val|\vert$ should be appended to the buffer. If |out_val<0|,
+or if |out_val=0| and |last_sign<0|, the number should be preceded by a minus
+sign. Otherwise it should be preceded by the character |out_sign| unless
+|out_sign=0|; the |out_sign| variable is either 0 or \.{"\ "} or \.{"+"}.
+
+\yskip\hang |sign_val_sign| is like |sign_val|, but also append \.+ or \.-
+afterwards, depending on whether |out_app| is positive or negative.
+
+\yskip\hang |sign_val_val| is like |sign_val|, but also append the decimal
+equivalent of |out_app| including its sign, using |last_sign| in case
+|out_app=0|.
+
+\yskip\hang |misc| means none of the above.
+
+\yskip\noindent
+For example, the output buffer and output state run through the following
+sequence as we generate characters from `\.{(x-15+19-2)}':
+$$\vbox{\halign{$\hfil#\hfil$\quad&#\hfil&\quad\hfil#\hfil&\quad
+\hfil#\hfil&\quad\hfil#\hfil&\quad\hfil#\hfil\quad&\hfil#\hfil\cr
+output&|out_buf|&|out_state|&|out_sign|&|out_val|&|out_app|&|last_sign|\cr
+\noalign{\vskip 3pt}
+(&\.(&|misc|\cr
+x&\.{(x}&|num_or_id|\cr
+-&\.{(x}&|sign|&&&$-1$&$-1$\cr
+15&\.{(x}&|sign_val|&\.{"+"}&$-15$&&$-15$\cr
++&\.{(x}&|sign_val_sign|&\.{"+"}&$-15$&$+1$&$+1$\cr
+19&\.{(x}&|sign_val_val|&\.{"+"}&$-15$&$+19$&$+1$\cr
+-&\.{(x}&|sign_val_sign|&\.{"+"}&$+4$&$-1$&$-1$\cr
+2&\.{(x}&|sign_val_val|&\.{"+"}&$+4$&$-2$&$-2$\cr
+)&\.{(x+2)}&|misc|\cr}}$$
+At each stage we have put as much into the buffer as possible without
+knowing what is coming next. Examples like `\.{x-0.1}' indicate why
+|last_sign| is needed to associate the proper sign with an output of zero.
+
+In states |num_or_id|, |unbreakable|, and |misc| the last item in the buffer
+lies between |break_ptr| and |out_ptr-1|, inclusive; in the other states we
+have |break_ptr=out_ptr|.
+
+The numeric values assigned to |num_or_id|, etc., have been chosen to
+shorten some of the program logic; for example, the program makes use of
+the fact that |sign+2=sign_val_sign|.
+
+@d misc=0 {state associated with special characters}
+@d num_or_id=1 {state associated with numbers and identifiers}
+@d sign=2 {state associated with pending \.+ or \.-}
+@d sign_val=num_or_id+2 {state associated with pending sign and value}
+@d sign_val_sign=sign+2 {|sign_val| followed by another pending sign}
+@d sign_val_val=sign_val+2 {|sign_val| followed by another pending value}
+@d unbreakable=sign_val_val+1 {state associated with \.{@@\&}}
+
+@<Globals...@>=
+@!out_state:eight_bits; {current status of partial output}
+@!out_val,@!out_app:integer; {pending values}
+@!out_sign:ASCII_code; {sign to use if appending |out_val>=0|}
+@!last_sign:-1..+1; {sign to use if appending a zero}
+
+@ During the output process, |line| will equal the number of the next line
+to be output.
+
+@<Initialize the output buffer@>=
+out_state:=misc; out_ptr:=0; break_ptr:=0; semi_ptr:=0; out_buf[0]:=0; line:=1;
+
+@ Here is a routine that is invoked when |out_ptr>line_length|
+or when it is time to flush out the final line. The |flush_buffer| procedure
+often writes out the line up to the current |break_ptr| position, then moves the
+remaining information to the front of |out_buf|. However, it prefers to
+write only up to |semi_ptr|, if the residual line won't be too long.
+
+@d check_break==if out_ptr>line_length then flush_buffer
+
+@p procedure flush_buffer; {writes one line to output file}
+var k:0..out_buf_size; {index into |out_buf|}
+@!b:0..out_buf_size; {value of |break_ptr| upon entry}
+begin b:=break_ptr;
+if (semi_ptr<>0)and(out_ptr-semi_ptr<=line_length) then break_ptr:=semi_ptr;
+for k:=1 to break_ptr do write(Pascal_file,xchr[out_buf[k-1]]);
+write_ln(Pascal_file); incr(line);
+if line mod 100 = 0 then
+ begin print('.');
+ if line mod 500 = 0 then print(line:1);
+ update_terminal; {progress report}
+ end;
+if break_ptr<out_ptr then
+ begin if out_buf[break_ptr]=" " then
+ begin incr(break_ptr); {drop space at break}
+ if break_ptr>b then b:=break_ptr;
+ end;
+ for k:=break_ptr to out_ptr-1 do out_buf[k-break_ptr]:=out_buf[k];
+ end;
+out_ptr:=out_ptr-break_ptr; break_ptr:=b-break_ptr; semi_ptr:=0;
+if out_ptr>line_length then
+ begin err_print('! Long line must be truncated'); out_ptr:=line_length;
+@.Long line must be truncated@>
+ end;
+end;
+
+@ @<Empty the last line from the buffer@>=
+break_ptr:=out_ptr; semi_ptr:=0; flush_buffer;
+if brace_level<>0 then
+ err_print('! Program ended at brace level ',brace_level:1);
+@.Program ended at brace level n@>
+
+@ Another simple and useful routine appends the decimal equivalent of
+a nonnegative integer to the output buffer.
+
+@d app(#)==begin out_buf[out_ptr]:=#; incr(out_ptr); {append a single character}
+ end
+
+@p procedure app_val(@!v:integer); {puts |v| into buffer, assumes |v>=0|}
+var k:0..out_buf_size; {index into |out_buf|}
+begin k:=out_buf_size; {first we put the digits at the very end of |out_buf|}
+repeat out_buf[k]:=v mod 10; v:=v div 10; decr(k);
+until v=0;
+repeat incr(k); app(out_buf[k]+"0");
+until k=out_buf_size; {then we append them, most significant first}
+end;
+
+@ The output states are kept up to date by the output routines, which are
+called |send_out|, |send_val|, and |send_sign|. The |send_out| procedure
+has two parameters: |t| tells the type of information being sent and
+|v| contains the information proper. Some information may also be passed
+in the array |out_contrib|.
+
+\yskip\hang If |t=misc| then |v| is a character to be output.
+
+\hang If |t=str| then |v| is the length of a string or something like `\.{<>}'
+in |out_contrib|.
+
+\hang If |t=ident| then |v| is the length of an identifier in |out_contrib|.
+
+\hang If |t=frac| then |v| is the length of a fraction and/or exponent in
+|out_contrib|.
+
+@d str=1 {|send_out| code for a string}
+@d ident=2 {|send_out| code for an identifier}
+@d frac=3 {|send_out| code for a fraction}
+
+@<Glob...@>=
+@!out_contrib:array[1..line_length] of ASCII_code; {a contribution to |out_buf|}
+
+@ A slightly subtle point in the following code is that the user may ask
+for a |join| operation (i.e., \.{@@\&}) following whatever is being sent
+out. We will see later that |join| is implemented in part by calling
+|send_out(frac,0)|.
+
+@p procedure send_out(@!t:eight_bits; @!v:sixteen_bits);
+ {outputs |v| of type |t|}
+label restart;
+var k: 0..line_length; {index into |out_contrib|}
+begin @<Get the buffer ready for appending the new information@>;
+if t<>misc then for k:=1 to v do app(out_contrib[k])
+else app(v);
+check_break;
+if (t=misc)and((v=";")or(v="}")) then
+ begin semi_ptr:=out_ptr; break_ptr:=out_ptr;
+ end;
+if t>=ident then out_state:=num_or_id {|t=ident| or |frac|}
+else out_state:=misc {|t=str| or |misc|}
+end;
+
+@ Here is where the buffer states for signs and values collapse into simpler
+states, because we are about to append something that doesn't combine with
+the previous integer constants.
+
+We use an ASCII-code trick: Since |","-1="+"| and |","+1="-"|, we have
+|","-c=@t sign of $c$@>|, when $\vert c\vert=1$.
+
+@<Get the buffer ready...@>=
+restart: case out_state of
+num_or_id: if t<>frac then
+ begin break_ptr:=out_ptr;
+ if t=ident then app(" ");
+ end;
+sign: begin app(","-out_app); check_break; break_ptr:=out_ptr;
+ end;
+sign_val,sign_val_sign: begin @<Append \(|out_val| to buffer@>;
+ out_state:=out_state-2; goto restart;
+ end;
+sign_val_val: @<Reduce |sign_val_val| to |sign_val| and |goto restart|@>;
+misc: if t<>frac then break_ptr:=out_ptr;@/
+othercases do_nothing {this is for |unbreakable| state}
+endcases
+
+@ @<Append \(|out_val|...@>=
+if (out_val<0)or((out_val=0)and(last_sign<0)) then app("-")
+else if out_sign>0 then app(out_sign);
+app_val(abs(out_val)); check_break;
+
+@ @<Reduce |sign_val_val|...@>=
+begin if (t=frac)or(@<Contribution is \.* or \./ or \.{DIV} or \.{MOD}@>) then
+ begin @<Append \(|out_val| to buffer@>;
+ out_sign:="+"; out_val:=out_app;
+ end
+else out_val:=out_val+out_app;
+out_state:=sign_val; goto restart;
+end
+
+@ @<Contribution is \.*...@>=
+((t=ident)and(v=3)and@|
+ (((out_contrib[1]="D")and(out_contrib[2]="I")and(out_contrib[3]="V")) or@|
+ ((out_contrib[1]="M")and(out_contrib[2]="O")and(out_contrib[3]="D")) ))or@|
+@^uppercase@>
+ ((t=misc)and((v="*")or(v="/")))
+
+@ The following routine is called with $v=\pm1$ when a plus or minus sign is
+appended to the output. It extends \PASCAL\ to allow repeated signs
+(e.g., `\.{--}' is equivalent to `\.+'), rather than to give an error message.
+The signs following `\.E' in real constants are treated as part of a fraction,
+so they are not seen by this routine.
+
+@p procedure send_sign(@!v:integer);
+begin case out_state of
+sign, sign_val_sign: out_app:=out_app*v;
+sign_val:begin out_app:=v; out_state:=sign_val_sign;
+ end;
+sign_val_val: begin out_val:=out_val+out_app; out_app:=v;
+ out_state:=sign_val_sign;
+ end;
+othercases begin break_ptr:=out_ptr; out_app:=v; out_state:=sign;
+ end
+endcases;@/
+last_sign:=out_app;
+end;
+
+@ When a (signed) integer value is to be output, we call |send_val|.
+
+@d bad_case=666 {this is a label used below}
+
+@p procedure send_val(@!v:integer); {output the (signed) value |v|}
+label bad_case, {go here if we can't keep |v| in the output state}
+ exit;
+begin case out_state of
+num_or_id: begin @<If previous output was \.{DIV} or \.{MOD}, |goto bad_case|@>;
+ out_sign:=" "; out_state:=sign_val; out_val:=v; break_ptr:=out_ptr;
+ last_sign:=+1;
+ end;
+misc: begin @<If previous output was \.* or \./, |goto bad_case|@>;
+ out_sign:=0; out_state:=sign_val; out_val:=v; break_ptr:=out_ptr;
+ last_sign:=+1;
+ end;
+@t\4@>@<Handle cases of |send_val| when |out_state| contains a sign@>@;
+othercases goto bad_case
+endcases;@/
+return;
+bad_case: @<Append the decimal value of |v|, with parentheses if negative@>;
+exit: end;
+
+@ @<Handle cases of |send_val|...@>=
+sign: begin out_sign:="+"; out_state:=sign_val; out_val:=out_app*v;
+ end;
+sign_val: begin out_state:=sign_val_val; out_app:=v;
+ err_print('! Two numbers occurred without a sign between them');
+ end;
+sign_val_sign: begin out_state:=sign_val_val; out_app:=out_app*v;
+ end;
+sign_val_val: begin out_val:=out_val+out_app; out_app:=v;
+ err_print('! Two numbers occurred without a sign between them');
+@.Two numbers occurred...@>
+ end;
+
+@ @<If previous output was \.*...@>=
+if (out_ptr=break_ptr+1)and((out_buf[break_ptr]="*")or(out_buf[break_ptr]="/"))
+ then goto bad_case
+
+@ @<If previous output was \.{DIV}...@>=
+if (out_ptr=break_ptr+3)or
+ ((out_ptr=break_ptr+4)and(out_buf[break_ptr]=" ")) then
+@^uppercase@>
+ if ((out_buf[out_ptr-3]="D")and(out_buf[out_ptr-2]="I")and
+ (out_buf[out_ptr-1]="V"))or @/
+ ((out_buf[out_ptr-3]="M")and(out_buf[out_ptr-2]="O")and
+ (out_buf[out_ptr-1]="D")) then@/ goto bad_case
+
+@ @<Append the decimal value...@>=
+if v>=0 then
+ begin if out_state=num_or_id then
+ begin break_ptr:=out_ptr; app(" ");
+ end;
+ app_val(v); check_break; out_state:=num_or_id;
+ end
+else begin app("("); app("-"); app_val(-v); app(")"); check_break;
+ out_state:=misc;
+ end
+
+@* The big output switch.
+To complete the output process, we need a routine that takes the results
+of |get_output| and feeds them to |send_out|, |send_val|, or |send_sign|.
+This procedure `|send_the_output|' will be invoked just once, as follows:
+
+@<Phase II: Output the contents of the compressed tables@>=
+if text_link[0]=0 then
+ begin print_nl('! No output was specified.'); mark_harmless;
+@.No output was specified@>
+ end
+else begin print_nl('Writing the output file'); update_terminal;@/
+ @<Initialize the output stacks@>;
+ @<Initialize the output buffer@>;
+ send_the_output;@/
+ @<Empty the last line...@>;
+ print_nl('Done.');
+ end
+
+@ A many-way switch is used to send the output:
+
+@d get_fraction=2 {this label is used below}
+
+@p procedure send_the_output;
+label get_fraction, {go here to finish scanning a real constant}
+ reswitch, continue;
+var cur_char:eight_bits; {the latest character received}
+ @!k:0..line_length; {index into |out_contrib|}
+ @!j:0..max_bytes; {index into |byte_mem|}
+ @!w:0..ww-1; {segment of |byte_mem|}
+ @!n:integer; {number being scanned}
+begin while stack_ptr>0 do
+ begin cur_char:=get_output;
+ reswitch: case cur_char of
+ 0: do_nothing; {this case might arise if output ends unexpectedly}
+ @t\4@>@<Cases related to identifiers@>@;
+ @t\4@>@<Cases related to constants, possibly leading to
+ |get_fraction| or |reswitch|@>@;
+ "+","-": send_sign(","-cur_char);
+ @t\4@>@<Cases like \.{<>} and \.{:=}@>@;
+ "'": @<Send a string, |goto reswitch|@>;
+ @<Other printable characters@>: send_out(misc,cur_char);
+ @t\4@>@<Cases involving \.{@@\{} and \.{@@\}}@>@;
+ join: begin send_out(frac,0); out_state:=unbreakable;
+ end;
+ verbatim: @<Send verbatim string@>;
+ force_line: @<Force a line break@>;
+ othercases err_print('! Can''t output ASCII code ',cur_char:1)
+@.Can't output ASCII code n@>
+ endcases;@/
+ goto continue;
+ get_fraction: @<Special code to finish real constants@>;
+ continue: end;
+end;
+
+@ @<Cases like \.{<>}...@>=
+and_sign: begin out_contrib[1]:="A"; out_contrib[2]:="N"; out_contrib[3]:="D";
+@^uppercase@>
+ send_out(ident,3);
+ end;
+not_sign: begin out_contrib[1]:="N"; out_contrib[2]:="O"; out_contrib[3]:="T";
+ send_out(ident,3);
+ end;
+set_element_sign: begin out_contrib[1]:="I"; out_contrib[2]:="N";
+ send_out(ident,2);
+ end;
+or_sign: begin out_contrib[1]:="O"; out_contrib[2]:="R"; send_out(ident,2);
+ end;
+left_arrow: begin out_contrib[1]:=":"; out_contrib[2]:="="; send_out(str,2);
+ end;
+not_equal: begin out_contrib[1]:="<"; out_contrib[2]:=">"; send_out(str,2);
+ end;
+less_or_equal: begin out_contrib[1]:="<"; out_contrib[2]:="="; send_out(str,2);
+ end;
+greater_or_equal: begin out_contrib[1]:=">"; out_contrib[2]:="=";
+ send_out(str,2);
+ end;
+equivalence_sign: begin out_contrib[1]:="="; out_contrib[2]:="=";
+ send_out(str,2);
+ end;
+double_dot: begin out_contrib[1]:="."; out_contrib[2]:="."; send_out(str,2);
+ end;
+
+@ Please don't ask how all of the following characters can actually get
+through \.{TANGLE} outside of strings. It seems that |""""| and |"{"|
+cannot actually occur at this point of the program, but they have
+been included just in case \.{TANGLE} changes.
+
+If \.{TANGLE} is producing code for a \PASCAL\ compiler that uses `\.{(.}'
+and `\.{.)}' instead of square brackets (e.g., on machines with {\mc EBCDIC}
+code), one should remove |"["| and |"]"| from this list and put them into
+the preceding module in the appropriate way. Similarly, some compilers
+want `\.\^' to be converted to `\.{@@}'.
+@^system dependencies@>@^EBCDIC@>
+
+@<Other printable characters@>=
+"!","""","#","$","%","&","(",")","*",",","/",":",";","<","=",">","?",
+"@@","[","\","]","^","_","`","{","|"
+
+@ Single-character identifiers represent themselves, while longer ones
+appear in |byte_mem|. All must be converted to uppercase,
+with underlines removed. Extremely long identifiers must be chopped.
+
+(Some \PASCAL\ compilers work with lowercase letters instead of
+uppercase. If this module of \.{TANGLE} is changed, it's also necessary
+to change from uppercase to lowercase in the modules that are
+listed in the index under ``uppercase''.)
+@^system dependencies@>
+@^uppercase@>
+
+@d up_to(#)==#-24,#-23,#-22,#-21,#-20,#-19,#-18,#-17,#-16,#-15,#-14,
+ #-13,#-12,#-11,#-10,#-9,#-8,#-7,#-6,#-5,#-4,#-3,#-2,#-1,#
+
+@<Cases related to identifiers@>=
+"A",up_to("Z"): begin out_contrib[1]:=cur_char; send_out(ident,1);
+ end;
+"a",up_to("z"): begin out_contrib[1]:=cur_char-@'40; send_out(ident,1);
+ end;
+identifier: begin k:=0; j:=byte_start[cur_val]; w:=cur_val mod ww;
+ while (k<max_id_length)and(j<byte_start[cur_val+ww]) do
+ begin incr(k); out_contrib[k]:=byte_mem[w,j]; incr(j);
+ if out_contrib[k]>="a" then out_contrib[k]:=out_contrib[k]-@'40
+ else if out_contrib[k]="_" then decr(k);
+ end;
+ send_out(ident,k);
+ end;
+
+@ After sending a string, we need to look ahead at the next character, in order
+to see if there were two consecutive single-quote marks. Afterwards we go to
+|reswitch| to process the next character.
+
+@<Send a string...@>=
+begin k:=1; out_contrib[1]:="'";
+repeat if k<line_length then incr(k);
+out_contrib[k]:=get_output;
+until (out_contrib[k]="'")or(stack_ptr=0);
+if k=line_length then err_print('! String too long');
+@.String too long@>
+send_out(str,k); cur_char:=get_output;
+if cur_char="'" then out_state:=unbreakable;
+goto reswitch;
+end
+
+@ Sending a verbatim string is similar, but we don't have to look ahead.
+
+@<Send verbatim string@>=
+begin k:=0;
+repeat if k<line_length then incr(k);
+out_contrib[k]:=get_output;
+until (out_contrib[k]=verbatim)or(stack_ptr=0);
+if k=line_length then err_print('! Verbatim string too long');
+@.Verbatim string too long@>
+send_out(str,k-1);
+end
+
+@ In order to encourage portable software, \.{TANGLE} complains
+if the constants get dangerously close to the largest value representable
+on a 32-bit computer ($2^{31}-1$).
+
+@d digits=="0","1","2","3","4","5","6","7","8","9"
+
+@<Cases related to constants...@>=
+digits: begin n:=0;
+ repeat cur_char:=cur_char-"0";
+ if n>=@'1463146314 then err_print('! Constant too big')
+@.Constant too big@>
+ else n:=10*n+cur_char;
+ cur_char:=get_output;
+ until (cur_char>"9")or(cur_char<"0");
+ send_val(n); k:=0;
+ if cur_char="e" then cur_char:="E";
+@^uppercase@>
+ if cur_char="E" then goto get_fraction
+ else goto reswitch;
+ end;
+check_sum: send_val(pool_check_sum);
+octal: begin n:=0; cur_char:="0";
+ repeat cur_char:=cur_char-"0";
+ if n>=@'2000000000 then err_print('! Constant too big')
+ else n:=8*n+cur_char;
+ cur_char:=get_output;
+ until (cur_char>"7")or(cur_char<"0");
+ send_val(n); goto reswitch;
+ end;
+hex: begin n:=0; cur_char:="0";
+ repeat if cur_char>="A" then cur_char:=cur_char+10-"A"
+ else cur_char:=cur_char-"0";
+ if n>=@"8000000 then err_print('! Constant too big')
+ else n:=16*n+cur_char;
+ cur_char:=get_output;
+ until (cur_char>"F")or(cur_char<"0")or@|
+ ((cur_char>"9")and(cur_char<"A"));
+ send_val(n); goto reswitch;
+ end;
+number: send_val(cur_val);
+".": begin k:=1; out_contrib[1]:="."; cur_char:=get_output;
+ if cur_char="." then
+ begin out_contrib[2]:="."; send_out(str,2);
+ end
+ else if (cur_char>="0")and(cur_char<="9") then goto get_fraction
+ else begin send_out(misc,"."); goto reswitch;
+ end;
+ end;
+
+@ The following code appears at label `|get_fraction|', when we want to
+scan to the end of a real constant. The first |k| characters of a fraction
+have already been placed in |out_contrib|, and |cur_char| is the next character.
+
+@<Special code...@>=
+repeat if k<line_length then incr(k);
+out_contrib[k]:=cur_char; cur_char:=get_output;
+if (out_contrib[k]="E")and((cur_char="+")or(cur_char="-")) then
+@^uppercase@>
+ begin if k<line_length then incr(k);
+ out_contrib[k]:=cur_char; cur_char:=get_output;
+ end
+else if cur_char="e" then cur_char:="E";
+until (cur_char<>"E")and((cur_char<"0")or(cur_char>"9"));
+if k=line_length then err_print('! Fraction too long');
+@.Fraction too long@>
+send_out(frac,k); goto reswitch
+
+@ Some \PASCAL\ compilers do not recognize comments in braces, so the
+comments must be delimited by `\.{(*}' and `\.{*)}'.
+@^system dependencies@>
+In such cases the statement `|send_out(misc,"{")|' that appears here should
+be replaced by `\ignorespaces|begin out_contrib[1]:="("; out_contrib[2]:="*";
+send_out(str,2); end|', and a similar change should be made to
+`|send_out(misc,"}")|'.
+
+@<Cases involving \.{@@\{} and \.{@@\}}@>=
+begin_comment: begin if brace_level=0 then send_out(misc,"{")
+ else send_out(misc,"[");
+ incr(brace_level);
+ end;
+end_comment: if brace_level>0 then
+ begin decr(brace_level);
+ if brace_level=0 then send_out(misc,"}")
+ else send_out(misc,"]");
+ end
+ else err_print('! Extra @@}');
+@.Extra \AT!\}@>
+module_number: begin if brace_level=0 then send_out(misc,"{")
+ else send_out(misc,"[");
+ if cur_val<0 then
+ begin send_out(misc,":"); send_val(-cur_val);
+ end
+ else begin send_val(cur_val); send_out(misc,":");
+ end;
+ if brace_level=0 then send_out(misc,"}")
+ else send_out(misc,"]");
+ end;
+
+@ @<Force a line break@>=
+begin send_out(str,0); {normalize the buffer}
+while out_ptr>0 do
+ begin if out_ptr<=line_length then break_ptr:=out_ptr;
+ flush_buffer;
+ end;
+out_state:=misc;
+end
+
+@* Introduction to the input phase.
+We have now seen that \.{TANGLE} will be able to output the full
+\PASCAL\ program, if we can only get that program into the byte memory in
+the proper format. The input process is something like the output process
+in reverse, since we compress the text as we read it in and we expand it
+as we write it out.
+
+There are three main input routines. The most interesting is the one that gets
+the next token of a \PASCAL\ text; the other two are used to scan rapidly past
+\TeX\ text in the \.{WEB} source code. One of the latter routines will jump to
+the next token that starts with `\.{@@}', and the other skips to the end
+of a \PASCAL\ comment.
+
+@ But first we need to consider the low-level routine |get_line|
+that takes care of merging |change_file| into |web_file|. The |get_line|
+procedure also updates the line numbers for error messages.
+
+@<Globals...@>=
+@!ii:integer; {general purpose |for| loop variable in the outer block}
+@!line:integer; {the number of the current line in the current file}
+@!other_line:integer; {the number of the current line in the input file that
+ is not currently being read}
+@!temp_line:integer; {used when interchanging |line| with |other_line|}
+@!limit:0..buf_size; {the last character position occupied in the buffer}
+@!loc:0..buf_size; {the next character position to be read from the buffer}
+@!input_has_ended: boolean; {if |true|, there is no more input}
+@!changing: boolean; {if |true|, the current line is from |change_file|}
+
+@ As we change |changing| from |true| to |false| and back again, we must
+remember to swap the values of |line| and |other_line| so that the |err_print|
+routine will be sure to report the correct line number.
+
+@d change_changing==
+ changing := not changing;
+ temp_line:=other_line; other_line:=line; line:=temp_line
+ {|line @t$\null\BA\null$@> other_line|}
+
+@ When |changing| is |false|, the next line of |change_file| is kept in
+|change_buffer[0..change_limit]|, for purposes of comparison with the next
+line of |web_file|. After the change file has been completely input, we
+set |change_limit:=0|, so that no further matches will be made.
+
+@<Globals...@>=
+@!change_buffer:array[0..buf_size] of ASCII_code;
+@!change_limit:0..buf_size; {the last position occupied in |change_buffer|}
+
+@ Here's a simple function that checks if the two buffers are different.
+
+@p function lines_dont_match:boolean;
+label exit;
+var k:0..buf_size; {index into the buffers}
+begin lines_dont_match:=true;
+if change_limit<>limit then return;
+if limit>0 then
+ for k:=0 to limit-1 do if change_buffer[k]<>buffer[k] then return;
+lines_dont_match:=false;
+exit: end;
+
+@ Procedure |prime_the_change_buffer| sets |change_buffer| in preparation
+for the next matching operation. Since blank lines in the change file are
+not used for matching, we have |(change_limit=0)and not changing| if and
+only if the change file is exhausted. This procedure is called only
+when |changing| is true; hence error messages will be reported correctly.
+
+@p procedure prime_the_change_buffer;
+label continue, done, exit;
+var k:0..buf_size; {index into the buffers}
+begin change_limit:=0; {this value will be used if the change file ends}
+@<Skip over comment lines in the change file; |return| if end of file@>;
+@<Skip to the next nonblank line; |return| if end of file@>;
+@<Move |buffer| and |limit| to |change_buffer| and |change_limit|@>;
+exit: end;
+
+@ While looking for a line that begins with \.{@@x} in the change file,
+we allow lines that begin with \.{@@}, as long as they don't begin with
+\.{@@y} or \.{@@z} (which would probably indicate that the change file is
+fouled up).
+
+@<Skip over comment lines in the change file...@>=
+loop@+ begin incr(line);
+ if not input_ln(change_file) then return;
+ if limit<2 then goto continue;
+ if buffer[0]<>"@@" then goto continue;
+ if (buffer[1]>="X")and(buffer[1]<="Z") then
+ buffer[1]:=buffer[1]+"z"-"Z"; {lowercasify}
+ if buffer[1]="x" then goto done;
+ if (buffer[1]="y")or(buffer[1]="z") then
+ begin loc:=2; err_print('! Where is the matching @@x?');
+@.Where is the match...@>
+ end;
+continue: end;
+done:
+
+@ Here we are looking at lines following the \.{@@x}.
+
+@<Skip to the next nonblank line...@>=
+repeat incr(line);
+ if not input_ln(change_file) then
+ begin err_print('! Change file ended after @@x');
+@.Change file ended...@>
+ return;
+ end;
+until limit>0;
+
+@ @<Move |buffer| and |limit| to |change_buffer| and |change_limit|@>=
+begin change_limit:=limit;
+if limit>0 then for k:=0 to limit-1 do change_buffer[k]:=buffer[k];
+end
+
+@ The following procedure is used to see if the next change entry should
+go into effect; it is called only when |changing| is false.
+The idea is to test whether or not the current
+contents of |buffer| matches the current contents of |change_buffer|.
+If not, there's nothing more to do; but if so, a change is called for:
+All of the text down to the \.{@@y} is supposed to match. An error
+message is issued if any discrepancy is found. Then the procedure
+prepares to read the next line from |change_file|.
+
+@p procedure check_change; {switches to |change_file| if the buffers match}
+label exit;
+var n:integer; {the number of discrepancies found}
+@!k:0..buf_size; {index into the buffers}
+begin if lines_dont_match then return;
+n:=0;
+loop@+ begin change_changing; {now it's |true|}
+ incr(line);
+ if not input_ln(change_file) then
+ begin err_print('! Change file ended before @@y');
+@.Change file ended...@>
+ change_limit:=0; change_changing; {|false| again}
+ return;
+ end;
+ @<If the current line starts with \.{@@y},
+ report any discrepancies and |return|@>;
+ @<Move |buffer| and |limit|...@>;
+ change_changing; {now it's |false|}
+ incr(line);
+ if not input_ln(web_file) then
+ begin err_print('! WEB file ended during a change');
+@.WEB file ended...@>
+ input_has_ended:=true; return;
+ end;
+ if lines_dont_match then incr(n);
+ end;
+exit: end;
+
+@ @<If the current line starts with \.{@@y}...@>=
+if limit>1 then if buffer[0]="@@" then
+ begin if (buffer[1]>="X")and(buffer[1]<="Z") then
+ buffer[1]:=buffer[1]+"z"-"Z"; {lowercasify}
+ if (buffer[1]="x")or(buffer[1]="z") then
+ begin loc:=2; err_print('! Where is the matching @@y?');
+@.Where is the match...@>
+ end
+ else if buffer[1]="y" then
+ begin if n>0 then
+ begin loc:=2; err_print('! Hmm... ',n:1,
+ ' of the preceding lines failed to match');
+@.Hmm... n of the preceding...@>
+ end;
+ return;
+ end;
+ end
+
+@ @<Initialize the input system@>=
+open_input; line:=0; other_line:=0;@/
+changing:=true; prime_the_change_buffer; change_changing;@/
+limit:=0; loc:=1; buffer[0]:=" "; input_has_ended:=false;
+
+@ The |get_line| procedure is called when |loc>limit|; it puts the next
+line of merged input into the buffer and updates the other variables
+appropriately. A space is placed at the right end of the line.
+
+@p procedure get_line; {inputs the next line}
+label restart;
+begin restart: if changing then
+ @<Read from |change_file| and maybe turn off |changing|@>;
+if not changing then
+ begin @<Read from |web_file| and maybe turn on |changing|@>;
+ if changing then goto restart;
+ end;
+loc:=0; buffer[limit]:=" ";
+end;
+
+@ @<Read from |web_file|...@>=
+begin incr(line);
+if not input_ln(web_file) then input_has_ended:=true
+else if limit=change_limit then
+ if buffer[0]=change_buffer[0] then
+ if change_limit>0 then check_change;
+end
+
+@ @<Read from |change_file|...@>=
+begin incr(line);
+if not input_ln(change_file) then
+ begin err_print('! Change file ended without @@z');
+@.Change file ended...@>
+ buffer[0]:="@@"; buffer[1]:="z"; limit:=2;
+ end;
+if limit>1 then {check if the change has ended}
+ if buffer[0]="@@" then
+ begin if (buffer[1]>="X")and(buffer[1]<="Z") then
+ buffer[1]:=buffer[1]+"z"-"Z"; {lowercasify}
+ if (buffer[1]="x")or(buffer[1]="y") then
+ begin loc:=2; err_print('! Where is the matching @@z?');
+@.Where is the match...@>
+ end
+ else if buffer[1]="z" then
+ begin prime_the_change_buffer; change_changing;
+ end;
+ end;
+end
+
+@ At the end of the program, we will tell the user if the change file
+had a line that didn't match any relevant line in |web_file|.
+
+@<Check that all changes have been read@>=
+if change_limit<>0 then {|changing| is false}
+ begin for ii:=0 to change_limit do buffer[ii]:=change_buffer[ii];
+ limit:=change_limit; changing:=true; line:=other_line; loc:=change_limit;
+ err_print('! Change file entry did not match');
+@.Change file entry did not match@>
+ end
+
+@ Important milestones are reached during the input phase when certain
+control codes are sensed.
+
+Control codes in \.{WEB} begin with `\.{@@}', and the next character
+identifies the code. Some of these are of interest only to \.{WEAVE},
+so \.{TANGLE} ignores them; the others are converted by \.{TANGLE} into
+internal code numbers by the |control_code| function below. The ordering
+of these internal code numbers has been chosen to simplify the program logic;
+larger numbers are given to the control codes that denote more significant
+milestones.
+
+@d ignore=0 {control code of no interest to \.{TANGLE}}
+@d control_text=@'203 {control code for `\.{@@t}', `\.{@@\^}', etc.}
+@d format=@'204 {control code for `\.{@@f}'}
+@d definition=@'205 {control code for `\.{@@d}'}
+@d begin_Pascal=@'206 {control code for `\.{@@p}'}
+@d module_name=@'207 {control code for `\.{@@<}'}
+@d new_module=@'210 {control code for `\.{@@\ }' and `\.{@@*}'}
+
+@p function control_code(@!c:ASCII_code):eight_bits; {convert |c| after \.{@@}}
+begin case c of
+"@@": control_code:="@@"; {`quoted' at sign}
+"'": control_code:=octal; {precedes octal constant}
+"""": control_code:=hex; {precedes hexadecimal constant}
+"$": control_code:=check_sum; {string pool check sum}
+" ",tab_mark: control_code:=new_module; {beginning of a new module}
+"*": begin print('*',module_count+1:1);
+ update_terminal; {print a progress report}
+ control_code:=new_module; {beginning of a new module}
+ end;
+"D","d": control_code:=definition; {macro definition}
+"F","f": control_code:=format; {format definition}
+"{": control_code:=begin_comment; {begin-comment delimiter}
+"}": control_code:=end_comment; {end-comment delimiter}
+"P","p": control_code:=begin_Pascal; {\PASCAL\ text in unnamed module}
+"T","t","^",".",":": control_code:=control_text; {control text to be ignored}
+"&": control_code:=join; {concatenate two tokens}
+"<": control_code:=module_name; {beginning of a module name}
+"=": control_code:=verbatim; {beginning of \PASCAL\ verbatim mode}
+"\": control_code:=force_line; {force a new line in \PASCAL\ output}
+othercases control_code:=ignore {ignore all other cases}
+endcases;
+end;
+
+@ The |skip_ahead| procedure reads through the input at fairly high speed
+until finding the next non-ignorable control code, which it returns.
+
+@p function skip_ahead:eight_bits; {skip to next control code}
+label done;
+var c:eight_bits; {control code found}
+begin loop begin if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin c:=new_module; goto done;
+ end;
+ end;
+ buffer[limit+1]:="@@";
+ while buffer[loc]<>"@@" do incr(loc);
+ if loc<=limit then
+ begin loc:=loc+2; c:=control_code(buffer[loc-1]);
+ if (c<>ignore)or(buffer[loc-1]=">") then goto done;
+ end;
+ end;
+done: skip_ahead:=c;
+end;
+
+@ The |skip_comment| procedure reads through the input at somewhat high speed
+until finding the first unmatched right brace or until coming to the end
+of the file. It ignores characters following `\.\\' characters, since all
+braces that aren't nested are supposed to be hidden in that way. For
+example, consider the process of skipping the first comment below,
+where the string containing the right brace has been typed as \.{\`\\.\\\}\'}
+in the \.{WEB} file.
+
+@p procedure skip_comment; {skips to next unmatched `\.\}'}
+label exit;
+var bal:eight_bits; {excess of left braces}
+@!c:ASCII_code; {current character}
+begin bal:=0;
+loop@+ begin if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin err_print('! Input ended in mid-comment');
+@.Input ended in mid-comment@>
+ return;
+ end;
+ end;
+ c:=buffer[loc]; incr(loc);
+ @<Do special things when |c="@@", "\", "{", "}"|; |return| at end@>;
+ end;
+exit:end;
+
+@ @<Do special things when |c="@@"...@>=
+if c="@@" then
+ begin c:=buffer[loc];
+ if (c<>" ")and(c<>tab_mark)and(c<>"*")and(c<>"z")and(c<>"Z") then incr(loc)
+ else begin err_print('! Section ended in mid-comment');
+@.Section ended in mid-comment@>
+ decr(loc); return;
+ end
+ end
+else if (c="\")and(buffer[loc]<>"@@") then incr(loc)
+else if c="{" then incr(bal)
+else if c="}" then
+ begin if bal=0 then return;
+ decr(bal);
+ end
+
+@* Inputting the next token.
+As stated above, \.{TANGLE}'s most interesting input procedure is the
+|get_next| routine that inputs the next token. However, the procedure
+isn't especially difficult.
+
+In most cases the tokens output by |get_next| have the form used in
+replacement texts, except that two-byte tokens are not produced.
+An identifier that isn't one letter long is represented by the
+output `|identifier|', and in such a case the global variables
+|id_first| and |id_loc| will have been set to the appropriate values
+needed by the |id_lookup| procedure. A string that begins with a
+double-quote is also considered an |identifier|, and in such a case
+the global variable |double_chars| will also have been set appropriately.
+Control codes produce the corresponding output of the |control_code|
+function above; and if that code is |module_name|, the value of |cur_module|
+will point to the |byte_start| entry for that module name.
+
+Another global variable, |scanning_hex|, is |true| during the time that
+the letters \.A through \.F should be treated as if they were digits.
+
+@<Globals...@>=
+@!cur_module: name_pointer; {name of module just scanned}
+@!scanning_hex: boolean; {are we scanning a hexadecimal constant?}
+
+@ @<Set init...@>=
+scanning_hex:=false;
+
+@ At the top level, |get_next| is a multi-way switch based on the next
+character in the input buffer. A |new_module| code is inserted at the
+very end of the input file.
+
+@p function get_next:eight_bits; {produces the next input token}
+label restart,done,found;
+var c:eight_bits; {the current character}
+@!d:eight_bits; {the next character}
+@!j,@!k:0..longest_name; {indices into |mod_text|}
+begin restart: if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin c:=new_module; goto found;
+ end;
+ end;
+c:=buffer[loc]; incr(loc);
+if scanning_hex then @<Go to |found| if |c| is a hexadecimal digit,
+ otherwise set |scanning_hex:=false|@>;
+case c of
+"A",up_to("Z"),"a",up_to("z"): @<Get an identifier@>;
+"""": @<Get a preprocessed string@>;
+"@@": @<Get control code and possible module name@>;
+@t\4@>@<Compress two-symbol combinations like `\.{:=}'@>@;
+" ",tab_mark: goto restart; {ignore spaces and tabs}
+"{": begin skip_comment; goto restart;
+ end;
+"}": begin err_print('! Extra }'); goto restart;
+@.Extra \}@>
+ end;
+othercases if c>=128 then goto restart {ignore nonstandard characters}
+ else do_nothing
+endcases;
+found:@!debug if trouble_shooting then debug_help;@;@+gubed@/
+get_next:=c;
+end;
+
+@ @<Go to |found| if |c| is a hexadecimal digit...@>=
+if ((c>="0")and(c<="9"))or((c>="A")and(c<="F")) then goto found
+else scanning_hex:=false
+
+@ Note that the following code substitutes \.{@@\{} and \.{@@\}} for the
+respective combinations `\.{(*}' and `\.{*)}'. Explicit braces should be used
+for \TeX\ comments in \PASCAL\ text.
+
+@d compress(#)==begin if loc<=limit then begin c:=#; incr(loc); end; end
+
+@<Compress two-symbol...@>=
+".": if buffer[loc]="." then compress(double_dot)
+ else if buffer[loc]=")" then compress("]");
+":": if buffer[loc]="=" then compress(left_arrow);
+"=": if buffer[loc]="=" then compress(equivalence_sign);
+">": if buffer[loc]="=" then compress(greater_or_equal);
+"<": if buffer[loc]="=" then compress(less_or_equal)
+ else if buffer[loc]=">" then compress(not_equal);
+"(": if buffer[loc]="*" then compress(begin_comment)
+ else if buffer[loc]="." then compress("[");
+"*": if buffer[loc]=")" then compress(end_comment);
+
+@ We have to look at the preceding character to make sure this isn't part
+of a real constant, before trying to find an identifier starting with
+`\.e' or `\.E'.
+
+@<Get an identifier@>=
+begin if ((c="e")or(c="E"))and(loc>1) then
+ if (buffer[loc-2]<="9")and(buffer[loc-2]>="0") then c:=0;
+if c<>0 then
+ begin decr(loc); id_first:=loc;
+ repeat incr(loc); d:=buffer[loc];
+ until ((d<"0")or((d>"9")and(d<"A"))or((d>"Z")and(d<"a"))or(d>"z")) and
+ (d<>"_");
+ if loc>id_first+1 then
+ begin c:=identifier; id_loc:=loc;
+ end;
+ end
+else c:="E"; {exponent of a real constant}
+end
+
+@ A string that starts and ends with double-quote marks is converted into
+an identifier that behaves like a numeric macro by means of the following
+piece of the program.
+@^preprocessed strings@>
+
+@<Get a preprocessed string@>=
+begin double_chars:=0; id_first:=loc-1;
+repeat d:=buffer[loc]; incr(loc);
+ if (d="""")or(d="@@") then
+ if buffer[loc]=d then
+ begin incr(loc); d:=0; incr(double_chars);
+ end
+ else begin if d="@@" then err_print('! Double @@ sign missing')
+@.Double \AT! sign missing@>
+ end
+ else if loc>limit then
+ begin err_print('! String constant didn''t end'); d:="""";
+@.String constant didn't end@>
+ end;
+until d="""";
+id_loc:=loc-1; c:=identifier;
+end
+
+@ After an \.{@@} sign has been scanned, the next character tells us
+whether there is more work to do.
+
+@<Get control code and possible module name@>=
+begin c:=control_code(buffer[loc]); incr(loc);
+if c=ignore then goto restart
+else if c=hex then scanning_hex:=true
+else if c=module_name then
+ @<Scan the \(module name and make |cur_module| point to it@>
+else if c=control_text then
+ begin repeat c:=skip_ahead;
+ until c<>"@@";
+ if buffer[loc-1]<>">" then
+ err_print('! Improper @@ within control text');
+@.Improper \AT! within control text@>
+ goto restart;
+ end;
+end
+
+@ @<Scan the \(module name...@>=
+begin @<Put module name into |mod_text[1..k]|@>;
+if k>3 then
+ begin if (mod_text[k]=".")and(mod_text[k-1]=".")and(mod_text[k-2]=".") then
+ cur_module:=prefix_lookup(k-3)
+ else cur_module:=mod_lookup(k);
+ end
+else cur_module:=mod_lookup(k);
+end
+
+@ Module names are placed into the |mod_text| array with consecutive spaces,
+tabs, and carriage-returns replaced by single spaces. There will be no
+spaces at the beginning or the end. (We set |mod_text[0]:=" "| to facilitate
+this, since the |mod_lookup| routine uses |mod_text[1]| as the first
+character of the name.)
+
+@<Set init...@>=mod_text[0]:=" ";
+
+@ @<Put module name...@>=
+k:=0;
+loop@+ begin if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin err_print('! Input ended in section name');
+@.Input ended in section name@>
+ goto done;
+ end;
+ end;
+ d:=buffer[loc];
+ @<If end of name, |goto done|@>;
+ incr(loc); if k<longest_name-1 then incr(k);
+ if (d=" ")or(d=tab_mark) then
+ begin d:=" "; if mod_text[k-1]=" " then decr(k);
+ end;
+ mod_text[k]:=d;
+ end;
+done: @<Check for overlong name@>;
+if (mod_text[k]=" ")and(k>0) then decr(k);
+
+@ @<If end of name,...@>=
+if d="@@" then
+ begin d:=buffer[loc+1];
+ if d=">" then
+ begin loc:=loc+2; goto done;
+ end;
+ if (d=" ")or(d=tab_mark)or(d="*") then
+ begin err_print('! Section name didn''t end'); goto done;
+@.Section name didn't end@>
+ end;
+ incr(k); mod_text[k]:="@@"; incr(loc); {now |d=buffer[loc]| again}
+ end
+
+@ @<Check for overlong name@>=
+if k>=longest_name-2 then
+ begin print_nl('! Section name too long: ');
+@.Section name too long@>
+ for j:=1 to 25 do print(xchr[mod_text[j]]);
+ print('...'); mark_harmless;
+ end
+
+@* Scanning a numeric definition.
+When \.{TANGLE} looks at the \PASCAL\ text following the `\.=' of a numeric
+macro definition, it calls on the precedure |scan_numeric(p)|, where |p|
+points to the name that is to be defined. This procedure evaluates the
+right-hand side, which must consist entirely of integer constants and
+defined numeric macros connected with \.+ and \.- signs (no parentheses).
+It also sets the global variable |next_control| to the control code that
+terminated this definition.
+
+A definition ends with the control codes |definition|, |format|, |module_name|,
+|begin_Pascal|, and |new_module|, all of which can be recognized
+by the fact that they are the largest values |get_next| can return.
+
+@d end_of_definition(#)==(#>=format)
+ {is |#| a control code ending a definition?}
+
+@<Global...@>=
+@!next_control:eight_bits; {control code waiting to be acted upon}
+
+@ The evaluation of a numeric expression makes use of two variables called the
+|accumulator| and the |next_sign|. At the beginning, |accumulator| is zero and
+|next_sign| is $+1$. When a \.+ or \.- is scanned, |next_sign| is multiplied
+by the value of that sign. When a numeric value is scanned, it is multiplied by
+|next_sign| and added to the |accumulator|, then |next_sign| is reset to $+1$.
+
+@d add_in(#)==begin accumulator:=accumulator+next_sign*(#); next_sign:=+1;
+ end
+
+@p procedure scan_numeric(@!p:name_pointer); {defines numeric macros}
+label reswitch, done;
+var accumulator:integer; {accumulates sums}
+@!next_sign:-1..+1; {sign to attach to next value}
+@!q:name_pointer; {points to identifiers being evaluated}
+@!val:integer; {constants being evaluated}
+begin @<Set \(|accumulator| to the value of the right-hand side@>;
+if abs(accumulator)>=1073741824 then
+ begin err_print('! Value too big: ',accumulator:1); accumulator:=0;
+@.Value too big@>
+ end;
+equiv[p]:=accumulator+1073741824;
+ {name |p| now is defined to equal |accumulator|}
+end;
+
+@ @<Set \(|accumulator| to the value of the right-hand side@>=
+accumulator:=0; next_sign:=+1;
+loop@+ begin next_control:=get_next;
+ reswitch: case next_control of
+ digits: begin @<Set |val| to value of decimal constant, and
+ set |next_control| to the following token@>;
+ add_in(val); goto reswitch;
+ end;
+ octal: begin @<Set |val| to value of octal constant, and
+ set |next_control| to the following token@>;
+ add_in(val); goto reswitch;
+ end;
+ hex: begin @<Set |val| to value of hexadecimal constant, and
+ set |next_control| to the following token@>;
+ add_in(val); goto reswitch;
+ end;
+ identifier: begin q:=id_lookup(normal);
+ if ilk[q]<>numeric then
+ begin next_control:="*"; goto reswitch; {leads to error}
+ end;
+ add_in(equiv[q]-1073741824);
+ end;
+ "+": do_nothing;
+ "-": next_sign:=-next_sign;
+ format, definition, module_name, begin_Pascal, new_module: goto done;
+ ";": err_print('! Omit semicolon in numeric definition');
+@.Omit semicolon in numeric def...@>
+ othercases @<Signal error, flush rest of the definition@>
+ endcases;
+ end;
+done:
+
+@ @<Signal error, flush rest...@>=
+begin err_print('! Improper numeric definition will be flushed');
+@.Improper numeric definition...@>
+repeat next_control:=skip_ahead
+until end_of_definition(next_control);
+if next_control=module_name then
+ begin {we want to scan the module name too}
+ loc:=loc-2; next_control:=get_next;
+ end;
+accumulator:=0; goto done;
+end
+
+@ @<Set |val| to value of decimal...@>=
+val:=0;
+repeat val:=10*val+next_control-"0"; next_control:=get_next;
+until (next_control>"9")or(next_control<"0")
+
+@ @<Set |val| to value of octal...@>=
+val:=0; next_control:="0";
+repeat val:=8*val+next_control-"0"; next_control:=get_next;
+until (next_control>"7")or(next_control<"0")
+
+@ @<Set |val| to value of hex...@>=
+val:=0; next_control:="0";
+repeat if next_control>="A" then next_control:=next_control+"0"+10-"A";
+val:=16*val+next_control-"0"; next_control:=get_next;
+until (next_control>"F")or(next_control<"0")or@|
+ ((next_control>"9")and(next_control<"A"))
+
+@* Scanning a macro definition.
+The rules for generating the replacement texts corresponding to simple
+macros, parametric macros, and \PASCAL\ texts of a module are almost
+identical, so a single procedure is used for all three cases. The
+differences are that
+
+\yskip\item{a)} The sign |#| denotes a parameter only when it appears
+outside of strings in a parametric macro; otherwise it stands for the
+ASCII character |#|. (This is not used in standard \PASCAL, but some
+\PASCAL s allow, for example, `\.{/\#}' after a certain kind of file name.)
+
+\item{b)}Module names are not allowed in simple macros or parametric macros;
+in fact, the appearance of a module name terminates such macros and denotes
+the name of the current module.
+
+\item{c)}The symbols \.{@@d} and \.{@@f} and \.{@@p} are not allowed after
+module names, while they terminate macro definitions.
+
+@ Therefore there is a procedure |scan_repl| whose parameter |t| specifies
+either |simple| or |parametric| or |module_name|. After |scan_repl| has
+acted, |cur_repl_text| will point to the replacement text just generated, and
+|next_control| will contain the control code that terminated the activity.
+
+@<Globals...@>=
+@!cur_repl_text:text_pointer; {replacement text formed by |scan_repl|}
+
+@ @p procedure scan_repl(@!t:eight_bits); {creates a replacement text}
+label continue, done, found, reswitch;
+var a:sixteen_bits; {the current token}
+@!b:ASCII_code; {a character from the buffer}
+@!bal:eight_bits; {left parentheses minus right parentheses}
+begin bal:=0;
+loop@+ begin continue: a:=get_next;
+ case a of
+ "(": incr(bal);
+ ")": if bal=0 then err_print('! Extra )')
+@.Extra )@>
+ else decr(bal);
+ "'": @<Copy a string from the buffer to |tok_mem|@>;
+ "#": if t=parametric then a:=param;
+ @t\4@>@<In cases that |a| is a non-ASCII token (|identifier|,
+ |module_name|, etc.), either process it and change |a| to a byte
+ that should be stored, or |goto continue| if |a| should be ignored,
+ or |goto done| if |a| signals the end of this replacement text@>@;
+ othercases do_nothing
+ endcases;@/
+ app_repl(a); {store |a| in |tok_mem|}
+ end;
+done: next_control:=a;
+@<Make sure the parentheses balance@>;
+if text_ptr>max_texts-zz then overflow('text');
+cur_repl_text:=text_ptr; tok_start[text_ptr+zz]:=tok_ptr[z];
+incr(text_ptr);
+if z=zz-1 then z:=0@+else incr(z);
+end;
+
+@ @<Make sure the parentheses balance@>=
+if bal>0 then
+ begin if bal=1 then err_print('! Missing )')
+ else err_print('! Missing ',bal:1,' )''s');
+@.Missing n )@>
+ while bal>0 do
+ begin app_repl(")"); decr(bal);
+ end;
+ end
+
+@ @<In cases that |a| is...@>=
+identifier: begin a:=id_lookup(normal); app_repl((a div @'400)+@'200);
+ a:=a mod @'400;
+ end;
+module_name: if t<>module_name then goto done
+ else begin app_repl((cur_module div @'400)+@'250);
+ a:=cur_module mod @'400;
+ end;
+verbatim: @<Copy verbatim string from the buffer to |tok_mem|@>;
+definition, format, begin_Pascal: if t<>module_name then goto done
+ else begin err_print('! @@',xchr[buffer[loc-1]],
+@.\AT!p is ignored in Pascal text@>
+@.\AT!d is ignored in Pascal text@>
+@.\AT!f is ignored in Pascal text@>
+ ' is ignored in Pascal text'); goto continue;
+ end;
+new_module: goto done;
+
+@ @<Copy a string...@>=
+begin b:="'";
+loop@+ begin app_repl(b);
+ if b="@@" then
+ if buffer[loc]="@@" then incr(loc) {store only one \.{@@}}
+ else err_print('! You should double @@ signs in strings');
+@.You should double \AT! signs@>
+ if loc=limit then
+ begin err_print('! String didn''t end');
+@.String didn't end@>
+ buffer[loc]:="'"; buffer[loc+1]:=0;
+ end;
+ b:=buffer[loc]; incr(loc);
+ if b="'" then
+ begin if buffer[loc]<>"'" then goto found
+ else begin incr(loc); app_repl("'");
+ end;
+ end;
+ end;
+found: end {now |a| holds the final |"'"| that will be stored}
+
+@ @<Copy verbatim string...@>=
+begin app_repl(verbatim);
+buffer[limit+1]:="@@";
+reswitch: if buffer[loc]="@@" then
+ begin if loc<limit then if buffer[loc+1]="@@" then
+ begin app_repl("@@");
+ loc:=loc+2;
+ goto reswitch;
+ end;
+ end
+else begin app_repl(buffer[loc]);
+ incr(loc);
+ goto reswitch;
+ end;
+if loc>=limit then err_print('! Verbatim string didn''t end')
+@.Verbatim string didn't end@>
+else if buffer[loc+1]<>">" then
+ err_print('! You should double @@ signs in verbatim strings');
+@.You should double \AT! signs@>
+loc:=loc+2;
+end {another |verbatim| byte will be stored, since |a=verbatim|}
+
+@ The following procedure is used to define a simple or parametric macro,
+just after the `\.{==}' of its definition has been scanned.
+
+@p procedure define_macro(@!t:eight_bits);
+var p:name_pointer; {the identifier being defined}
+begin p:=id_lookup(t); scan_repl(t);@/
+equiv[p]:=cur_repl_text; text_link[cur_repl_text]:=0;
+end;
+
+@* Scanning a module.
+The |scan_module| procedure starts when `\.{@@\ }' or `\.{@@*}' has been
+sensed in the input, and it proceeds until the end of that module. It
+uses |module_count| to keep track of the current module number; with luck,
+\.{WEAVE} and \.{TANGLE} will both assign the same numbers to modules.
+
+@<Globals...@>=
+@!module_count:0..@'27777; {the current module number}
+
+@ The top level of |scan_module| is trivial.
+@p procedure scan_module;
+label continue, done, exit;
+var p:name_pointer; {module name for the current module}
+begin incr(module_count);
+@<Scan the \(definition part of the current module@>;
+@<Scan the \PASCAL\ part of the current module@>;
+exit: end;
+
+@ @<Scan the \(definition part...@>=
+next_control:=0;
+loop@+ begin continue: while next_control<=format do
+ begin next_control:=skip_ahead;
+ if next_control=module_name then
+ begin {we want to scan the module name too}
+ loc:=loc-2; next_control:=get_next;
+ end;
+ end;
+ if next_control<>definition then goto done;
+ next_control:=get_next; {get identifier name}
+ if next_control<>identifier then
+ begin err_print('! Definition flushed, must start with ',
+@.Definition flushed...@>
+ 'identifier of length > 1'); goto continue;
+ end;
+ next_control:=get_next; {get token after the identifier}
+ if next_control="=" then
+ begin scan_numeric(id_lookup(numeric)); goto continue;
+ end
+ else if next_control=equivalence_sign then
+ begin define_macro(simple); goto continue;
+ end
+ else @<If the next text is `|(#)==|', call |define_macro|
+ and |goto continue|@>;
+ err_print('! Definition flushed since it starts badly');
+@.Definition flushed...@>
+ end;
+done:
+
+@ @<If the next text is `|(#)==|'...@>=
+if next_control="(" then
+ begin next_control:=get_next;
+ if next_control="#" then
+ begin next_control:=get_next;
+ if next_control=")" then
+ begin next_control:=get_next;
+ if next_control="=" then
+ begin err_print('! Use == for macros');
+@.Use == for macros@>
+ next_control:=equivalence_sign;
+ end;
+ if next_control=equivalence_sign then
+ begin define_macro(parametric); goto continue;
+ end;
+ end;
+ end;
+ end;
+
+@ @<Scan the \PASCAL...@>=
+case next_control of
+begin_Pascal:p:=0;
+module_name: begin p:=cur_module;
+ @<Check that |=| or |==| follows this module name, otherwise |return|@>;
+ end;
+othercases return
+endcases;@/
+@<Insert the module number into |tok_mem|@>;
+scan_repl(module_name); {now |cur_repl_text| points to the replacement text}
+@<Update the data structure so that the replacement text is accessible@>;
+
+@ @<Check that |=|...@>=
+repeat next_control:=get_next;
+until next_control<>"+"; {allow optional `\.{+=}'}
+if (next_control<>"=")and(next_control<>equivalence_sign) then
+ begin err_print('! Pascal text flushed, = sign is missing');
+@.Pascal text flushed...@>
+ repeat next_control:=skip_ahead;
+ until next_control=new_module;
+ return;
+ end
+
+@ @<Insert the module number...@>=
+store_two_bytes(@'150000+module_count); {|@'150000=@'320*@'400|}
+
+@ @<Update the data...@>=
+if p=0 then {unnamed module}
+ begin text_link[last_unnamed]:=cur_repl_text; last_unnamed:=cur_repl_text;
+ end
+else if equiv[p]=0 then equiv[p]:=cur_repl_text {first module of this name}
+else begin p:=equiv[p];
+ while text_link[p]<module_flag do p:=text_link[p]; {find end of list}
+ text_link[p]:=cur_repl_text;
+ end;
+text_link[cur_repl_text]:=module_flag;
+ {mark this replacement text as a nonmacro}
+
+@* Debugging.
+The \PASCAL\ debugger with which \.{TANGLE} was developed allows breakpoints
+to be set, and variables can be read and changed, but procedures cannot be
+executed. Therefore a `|debug_help|' procedure has been inserted in the main
+loops of each phase of the program; when |ddt| and |dd| are set to appropriate
+values, symbolic printouts of various tables will appear.
+
+The idea is to set a breakpoint inside the |debug_help| routine, at the
+place of `\ignorespaces|breakpoint:|\unskip' below. Then when
+|debug_help| is to be activated, set |trouble_shooting| equal to |true|.
+The |debug_help| routine will prompt you for values of |ddt| and |dd|,
+discontinuing this when |ddt<=0|; thus you type $2n+1$ integers, ending
+with zero or a negative number. Then control either passes to the
+breakpoint, allowing you to look at and/or change variables (if you typed
+zero), or to exit the routine (if you typed a negative value).
+
+Another global variable, |debug_cycle|, can be used to skip silently
+past calls on |debug_help|. If you set |debug_cycle>1|, the program stops
+only every |debug_cycle| times |debug_help| is called; however,
+any error stop will set |debug_cycle| to zero.
+
+@<Globals...@>=
+@!debug@!trouble_shooting:boolean; {is |debug_help| wanted?}
+@!ddt:integer; {operation code for the |debug_help| routine}
+@!dd:integer; {operand in procedures performed by |debug_help|}
+@!debug_cycle:integer; {threshold for |debug_help| stopping}
+@!debug_skipped:integer; {we have skipped this many |debug_help| calls}
+@!term_in:text_file; {the user's terminal as an input file}
+gubed
+
+@ The debugging routine needs to read from the user's terminal.
+@^system dependencies@>
+@<Set init...@>=
+@!debug trouble_shooting:=true; debug_cycle:=1; debug_skipped:=0;@/
+trouble_shooting:=false; debug_cycle:=99999; {use these when it almost works}
+reset(term_in,'TTY:','/I'); {open |term_in| as the terminal, don't do a |get|}
+gubed
+
+@ @d breakpoint=888 {place where a breakpoint is desirable}
+@^system dependencies@>
+
+@p @!debug procedure debug_help; {routine to display various things}
+label breakpoint,exit;
+var k:integer; {index into various arrays}
+begin incr(debug_skipped);
+if debug_skipped<debug_cycle then return;
+debug_skipped:=0;
+loop@+ begin write(term_out,'#'); update_terminal; {prompt}
+ read(term_in,ddt); {read a list of integers}
+ if ddt<0 then return
+ else if ddt=0 then
+ begin goto breakpoint;@\ {go to every label at least once}
+ breakpoint: ddt:=0;@\
+ end
+ else begin read(term_in,dd);
+ case ddt of
+ 1: print_id(dd);
+ 2: print_repl(dd);
+ 3: for k:=1 to dd do print(xchr[buffer[k]]);
+ 4: for k:=1 to dd do print(xchr[mod_text[k]]);
+ 5: for k:=1 to out_ptr do print(xchr[out_buf[k]]);
+ 6: for k:=1 to dd do print(xchr[out_contrib[k]]);
+ othercases print('?')
+ endcases;
+ end;
+ end;
+exit:end;
+gubed
+
+@* The main program.
+We have defined plenty of procedures, and it is time to put the last
+pieces of the puzzle in place. Here is where \.{TANGLE} starts, and where
+it ends.
+@^system dependencies@>
+
+@p begin initialize;
+@<Initialize the input system@>;
+print_ln(banner); {print a ``banner line''}
+@<Phase I: Read all the user's text and compress it into |tok_mem|@>;
+stat for ii:=0 to zz-1 do max_tok_ptr[ii]:=tok_ptr[ii];@+tats@;@/
+@<Phase II:...@>;
+end_of_TANGLE:
+if string_ptr>number_chars then @<Finish off the string pool file@>;
+stat @<Print statistics about memory usage@>;@+tats@;@/
+@t\4\4@>{here files should be closed if the operating system requires it}
+@<Print the job |history|@>;
+end.
+
+@ @<Phase I:...@>=
+phase_one:=true;
+module_count:=0;
+repeat next_control:=skip_ahead;
+until next_control=new_module;
+while not input_has_ended do scan_module;
+@<Check that all changes have been read@>;
+phase_one:=false;
+
+@ @<Finish off the string pool file@>=
+begin print_nl(string_ptr-number_chars:1,
+ ' strings written to string pool file.');
+write(pool,'*');
+for ii:=1 to 9 do
+ begin out_buf[ii]:=pool_check_sum mod 10;
+ pool_check_sum:=pool_check_sum div 10;
+ end;
+for ii:=9 downto 1 do write(pool,xchr["0"+out_buf[ii]]);
+write_ln(pool);
+end
+
+@ @<Glob...@>=
+stat @!wo:0..ww-1; {segment of memory for which statistics are being printed}
+tats
+
+@ @<Print statistics about memory usage@>=
+print_nl('Memory usage statistics:');
+print_nl(name_ptr:1, ' names, ', text_ptr:1, ' replacement texts;');
+print_nl(byte_ptr[0]:1);
+for wo:=1 to ww-1 do print('+',byte_ptr[wo]:1);
+if phase_one then
+ for ii:=0 to zz-1 do max_tok_ptr[ii]:=tok_ptr[ii];
+print(' bytes, ', max_tok_ptr[0]:1);
+for ii:=1 to zz-1 do print('+',max_tok_ptr[ii]:1);
+print(' tokens.');
+
+@ Some implementations may wish to pass the |history| value to the
+operating system so that it can be used to govern whether or not other
+programs are started. Here we simply report the history to the user.
+@^system dependencies@>
+
+@<Print the job |history|@>=
+case history of
+spotless: print_nl('(No errors were found.)');
+harmless_message: print_nl('(Did you see the warning message above?)');
+error_message: print_nl('(Pardon me, but I think I spotted something wrong.)');
+fatal_message: print_nl('(That was a fatal error, my friend.)');
+end {there are no other cases}
+
+@* System-dependent changes.
+This module should be replaced, if necessary, by changes to the program
+that are necessary to make \.{TANGLE} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous modules preserve the module numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new modules, can be inserted here; then only the index
+itself will get a new module number.
+@^system dependencies@>
+
+@* Index.
+Here is a cross-reference table for the \.{TANGLE} processor.
+All modules in which an identifier is
+used are listed with that identifier, except that reserved words are
+indexed only when they appear in format definitions, and the appearances
+of identifiers in module names are not indexed. Underlined entries
+correspond to where the identifier was declared. Error messages and
+a few other things like ``ASCII code'' are indexed here too.
diff --git a/Build/source/texk/web2c/luatexdir/luatex-api.h b/Build/source/texk/web2c/luatexdir/luatex-api.h
new file mode 100644
index 00000000000..3585e01dea7
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatex-api.h
@@ -0,0 +1,104 @@
+/* $Id */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <../lua51/lua.h>
+#include <../lua51/lauxlib.h>
+#include <../lua51/lualib.h>
+
+
+typedef struct LoadS {
+ const char *s;
+ size_t size;
+} LoadS;
+
+extern lua_State *Luas[];
+
+extern void make_table (lua_State *L, char *tab, char *getfunc, char*setfunc);
+
+extern int luac_main (int argc, char* argv[]);
+
+extern int luaopen_tex (lua_State *L);
+
+extern int luaopen_pdf (lua_State *L);
+
+#define LUA_TEXFILEHANDLE "TEXFILE*"
+
+extern int luaopen_texio (lua_State *L);
+
+extern int luaopen_lang (lua_State *L);
+
+extern void luatex_load_init (int s, LoadS *ls);
+
+extern lua_State *luatex_error (lua_State *L, int fatal);
+
+extern int luaopen_unicode (lua_State *L);
+extern int luaopen_zip (lua_State *L);
+extern int luaopen_lfs (lua_State *L);
+extern int luaopen_lpeg (lua_State *L);
+extern int luaopen_md5 (lua_State *L);
+extern int luaopen_zlib (lua_State *L);
+extern int luaopen_gzip (lua_State *L);
+extern int luaopen_ff (lua_State *L);
+
+extern int luaopen_img (lua_State *L);
+extern int luaopen_mp (lua_State *L);
+
+extern void open_oslibext (lua_State *L, int safer_option);
+
+extern void initfilecallbackids (int max);
+extern void setinputfilecallbackid (int n, int i) ;
+extern void setreadfilecallbackid (int n, int i) ;
+extern int getinputfilecallbackid (int n);
+extern int getreadfilecallbackid (int n);
+
+extern void lua_initialize (int ac, char **av);
+
+extern int luaopen_kpse (lua_State *L);
+
+extern int luaopen_callback (lua_State *L);
+
+extern int luaopen_lua (lua_State *L, int n, char *fname);
+
+extern int luaopen_stats (lua_State *L);
+
+extern int luaopen_font (lua_State *L);
+extern int font_to_lua (lua_State *L, int f) ;
+extern int font_from_lua (lua_State *L, int f) ; /* return is boolean */
+
+extern int luaopen_token (lua_State *L);
+extern char *tokenlist_to_cstring (int p , int inhibit_par, int *siz);
+extern void tokenlist_to_lua(lua_State *L, int p);
+extern void tokenlist_to_luastring(lua_State *L, int p) ;
+extern int tokenlist_from_lua(lua_State *L);
+
+extern void lua_nodelib_push (lua_State *L) ;
+extern int luaopen_node (lua_State *L);
+extern void nodelist_to_lua (lua_State *L, int n) ;
+extern int nodelist_from_lua (lua_State *L);
+
+extern int dimen_to_number (lua_State *L, char *s);
+
+extern void dump_luac_registers (void);
+
+extern void undump_luac_registers (void);
+
+
+extern void unhide_lua_table(lua_State *lua, char *name, int r);
+extern int hide_lua_table (lua_State *lua, char *name);
+
+extern void unhide_lua_value(lua_State *lua, char *name, char *item, int r);
+extern int hide_lua_value (lua_State *lua, char *name, char *item);
+
+typedef struct command_item_ {
+ char *cmd_name;
+ int command_offset;
+ char **commands;
+} command_item;
+
+extern command_item command_names[];
+extern int callback_callbacks_id;
+
+void luainterpreter (int n) ;
+
diff --git a/Build/source/texk/web2c/luatexdir/luatex.ch b/Build/source/texk/web2c/luatexdir/luatex.ch
new file mode 100644
index 00000000000..dd1c17e44af
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatex.ch
@@ -0,0 +1,2623 @@
+@x
+ \def\?##1]{\hbox to 1in{\hfil##1.\ }}
+ }
+@y
+ \def\?##1]{\hbox{Changes to \hbox to 1em{\hfil##1}.\ }}
+ }
+\let\maybe=\iftrue
+@z
+
+@x
+@d banner==luaTeX_banner
+@y
+@d luaTeXk_banner=='This is luaTeXk, Version ',luatex_version_string
+@#
+@d banner==luaTeX_banner
+@d banner_k==luaTeXk_banner
+@z
+
+@x
+Actually the heading shown here is not quite normal: The |program| line
+does not mention any |output| file, because \ph\ would ask the \TeX\ user
+to specify a file name if |output| were specified here.
+@^system dependencies@>
+@y
+@z
+
+@x
+program TEX; {all file names are defined dynamically}
+label @<Labels in the outer block@>@/
+@y
+program TEX; {all file names are defined dynamically}
+@z
+
+@x
+@ Three labels must be declared in the main program, so we give them
+symbolic names.
+
+@d start_of_TEX=1 {go here when \TeX's variables are initialized}
+@d end_of_TEX=9998 {go here to close files and terminate gracefully}
+@d final_end=9999 {this label marks the ending of the program}
+
+@<Labels in the out...@>=
+start_of_TEX@t\hskip-2pt@>, end_of_TEX@t\hskip-2pt@>,@,final_end;
+ {key control points}
+@y
+@ For Web2c, labels are not declared in the main program, but
+we still have to declare the symbolic names.
+
+@d start_of_TEX=1 {go here when \TeX's variables are initialized}
+@d final_end=9999 {this label marks the ending of the program}
+@z
+
+@x
+@d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging}
+@d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging}
+@y
+@d debug== ifdef('TEXMF_DEBUG')
+@d gubed== endif('TEXMF_DEBUG')
+@z
+
+@x
+@d stat==@{ {change this to `$\\{stat}\equiv\null$' when gathering
+ usage statistics}
+@d tats==@t@>@} {change this to `$\\{tats}\equiv\null$' when gathering
+ usage statistics}
+@y
+@d stat==ifdef('STAT')
+@d tats==endif('STAT')
+@z
+
+@x
+the codewords `$|init|\ldots|tini|$'.
+
+@d init== {change this to `$\\{init}\equiv\.{@@\{}$' in the production version}
+@d tini== {change this to `$\\{tini}\equiv\.{@@\}}$' in the production version}
+@y
+the codewords `$|init|\ldots|tini|$' for declarations and by the codewords
+`$|Init|\ldots|Tini|$' for executable code. This distinction is helpful for
+implementations where a run-time switch differentiates between the two
+versions of the program.
+
+@d init==ifdef('INITEX')
+@d tini==endif('INITEX')
+@d Init==init if ini_version then begin
+@d Tini==end;@+tini
+@f Init==begin
+@f Tini==end
+@z
+
+@x
+@!init @<Initialize table entries (done by \.{INITEX} only)@>@;@+tini
+@y
+@!Init @<Initialize table entries (done by \.{INITEX} only)@>@;@+Tini
+@z
+
+@x
+@<Constants...@>=
+@!buf_size=500; {maximum number of characters simultaneously present in
+ current lines of open files and in control sequences between
+ \.{\\csname} and \.{\\endcsname}; must not exceed |max_halfword|}
+@!error_line=72; {width of context lines on terminal error messages}
+@!half_error_line=42; {width of first lines of contexts in terminal
+ error messages; should be between 30 and |error_line-15|}
+@!max_print_line=79; {width of longest text lines output; should be at least 60}
+@!stack_size=200; {maximum number of simultaneous input sources}
+@!max_in_open=6; {maximum number of input files and error insertions that
+ can be going on simultaneously}
+@!param_size=60; {maximum number of simultaneous macro parameters}
+@!nest_size=40; {maximum number of semantic levels simultaneously active}
+@!max_strings=3000; {maximum number of strings; must not exceed |max_halfword|}
+@!string_vacancies=8000; {the minimum number of characters that should be
+ available for the user's control sequences and font names,
+ after \TeX's own error messages are stored}
+@!pool_size=32000; {maximum number of characters in strings, including all
+ error messages and help texts, and the names of all fonts and
+ control sequences; must exceed |string_vacancies| by the total
+ length of \TeX's own strings, which is currently about 23000}
+@!save_size=600; {space for saving values outside of current group; must be
+ at most |max_halfword|}
+@!dvi_buf_size=800; {size of the output buffer; must be a multiple of 8}
+@!expand_depth=10000; {limits recursive calls of the |expand| procedure}
+@!file_name_size=40; {file names shouldn't be longer than this}
+@!pool_name='TeXformats:TEX.POOL ';
+ {string of length |file_name_size|; tells where the string pool appears}
+@y
+@d file_name_size == max_halfword-1 { has to be big enough to force namelength into integer }
+@d ssup_error_line = 255
+@d ssup_max_strings == 262143
+{Larger values than 65536 cause the arrays consume much more memory.}
+
+@<Constants...@>=
+@!hash_offset=514; {smallest index in hash array, i.e., |hash_base| }
+ {Use |hash_offset=0| for compilers which cannot decrement pointers.}
+@!engine_name='luatex'; {the name of this engine}
+@#
+
+@!inf_main_memory = 2000000;
+@!sup_main_memory = 32000000;
+
+@!inf_max_strings = 100000;
+@!sup_max_strings = ssup_max_strings;
+@!inf_strings_free = 100;
+@!sup_strings_free = sup_max_strings;
+
+@!inf_buf_size = 500;
+@!sup_buf_size = 100000000;
+
+@!inf_nest_size = 40;
+@!sup_nest_size = 4000;
+
+@!inf_max_in_open = 6;
+@!sup_max_in_open = 127;
+
+@!inf_param_size = 60;
+@!sup_param_size = 6000;
+
+@!inf_save_size = 600;
+@!sup_save_size = 80000;
+
+@!inf_stack_size = 200;
+@!sup_stack_size = 30000;
+
+@!inf_dvi_buf_size = 800;
+@!sup_dvi_buf_size = 65536;
+
+@!inf_pool_size = 128000;
+@!sup_pool_size = 40000000;
+@!inf_pool_free = 1000;
+@!sup_pool_free = sup_pool_size;
+@!inf_string_vacancies = 8000;
+@!sup_string_vacancies = sup_pool_size - 23000;
+
+@!sup_hash_extra = sup_max_strings;
+@!inf_hash_extra = 0;
+
+@!sup_ocp_list_size = 1000000;
+@!inf_ocp_list_size = 1000;
+@!sup_ocp_buf_size = 100000000;
+@!inf_ocp_buf_size = 1000;
+@!sup_ocp_stack_size = 1000000;
+@!inf_ocp_stack_size = 1000;
+
+@!inf_expand_depth = 100;
+@!sup_expand_depth = 1000000;
+@z
+
+@x
+@d font_base=0 {smallest internal font number; must not be less
+ than |min_quarterword|}
+@d hash_size=2100 {maximum number of control sequences; it should be at most
+ about |(fix_mem_max-fix_mem_min)/10|}
+@d hash_prime=1777 {a prime number equal to about 85\pct! of |hash_size|}
+@y
+@d font_base=0 {smallest internal font number; must not be less
+ than |min_quarterword|}
+@d hash_size=65536 {maximum number of control sequences; it should be at most
+ about |(mem_max-mem_min)/10|}
+@d hash_prime=55711 {a prime number equal to about 85\pct! of |hash_size|}
+@z
+
+@x
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@y
+@z
+
+@x
+@d text_char == char {the data type of characters in text files}
+@y
+@d text_char == ASCII_code {the data type of characters in text files}
+@z
+
+@x
+@!nameoffile:packed array[1..file_name_size] of char;@;@/
+ {on some systems this may be a \&{record} variable}
+@y
+@!nameoffile:^packed_ASCII_code;
+@z
+
+@x
+@ The \ph\ compiler with which the present version of \TeX\ was prepared has
+extended the rules of \PASCAL\ in a very convenient way. To open file~|f|,
+we can write
+$$\vbox{\halign{#\hfil\qquad&#\hfil\cr
+|reset(f,@t\\{name}@>,'/O')|&for input;\cr
+|rewrite(f,@t\\{name}@>,'/O')|&for output.\cr}}$$
+The `\\{name}' parameter, which is of type `{\bf packed array
+$[\langle\\{any}\rangle]$ of \\{char}}', stands for the name of
+the external file that is being opened for input or output.
+Blank spaces that might appear in \\{name} are ignored.
+
+The `\.{/O}' parameter tells the operating system not to issue its own
+error messages if something goes wrong. If a file of the specified name
+cannot be found, or if such a file cannot be opened for some other reason
+(e.g., someone may already be trying to write the same file), we will have
+|@!erstat(f)<>0| after an unsuccessful |reset| or |rewrite|. This allows
+\TeX\ to undertake appropriate corrective action.
+@:PASCAL H}{\ph@>
+@^system dependencies@>
+
+\TeX's file-opening procedures return |false| if no file identified by
+|nameoffile| could be opened.
+
+@d reset_OK(#)==erstat(#)=0
+@d rewrite_OK(#)==erstat(#)=0
+
+@p function a_open_in(var f:alpha_file):boolean;
+ {open a text file for input}
+begin reset(f,nameoffile,'/O'); a_open_in:=reset_OK(f);
+end;
+@#
+function a_open_out(var f:alpha_file):boolean;
+ {open a text file for output}
+begin rewrite(f,nameoffile,'/O'); a_open_out:=rewrite_OK(f);
+end;
+@#
+function b_open_in(var f:byte_file):boolean;
+ {open a binary file for input}
+begin reset(f,nameoffile,'/O'); b_open_in:=reset_OK(f);
+end;
+@#
+function b_open_out(var f:byte_file):boolean;
+ {open a binary file for output}
+begin rewrite(f,nameoffile,'/O'); b_open_out:=rewrite_OK(f);
+end;
+@#
+function w_open_in(var f:word_file):boolean;
+ {open a word file for input}
+begin reset(f,nameoffile,'/O'); w_open_in:=reset_OK(f);
+end;
+@#
+function w_open_out(var f:word_file):boolean;
+ {open a word file for output}
+begin rewrite(f,nameoffile,'/O'); w_open_out:=rewrite_OK(f);
+end;
+@y
+@ All of the file opening functions are defined in C.
+@z
+
+@x
+@ Files can be closed with the \ph\ routine `|close(f)|', which
+@^system dependencies@>
+should be used when all input or output with respect to |f| has been completed.
+This makes |f| available to be opened again, if desired; and if |f| was used for
+output, the |close| operation makes the corresponding external file appear
+on the user's area, ready to be read.
+
+These procedures should not generate error messages if a file is
+being closed before it has been successfully opened.
+
+@p procedure a_close(var f:alpha_file); {close a text file}
+begin close(f);
+end;
+@#
+procedure b_close(var f:byte_file); {close a binary file}
+begin close(f);
+end;
+@#
+procedure w_close(var f:word_file); {close a word file}
+begin close(f);
+end;
+@y
+@ And all the file closing routines as well.
+@z
+
+@x
+@!buffer:array[0..buf_size] of packed_ASCII_code; {lines of characters being read}
+@y
+@!buffer:^packed_ASCII_code; {lines of characters being read}
+@z
+
+@x
+@p function input_ln(var f:alpha_file;@!bypass_eoln:boolean):boolean;
+ {inputs the next line or returns |false|}
+var last_nonblank:0..buf_size; {|last| with trailing blanks removed}
+begin if bypass_eoln then if not eof(f) then get(f);
+ {input the first character of the line into |f^|}
+last:=first; {cf.\ Matthew 19\thinspace:\thinspace30}
+if eof(f) then input_ln:=false
+else begin last_nonblank:=first;
+ while not eoln(f) do
+ begin if last>=max_buf_stack then
+ begin max_buf_stack:=last+1;
+ if max_buf_stack=buf_size then
+ @<Report overflow of the input buffer, and abort@>;
+ end;
+ buffer[last]:=f^; get(f); incr(last);
+ if buffer[last-1]<>" " then last_nonblank:=last;
+ end;
+ last:=last_nonblank; input_ln:=true;
+ end;
+end;
+@y
+We define |input_ln| in C, for efficiency. Nevertheless we quote the module
+`Report overflow of the input buffer, and abort' here in order to make
+\.{WEAVE} happy, since part of that module is needed by e-TeX.
+
+@p @{ @<Report overflow of the input buffer, and abort@> @}
+@z
+
+@x
+@<Glob...@>=
+@!term_in:alpha_file; {the terminal as an input file}
+@!term_out:alpha_file; {the terminal as an output file}
+@y
+@d term_in==stdin {the terminal as an input file}
+@d term_out==stdout {the terminal as an output file}
+
+@<Glob...@>=
+@!init
+@!ini_version:boolean; {are we \.{INITEX}?}
+@!dump_option:boolean; {was the dump name option used?}
+@!dump_line:boolean; {was a \.{\%\AM format} line seen?}
+tini@/
+@#
+@!bound_default:integer; {temporary for setup}
+@!bound_name:^char; {temporary for setup}
+@#
+@!error_line:integer; {width of context lines on terminal error messages}
+@!half_error_line:integer; {width of first lines of contexts in terminal
+ error messages; should be between 30 and |error_line-15|}
+@!max_print_line:integer;
+ {width of longest text lines output; should be at least 60}
+@!ocp_list_size:integer;
+@!ocp_buf_size:integer;
+@!ocp_stack_size:integer;
+@!max_strings:integer; {maximum number of strings; must not exceed |max_halfword|}
+@!strings_free:integer; {strings available after format loaded}
+@!string_vacancies:integer; {the minimum number of characters that should be
+ available for the user's control sequences and font names,
+ after \TeX's own error messages are stored}
+@!pool_size:integer; {maximum number of characters in strings, including all
+ error messages and help texts, and the names of all fonts and
+ control sequences; must exceed |string_vacancies| by the total
+ length of \TeX's own strings, which is currently about 23000}
+@!pool_free:integer;{pool space free after format loaded}
+@!font_k:integer; {loop variable for initialization}
+@!buf_size:integer; {maximum number of characters simultaneously present in
+ current lines of open files and in control sequences between
+ \.{\\csname} and \.{\\endcsname}; must not exceed |max_halfword|}
+@!stack_size:integer; {maximum number of simultaneous input sources}
+@!max_in_open:integer; {maximum number of input files and error insertions that
+ can be going on simultaneously}
+@!param_size:integer; {maximum number of simultaneous macro parameters}
+@!nest_size:integer; {maximum number of semantic levels simultaneously active}
+@!save_size:integer; {space for saving values outside of current group; must be
+ at most |max_halfword|}
+@!dvi_buf_size:integer; {size of the output buffer; must be a multiple of 8}
+@!expand_depth:integer; {limits recursive calls of the |expand| procedure}
+@!parsefirstlinep:cinttype; {parse the first line for options}
+@!filelineerrorstylep:cinttype; {format messages as file:line:error}
+@!haltonerrorp:cinttype; {stop at first error}
+@!quoted_filename:boolean; {current filename is quoted}
+{Variables for source specials}
+@!srcspecialsp : boolean;{Whether |src_specials| are enabled at all}
+@!insertsrcspecialauto : boolean;
+@!insertsrcspecialeverypar : boolean;
+@!insertsrcspecialeveryparend : boolean;
+@!insertsrcspecialeverycr : boolean;
+@!insertsrcspecialeverymath : boolean;
+@!insertsrcspecialeveryhbox : boolean;
+@!insertsrcspecialeveryvbox : boolean;
+@!insertsrcspecialeverydisplay : boolean;
+@z
+
+@x
+@ Here is how to open the terminal files
+in \ph. The `\.{/I}' switch suppresses the first |get|.
+@^system dependencies@>
+
+@d t_open_in==reset(term_in,'TTY:','/O/I') {open the terminal for text input}
+@d t_open_out==rewrite(term_out,'TTY:','/O') {open the terminal for text output}
+@y
+@ Here is how to open the terminal files. |t_open_out| does nothing.
+|t_open_in|, on the other hand, does the work of ``rescanning,'' or getting
+any command line arguments the user has provided. It's defined in C.
+
+@d t_open_out == {output already open for text output}
+@z
+
+@x
+these operations can be specified in \ph:
+@^system dependencies@>
+
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+@d clear_terminal == break_in(term_in,true) {clear the terminal input buffer}
+@y
+these operations can be specified with {\mc UNIX}. |update_terminal|
+does an |fflush|. |clear_terminal| is redefined
+to do nothing, since the user should control the terminal.
+@^system dependencies@>
+
+@d update_terminal == fflush (term_out)
+@d clear_terminal == do_nothing
+@z
+
+@x
+@<Report overflow of the input buffer, and abort@>=
+if format_ident=0 then
+ begin writeln(term_out,'Buffer size exceeded!'); goto final_end;
+@.Buffer size exceeded@>
+ end
+else
+ check_buffer_overflow(buf_size+10) { need a little bit more}
+@y
+@<Report overflow of the input buffer, and abort@>=
+ check_buffer_overflow(buf_size+10) { need a little bit more}
+@z
+
+@x
+@ The following program does the required initialization
+without retrieving a possible command line.
+It should be clear how to modify this routine to deal with command lines,
+if the system permits them.
+@^system dependencies@>
+
+@p function init_terminal:boolean; {gets the terminal input started}
+label exit;
+begin t_open_in;
+@y
+@ The following program does the required initialization.
+Iff anything has been specified on the command line, then |t_open_in|
+will return with |last > first|.
+@^system dependencies@>
+
+@p function init_terminal:boolean; {gets the terminal input started}
+label exit;
+begin t_open_in;
+if last > first then
+ begin loc := first;
+ while (loc < last) and (buffer[loc]=' ') do incr(loc);
+ if loc < last then
+ begin init_terminal := true; goto exit;
+ end;
+ end;
+@z
+
+@x
+ write(term_out,'! End of file on the terminal... why?');
+@y
+ writeln(term_out,'! End of file on the terminal... why?');
+@z
+
+@x
+@!str_pool:packed array[pool_pointer] of packed_ASCII_code; {the characters}
+@!str_start : array[str_number] of pool_pointer; {the starting pointers}
+@y
+@!str_pool: ^packed_ASCII_code; {the characters}
+@!str_start : ^pool_pointer; {the starting pointers}
+@z
+
+@x
+@p @!init function get_strings_started:boolean; {initializes the string pool,
+@y
+@p @t\4@>@<Declare additional routines for string recycling@>@/
+
+@!init function get_strings_started:boolean; {initializes the string pool,
+@z
+
+@x
+would like string @'32 to be the single character @'32 instead of the
+@y
+would like string @'32 to be printed as the single character @'32
+instead of the
+@z
+
+@x
+@!trick_buf:array[0..error_line] of packed_ASCII_code; {circular buffer for
+@y
+@!trick_buf:array[0..ssup_error_line] of packed_ASCII_code; {circular buffer for
+@z
+
+@x
+@d error_stop_mode=3 {stops at every opportunity to interact}
+@y
+@d error_stop_mode=3 {stops at every opportunity to interact}
+@d unspecified_mode=4 {extra value for command-line switch}
+@z
+
+@x
+ print_nl("! "); print(#);
+@y
+ if filelineerrorstylep then print_file_line
+ else print_nl("! ");
+ print(#);
+@z
+
+@x
+@!interaction:batch_mode..error_stop_mode; {current level of interaction}
+@y
+@!interaction:batch_mode..error_stop_mode; {current level of interaction}
+@!interactionoption:batch_mode..unspecified_mode; {set from command line}
+@z
+
+@x
+@ @<Set init...@>=interaction:=error_stop_mode;
+@y
+@ @<Set init...@>=if interactionoption=unspecified_mode then
+ interaction:=error_stop_mode
+else
+ interaction:=interactionoption;
+@z
+
+@x
+@<Error hand...@>=
+procedure jump_out;
+begin goto end_of_TEX;
+end;
+@y
+@d do_final_end==begin
+ update_terminal;
+ ready_already:=0;
+ if (history <> spotless) and (history <> warning_issued) then
+ uexit(1)
+ else
+ uexit(0);
+ end
+
+@<Error hand...@>=
+procedure jump_out;
+begin
+close_files_and_terminate;
+do_final_end;
+end;
+@z
+
+@x
+show_context;
+@y
+show_context;
+if (haltonerrorp) then begin
+ history:=fatal_error_stop; jump_out;
+end;
+@z
+
+@x
+line ready to be edited. But such an extension requires some system
+wizardry, so the present implementation simply types out the name of the
+file that should be
+edited and the relevant line number.
+@^system dependencies@>
+
+There is a secret `\.D' option available when the debugging routines haven't
+been commented~out.
+@^debugging@>
+@y
+line ready to be edited.
+We do this by calling the external procedure |calledit| with a pointer to
+the filename, its length, and the line number.
+However, here we just set up the variables that will be used as arguments,
+since we don't want to do the switch-to-editor until after TeX has closed
+its files.
+@^system dependencies@>
+
+There is a secret `\.D' option available when the debugging routines haven't
+been commented~out.
+@^debugging@>
+@d edit_file==input_stack[base_ptr]
+@z
+
+@x
+"E": if base_ptr>0 then
+ begin print_nl("You want to edit file ");
+@.You want to edit file x@>
+ slow_print(input_stack[base_ptr].name_field);
+ print(" at line "); print_int(line);
+ interaction:=scroll_mode; jump_out;
+@y
+"E": if base_ptr>0 then
+ begin edit_name_start:=str_start_macro(edit_file.name_field);
+ edit_name_length:=str_start_macro(edit_file.name_field+1) -
+ str_start_macro(edit_file.name_field);
+ edit_line:=line;
+ jump_out;
+@z
+
+@x
+|remainder|, holds the remainder after a division.
+
+@<Glob...@>=
+@y
+|remainder|, holds the remainder after a division.
+
+@d remainder==tex_remainder
+
+@<Glob...@>=
+@z
+
+@x
+@!glue_ratio=real; {one-word representation of a glue expansion factor}
+@y
+@z
+
+@x
+macros are simplified in the obvious way when |min_quarterword=0|.
+@^inner loop@>@^system dependencies@>
+
+@d qi(#)==#+min_quarterword
+ {to put an |eight_bits| item into a quarterword}
+@d qo(#)==#-min_quarterword
+ {to take an |eight_bits| item out of a quarterword}
+@d hi(#)==#+min_halfword
+ {to put a sixteen-bit item into a halfword}
+@d ho(#)==#-min_halfword
+ {to take a sixteen-bit item from a halfword}
+@y
+macros are simplified in the obvious way when |min_quarterword=0|.
+So they have been simplified here in the obvious way.
+@^inner loop@>@^system dependencies@>
+
+@d qi(#)==# {to put an |eight_bits| item into a quarterword}
+@d qo(#)==# {to take an |eight_bits| item from a quarterword}
+@d hi(#)==# {to put a sixteen-bit item into a halfword}
+@d ho(#)==# {to take a sixteen-bit item from a halfword}
+@z
+
+@x
+@!quarterword = min_quarterword..max_quarterword; {1/4 of a word}
+@!halfword=min_halfword..max_halfword; {1/2 of a word}
+@!two_choices = 1..2; {used when there are two variants in a record}
+@!four_choices = 1..4; {used when there are four variants in a record}
+@!two_halves = packed record@;@/
+ @!rh:halfword;
+ case two_choices of
+ 1: (@!lh:halfword);
+ 2: (@!b0:quarterword; @!b1:quarterword);
+ end;
+@!four_quarters = packed record@;@/
+ @!b0:quarterword;
+ @!b1:quarterword;
+ @!b2:quarterword;
+ @!b3:quarterword;
+ end;
+@!memory_word = record@;@/
+ case four_choices of
+ 1: (@!int:integer);
+ 2: (@!gr:glue_ratio);
+ 3: (@!hh:two_halves);
+ 4: (@!qqqq:four_quarters);
+ end;
+@y
+@!quarterword = min_quarterword..max_quarterword;
+@!halfword = min_halfword..max_halfword;
+@!two_choices = 1..2; {used when there are two variants in a record}
+@!four_choices = 1..4; {used when there are four variants in a record}
+@=#include "texmfmem.h";@>
+@z
+
+@x
+ if abs(vmem(p+glue_offset).int)<@'4000000 then print("?.?")
+ else if abs(g)>float_constant(20000) then
+@y
+ { The Unix |pc| folks removed this restriction with a remark that
+ invalid bit patterns were vanishingly improbable, so we follow
+ their example without really understanding it.
+ |if abs(vmem(p+glue_offset).int)<@'4000000 then print('?.?')|
+ |else| }
+ if fabs(g)>float_constant(20000) then
+@z
+
+@x
+begin if m>0 then
+ case m div (max_command+1) of
+ 0:print("vertical");
+ 1:print("horizontal");
+ 2:print("display math");
+ end
+else if m=0 then print("no")
+else case (-m) div (max_command+1) of
+ 0:print("internal vertical");
+ 1:print("restricted horizontal");
+ 2:print("math");
+ end;
+print(" mode");
+end;
+@y
+begin if m>0 then
+ case m div (max_command+1) of
+ 0:print("vertical mode");
+ 1:print("horizontal mode");
+ 2:print("display math mode");
+ end
+else if m=0 then print("no mode")
+else case (-m) div (max_command+1) of
+ 0:print("internal vertical mode");
+ 1:print("restricted horizontal mode");
+ 2:print("math mode");
+ end;
+end;
+
+procedure print_in_mode(@!m:integer); {prints the mode represented by |m|}
+begin if m>0 then
+ case m div (max_command+1) of
+ 0:print("' in vertical mode");
+ 1:print("' in horizontal mode");
+ 2:print("' in display math mode");
+ end
+else if m=0 then print("' in no mode")
+else case (-m) div (max_command+1) of
+ 0:print("' in internal vertical mode");
+ 1:print("' in restricted horizontal mode");
+ 2:print("' in math mode");
+ end;
+end;
+@z
+
+@x
+@!nest:array[0..nest_size] of list_state_record;
+@y
+@!nest:^list_state_record;
+@z
+
+@x
+local_par:=null; local_par_bool:=false;
+@<Start a new current page@>;
+@y
+local_par:=null; local_par_bool:=false;
+@/{The following piece of code is a copy of module 991:}
+page_contents:=empty; page_tail:=page_head; {|link(page_head):=null;|}@/
+last_glue:=max_halfword; last_penalty:=0; last_kern:=0;
+page_depth:=0; page_max_depth:=0;
+@z
+
+@x
+ print_int(nest[p].pg_field); print(" line");
+ if nest[p].pg_field<>1 then print_char("s");
+@y
+ print_int(nest[p].pg_field);
+ if nest[p].pg_field<>1 then print(" lines")
+ else print(" line");
+@z
+
+@x
+@d frozen_null_font=frozen_control_sequence+12
+ {permanent `\.{\\nullfont}'}
+@y
+@d frozen_special=frozen_control_sequence+12
+ {permanent `\.{\\special}'}
+@d frozen_null_font=frozen_control_sequence+13
+ {permanent `\.{\\nullfont}'}
+@z
+
+@x
+for k:=active_base to undefined_control_sequence-1 do
+ eqtb[k]:=eqtb[undefined_control_sequence];
+@y
+for k:=active_base to eqtb_top do
+ eqtb[k]:=eqtb[undefined_control_sequence];
+@z
+
+@x
+@ The following procedure, which is called just before \TeX\ initializes its
+input and output, establishes the initial values of the date and time.
+@^system dependencies@>
+Since standard \PASCAL\ cannot provide such information, something special
+is needed. The program here simply specifies July 4, 1776, at noon; but
+users probably want a better approximation to the truth.
+
+@p procedure fix_date_and_time;
+begin time:=12*60; {minutes since midnight}
+day:=4; {fourth day of the month}
+month:=7; {seventh month of the year}
+year:=1776; {Anno Domini}
+end;
+@y
+@ The following procedure, which is called just before \TeX\ initializes its
+input and output, establishes the initial values of the date and time.
+It calls a macro-defined |date_and_time| routine. |date_and_time|
+in turn is a C macro, which calls |get_date_and_time|, passing
+it the addresses of the day, month, etc., so they can be set by the
+routine. |get_date_and_time| also sets up interrupt catching if that
+is conditionally compiled in the C code.
+@^system dependencies@>
+
+@d fix_date_and_time==dateandtime(time,day,month,year)
+@z
+
+@x
+else if n<glue_base then @<Show equivalent |n|, in region 1 or 2@>
+@y
+else if (n<glue_base) or ((n>eqtb_size)and(n<=eqtb_top)) then
+ @<Show equivalent |n|, in region 1 or 2@>
+@z
+
+@x
+@!eqtb:array[active_base..eqtb_size] of memory_word;
+@y
+@!zeqtb:^memory_word;
+@z
+
+@x
+@!hash: array[hash_base..undefined_control_sequence-1] of two_halves;
+ {the hash table}
+@!hash_used:pointer; {allocation pointer for |hash|}
+@y
+@!hash: ^two_halves; {the hash table}
+@!yhash: ^two_halves; {auxiliary pointer for freeing hash}
+@!hash_used:pointer; {allocation pointer for |hash|}
+@!hash_extra:pointer; {|hash_extra=hash| above |eqtb_size|}
+@!hash_top:pointer; {maximum of the hash array}
+@!eqtb_top:pointer; {maximum of the |eqtb|}
+@!hash_high:pointer; {pointer to next high hash location}
+@z
+
+@x
+next(hash_base):=0; text(hash_base):=0;
+for k:=hash_base+1 to undefined_control_sequence-1 do hash[k]:=hash[hash_base];
+@y
+@z
+
+@x
+hash_used:=frozen_control_sequence; {nothing is used}
+@y
+hash_used:=frozen_control_sequence; {nothing is used}
+hash_high:=0;
+@z
+
+@x
+@ @<Insert a new control...@>=
+begin if text(p)>0 then
+ begin repeat if hash_is_full then overflow("hash size",hash_size);
+@:TeX capacity exceeded hash size}{\quad hash size@>
+ decr(hash_used);
+ until text(hash_used)=0; {search for an empty location in |hash|}
+ next(p):=hash_used; p:=hash_used;
+ end;
+@y
+@ @<Insert a new control...@>=
+begin if text(p)>0 then
+ begin if hash_high<hash_extra then
+ begin incr(hash_high);
+ next(p):=hash_high+eqtb_size; p:=hash_high+eqtb_size;
+ end
+ else begin
+ repeat if hash_is_full then overflow("hash size",hash_size+hash_extra);
+@:TeX capacity exceeded hash size}{\quad hash size@>
+ decr(hash_used);
+ until text(hash_used)=0; {search for an empty location in |hash|}
+ next(p):=hash_used; p:=hash_used;
+ end;
+ end;
+@z
+
+@x
+else if p>=undefined_control_sequence then print_esc("IMPOSSIBLE.")
+@y
+else if ((p>=undefined_control_sequence)and(p<=eqtb_size))or(p>eqtb_top) then
+ print_esc("IMPOSSIBLE.")
+@z
+
+@x
+else if (text(p)<0)or(text(p)>=str_ptr) then print_esc("NONEXISTENT.")
+@y
+else if (text(p)>=str_ptr) then print_esc("NONEXISTENT.")
+@z
+
+@x
+@!save_stack : array[0..save_size] of memory_word;
+@y
+@!save_stack : ^memory_word;
+@z
+
+@x
+if p<int_base then
+@y
+if (p<int_base)or(p>eqtb_size) then
+@z
+
+@x
+if cs_token_flag+undefined_control_sequence>max_halfword then bad:=21;
+@y
+if cs_token_flag+eqtb_size+hash_extra>max_halfword then bad:=21;
+if (hash_offset<0)or(hash_offset>hash_base) then bad:=42;
+@z
+
+@x
+@!input_stack : array[0..stack_size] of in_state_record;
+@y
+@!input_stack : ^in_state_record;
+@z
+
+@x
+@!input_file : array[1..max_in_open] of alpha_file;
+@!line : integer; {current line number in the current source file}
+@!line_stack : array[1..max_in_open] of integer;
+@y
+@!input_file : ^alpha_file;
+@!line : integer; {current line number in the current source file}
+@!line_stack : ^integer;
+@!source_filename_stack : ^str_number;
+@!full_source_filename_stack : ^str_number;
+@z
+
+@x
+ begin print_nl("Runaway ");
+@.Runaway...@>
+ case scanner_status of
+ defining: begin print("definition"); p:=def_ref;
+ end;
+ matching: begin print("argument"); p:=temp_token_head;
+ end;
+ aligning: begin print("preamble"); p:=hold_token_head;
+ end;
+ absorbing: begin print("text"); p:=def_ref;
+ end;
+ end; {there are no other cases}
+@y
+ begin
+@.Runaway...@>
+ case scanner_status of
+ defining: begin print_nl("Runaway definition"); p:=def_ref;
+ end;
+ matching: begin print_nl("Runaway argument"); p:=temp_token_head;
+ end;
+ aligning: begin print_nl("Runaway preamble"); p:=hold_token_head;
+ end;
+ absorbing: begin print_nl("Runaway text"); p:=def_ref;
+ end;
+ end; {there are no other cases}
+@z
+
+@x
+@!param_stack:array [0..param_size] of pointer;
+ {token list pointers for parameters}
+@y
+@!param_stack: ^pointer;
+ {token list pointers for parameters}
+@z
+
+@x
+incr(in_open); push_input; index:=in_open;
+@y
+incr(in_open); push_input; index:=in_open;
+source_filename_stack[index]:=0;full_source_filename_stack[index]:=0;
+@z
+
+@x
+begin input_ptr:=0; max_in_stack:=0;
+@y
+begin input_ptr:=0; max_in_stack:=0;
+source_filename_stack[0]:=0;full_source_filename_stack[0]:=0;
+@z
+
+@x
+if_eof_code: begin scan_four_bit_int; b:=(read_open[cur_val]=closed);
+ end;
+@y
+if_eof_code: begin scan_four_bit_int_or_18;
+ if cur_val=18 then b:=not shellenabledp
+ else b:=(read_open[cur_val]=closed);
+ end;
+@z
+
+@x
+@ The file names we shall deal with for illustrative purposes have the
+following structure: If the name contains `\.>' or `\.:', the file area
+consists of all characters up to and including the final such character;
+otherwise the file area is null. If the remaining file name contains
+`\..', the file extension consists of all such characters from the first
+remaining `\..' to the end, otherwise the file extension is null.
+@y
+@ The file names we shall deal with have the
+following structure: If the name contains `\./' or `\.:'
+(for Amiga only), the file area
+consists of all characters up to and including the final such character;
+otherwise the file area is null. If the remaining file name contains
+`\..', the file extension consists of all such characters from the last
+`\..' to the end, otherwise the file extension is null.
+@z
+
+@x
+@!area_delimiter:pool_pointer; {the most recent `\.>' or `\.:', if any}
+@!ext_delimiter:pool_pointer; {the relevant `\..', if any}
+@y
+@!area_delimiter:pool_pointer; {the most recent `\./', if any}
+@!ext_delimiter:pool_pointer; {the most recent `\..', if any}
+@z
+
+@x
+@d TEX_area=="TeXinputs:"
+@.TeXinputs@>
+@d TEX_font_area=="TeXfonts:"
+@.TeXfonts@>
+@y
+In C, the default paths are specified separately.
+@z
+
+@x
+begin area_delimiter:=0; ext_delimiter:=0;
+@y
+begin area_delimiter:=0; ext_delimiter:=0; quoted_filename:=false;
+@z
+
+@x
+begin if c=" " then more_name:=false
+@y
+begin if (c=" ") and stop_at_space and (not quoted_filename) then
+ more_name:=false
+else if c="""" then begin
+ quoted_filename:=not quoted_filename;
+ more_name:=true;
+ end
+@z
+
+@x
+ if (c=">")or(c=":") then
+@y
+ if ISDIRSEP(c) then
+@z
+
+@x
+ else if (c=".")and(ext_delimiter=0) then ext_delimiter:=cur_length;
+@y
+ else if c="." then ext_delimiter:=cur_length;
+@z
+
+@x
+@ The third.
+@^system dependencies@>
+
+@p procedure end_name;
+@y
+@ The third.
+@^system dependencies@>
+If a string is already in the string pool, the function
+|slow_make_string| does not create a new string but returns this string
+number, thus saving string space. Because of this new property of the
+returned string number it is not possible to apply |flush_string| to
+these strings.
+
+@p procedure end_name;
+var temp_str: str_number; {result of file name cache lookups}
+@!j,@!s,@!t: pool_pointer; {running indices}
+@!must_quote:boolean; {whether we need to quote a string}
+@z
+
+@x
+@:TeX capacity exceeded number of strings}{\quad number of strings@>
+@y
+@:TeX capacity exceeded number of strings}{\quad number of strings@>
+str_room(6); {Room for quotes, if needed.}
+{add quotes if needed}
+if area_delimiter<>0 then begin
+ {maybe quote |cur_area|}
+ must_quote:=false;
+ s:=str_start_macro(str_ptr);
+ t:=str_start_macro(str_ptr)+area_delimiter;
+ j:=s;
+ while (not must_quote) and (j<t) do begin
+ must_quote:=str_pool[j]=" "; incr(j);
+ end;
+ if must_quote then begin
+ for j:=pool_ptr-1 downto t do str_pool[j+2]:=str_pool[j];
+ str_pool[t+1]:="""";
+ for j:=t-1 downto s do str_pool[j+1]:=str_pool[j];
+ str_pool[s]:="""";
+ if ext_delimiter<>0 then ext_delimiter:=ext_delimiter+2;
+ area_delimiter:=area_delimiter+2;
+ pool_ptr:=pool_ptr+2;
+ end;
+ end;
+{maybe quote |cur_name|}
+s:=str_start_macro(str_ptr)+area_delimiter;
+if ext_delimiter=0 then t:=pool_ptr else t:=str_start_macro(str_ptr)+ext_delimiter-1;
+must_quote:=false;
+j:=s;
+while (not must_quote) and (j<t) do begin
+ must_quote:=str_pool[j]=" "; incr(j);
+ end;
+if must_quote then begin
+ for j:=pool_ptr-1 downto t do str_pool[j+2]:=str_pool[j];
+ str_pool[t+1]:="""";
+ for j:=t-1 downto s do str_pool[j+1]:=str_pool[j];
+ str_pool[s]:="""";
+ if ext_delimiter<>0 then ext_delimiter:=ext_delimiter+2;
+ pool_ptr:=pool_ptr+2;
+ end;
+if ext_delimiter<>0 then begin
+ {maybe quote |cur_ext|}
+ s:=str_start_macro(str_ptr)+ext_delimiter-1;
+ t:=pool_ptr;
+ must_quote:=false;
+ j:=s;
+ while (not must_quote) and (j<t) do begin
+ must_quote:=str_pool[j]=" "; incr(j);
+ end;
+ if must_quote then begin
+ str_pool[t+1]:="""";
+ for j:=t-1 downto s do str_pool[j+1]:=str_pool[j];
+ str_pool[s]:="""";
+ pool_ptr:=pool_ptr+2;
+ end;
+ end;
+@z
+
+@x
+ str_start_macro(str_ptr+1):=str_start_macro(str_ptr)+area_delimiter; incr(str_ptr);
+ end;
+if ext_delimiter=0 then
+ begin cur_ext:=""; cur_name:=make_string;
+@y
+ str_start_macro(str_ptr+1):=str_start_macro(str_ptr)+area_delimiter; incr(str_ptr);
+ temp_str:=search_string(cur_area);
+ if temp_str>0 then
+ begin cur_area:=temp_str;
+ decr(str_ptr); {no |flush_string|, |pool_ptr| will be wrong!}
+ for j:=str_start_macro(str_ptr+1) to pool_ptr-1 do
+ begin str_pool[j-area_delimiter]:=str_pool[j];
+ end;
+ pool_ptr:=pool_ptr-area_delimiter; {update |pool_ptr|}
+ end;
+ end;
+if ext_delimiter=0 then
+ begin cur_ext:=""; cur_name:=slow_make_string;
+@z
+
+@x
+else begin cur_name:=str_ptr;
+ str_start_macro(str_ptr+1):=str_start_macro(str_ptr)+ext_delimiter-area_delimiter-1;
+ incr(str_ptr); cur_ext:=make_string;
+@y
+else begin cur_name:=str_ptr;
+ str_start_macro(str_ptr+1):=str_start_macro(str_ptr)+ext_delimiter-area_delimiter-1;
+ incr(str_ptr); cur_ext:=make_string;
+ decr(str_ptr); {undo extension string to look at name part}
+ temp_str:=search_string(cur_name);
+ if temp_str>0 then
+ begin cur_name:=temp_str;
+ decr(str_ptr); {no |flush_string|, |pool_ptr| will be wrong!}
+ for j:=str_start_macro(str_ptr+1) to pool_ptr-1 do
+ begin str_pool[j-ext_delimiter+area_delimiter+1]:=str_pool[j];
+ end;
+ pool_ptr:=pool_ptr-ext_delimiter+area_delimiter+1; {update |pool_ptr|}
+ end;
+ cur_ext:=slow_make_string; {remake extension string}
+@z
+
+@x
+begin slow_print(a); slow_print(n); slow_print(e);
+@y
+var must_quote: boolean; {whether to quote the filename}
+@!j:pool_pointer; {index into |str_pool|}
+begin
+must_quote:=false;
+if a<>0 then begin
+ j:=str_start_macro(a);
+ while (not must_quote) and (j<str_start_macro(a+1)) do begin
+ must_quote:=str_pool[j]=" "; incr(j);
+ end;
+end;
+if n<>0 then begin
+ j:=str_start_macro(n);
+ while (not must_quote) and (j<str_start_macro(n+1)) do begin
+ must_quote:=str_pool[j]=" "; incr(j);
+ end;
+end;
+if e<>0 then begin
+ j:=str_start_macro(e);
+ while (not must_quote) and (j<str_start_macro(e+1)) do begin
+ must_quote:=str_pool[j]=" "; incr(j);
+ end;
+end;
+{FIXME: Alternative is to assume that any filename that has to be quoted has
+ at least one quoted component...if we pick this, a number of insertions
+ of |print_file_name| should go away.
+|must_quote|:=((|a|<>0)and(|str_pool|[|str_start|[|a|]]=""""))or
+ ((|n|<>0)and(|str_pool|[|str_start|[|n|]]=""""))or
+ ((|e|<>0)and(|str_pool|[|str_start|[|e|]]=""""));}
+if must_quote then print_char("""");
+if a<>0 then
+ for j:=str_start_macro(a) to str_start_macro(a+1)-1 do
+ if so(str_pool[j])<>"""" then
+ print(so(str_pool[j]));
+if n<>0 then
+ for j:=str_start_macro(n) to str_start_macro(n+1)-1 do
+ if so(str_pool[j])<>"""" then
+ print(so(str_pool[j]));
+if e<>0 then
+ for j:=str_start_macro(e) to str_start_macro(e+1)-1 do
+ if so(str_pool[j])<>"""" then
+ print(so(str_pool[j]));
+if must_quote then print_char("""");
+@z
+
+@x
+@d append_to_name(#)==begin c:=#; incr(k);
+ if k<=file_name_size then nameoffile[k]:=xchr[c];
+ end
+@y
+@d append_to_name(#)==begin c:=#; if not (c="""") then begin incr(k);
+ if k<=file_name_size then nameoffile[k]:=xchr[c];
+ end end
+@z
+
+@x
+for j:=str_start_macro(a) to str_start_macro(a+1)-1 do append_to_name(so(str_pool[j]));
+@y
+if nameoffile then libcfree (nameoffile);
+nameoffile:= xmallocarray (packed_ASCII_code, length(a)+length(n)+length(e)+1);
+for j:=str_start_macro(a) to str_start_macro(a+1)-1 do append_to_name(so(str_pool[j]));
+@z
+
+@x
+for k:=namelength+1 to file_name_size do nameoffile[k]:=' ';
+@y
+nameoffile[namelength+1]:=0;
+@z
+
+@x
+@d format_default_length=20 {length of the |TEX_format_default| string}
+@d format_area_length=11 {length of its area part}
+@d format_ext_length=4 {length of its `\.{.fmt}' part}
+@y
+Under {\mc UNIX} we don't give the area part, instead depending
+on the path searching that will happen during file opening. Also, the
+length will be set in the main program.
+
+@d format_area_length=0 {length of its area part}
+@d format_ext_length=4 {length of its `\.{.fmt}' part}
+@z
+
+@x
+@!TEX_format_default:packed array[1..format_default_length] of char;
+
+@ @<Set init...@>=
+TEX_format_default:='TeXformats:plain.fmt';
+@y
+@!format_default_length: integer;
+@!TEX_format_default: ^char;
+
+@ We set the name of the default format file and the length of that name
+in C, instead of Pascal, since we want them to depend on the name of the
+program.
+@z
+
+@x
+for j:=1 to n do append_to_name(TEX_format_default[j]);
+@y
+if nameoffile then libcfree (nameoffile);
+nameoffile := xmallocarray (packed_ASCII_code, n+(b-a+1)+format_ext_length+1);
+for j:=1 to n do append_to_name(TEX_format_default[j]);
+@z
+
+@x
+for k:=namelength+1 to file_name_size do nameoffile[k]:=' ';
+@y
+nameoffile[namelength+1]:=0;
+@z
+
+@x
+ pack_buffered_name(0,loc,j-1); {try first without the system file area}
+ if w_open_in(fmt_file) then goto found;
+ pack_buffered_name(format_area_length,loc,j-1);
+ {now try the system format file area}
+ if w_open_in(fmt_file) then goto found;
+@y
+ pack_buffered_name(0,loc,j-1); {Kpathsea does everything}
+ if w_open_in(fmt_file) then goto found;
+@z
+
+@x
+ wterm_ln('Sorry, I can''t find that format;',' will try PLAIN.');
+@y
+ wterm ('Sorry, I can''t find the format `');
+ fputs (stringcast(nameoffile + 1), stdout);
+ wterm ('''; will try `');
+ fputs (TEX_format_default + 1, stdout);
+ wterm_ln ('''.');
+@z
+
+@x
+ wterm_ln('I can''t find the PLAIN format file!');
+@.I can't find PLAIN...@>
+@y
+ wterm ('I can''t find the format file `');
+ fputs (TEX_format_default + 1, stdout);
+ wterm_ln ('''!');
+@.I can't find the format...@>
+@z
+
+@x
+@p function make_name_string:str_number;
+var k:1..file_name_size; {index into |nameoffile|}
+begin if (pool_ptr+namelength>pool_size)or(str_ptr=max_strings)or
+ (cur_length>0) then
+ make_name_string:="?"
+else begin for k:=1 to namelength do append_char(nameoffile[k]);
+ make_name_string:=make_string;
+ end;
+@y
+@p function make_name_string:str_number;
+var k:1..file_name_size; {index into |nameoffile|}
+save_area_delimiter, save_ext_delimiter: pool_pointer;
+save_name_in_progress, save_stop_at_space: boolean;
+begin if (pool_ptr+namelength>pool_size)or(str_ptr=max_strings)or
+ (cur_length>0) then
+ make_name_string:="?"
+else begin for k:=1 to namelength do append_char(nameoffile[k]);
+ make_name_string:=make_string;
+ {At this point we also set |cur_name|, |cur_ext|, and |cur_area| to
+ match the contents of |nameoffile|.}
+ save_area_delimiter:=area_delimiter;
+ save_ext_delimiter:=ext_delimiter;
+ save_name_in_progress:=name_in_progress;
+ save_stop_at_space:=stop_at_space;
+ name_in_progress:=true;
+ begin_name;
+ stop_at_space:=false;
+ k:=1;
+ while (k<=namelength)and(more_name(nameoffile[k])) do
+ incr(k);
+ stop_at_space:=save_stop_at_space;
+ end_name;
+ name_in_progress:=save_name_in_progress;
+ area_delimiter:=save_area_delimiter;
+ ext_delimiter:=save_ext_delimiter;
+ end;
+@z
+
+@x
+ if not more_name(cur_chr) then goto done;
+@y
+ {If |cur_chr| is a space and we're not scanning a token list, check
+ whether we're at the end of the buffer. Otherwise we end up adding
+ spurious spaces to file names in some cases.}
+ if (cur_chr=" ") and (state<>token_list) and (loc>limit) then goto done;
+ if not more_name(cur_chr) then goto done;
+@z
+
+@x
+var k:0..buf_size; {index into |buffer|}
+@y
+var k:0..buf_size; {index into |buffer|}
+@!saved_cur_name:str_number; {to catch empty terminal input}
+@z
+
+@x
+if e=".tex" then show_context;
+@y
+if (e=".tex") or (e="") then show_context;
+@z
+
+@x
+clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
+if cur_ext="" then cur_ext:=e;
+@y
+saved_cur_name:=cur_name;
+clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
+if cur_ext="" then cur_ext:=e;
+if length(cur_name)=0 then cur_name:=saved_cur_name;
+@z
+
+@x
+@d ensure_dvi_open==if output_file_name=0 then
+@y
+@d log_name == texmf_log_name
+@d ensure_dvi_open==if output_file_name=0 then
+@z
+
+@x
+@!months:packed array [1..36] of char; {abbreviations of month names}
+@y
+@!months:^char;
+@z
+
+@x
+if job_name=0 then job_name:="texput";
+@.texput@>
+@y
+if job_name=0 then job_name:=getjobname("texput");
+@.texput@>
+pack_job_name(".fls");
+recorder_change_filename(stringcast(nameoffile+1));
+@z
+
+@x
+begin wlog(banner);
+@y
+begin if srcspecialsp or filelineerrorstylep or parsefirstlinep
+then
+ wlog(banner_k)
+else
+ wlog(banner);
+@z
+
+@x
+slow_print(format_ident); print(" ");
+@y
+wlog(versionstring);
+slow_print(format_ident); print(" ");
+@z
+
+@x
+months:='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
+@y
+months := ' JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
+@z
+
+@x
+end
+@y
+if shellenabledp then begin
+ wlog_cr;
+ wlog('\write18 enabled.')
+ end;
+if srcspecialsp then begin
+ wlog_cr;
+ wlog(' Source specials enabled.')
+ end;
+if filelineerrorstylep then begin
+ wlog_cr;
+ wlog(' file:line:error style messages enabled.')
+ end;
+if parsefirstlinep then begin
+ wlog_cr;
+ wlog(' %&-line parsing enabled.');
+ end;
+end
+@z
+
+@x
+ prompt_file_name("input file name",".tex");
+@y
+ prompt_file_name("input file name","");
+@z
+
+@x
+name:=a_make_name_string(cur_file);
+@y
+name:=a_make_name_string(cur_file);
+source_filename_stack[in_open]:=name;
+full_source_filename_stack[in_open]:=makefullnamestring;
+if name=str_ptr-1 then {we can try to conserve string pool space now}
+ begin temp_str:=search_string(name);
+ if temp_str>0 then
+ begin name:=temp_str; flush_string;
+ end;
+ end;
+@z
+
+@x
+ begin job_name:=cur_name; open_log_file;
+@y
+ begin job_name:=getjobname(cur_name); open_log_file;
+@z
+
+@x
+if name=str_ptr-1 then {we can conserve string pool space now}
+ begin flush_string; name:=cur_name;
+ end;
+@y
+@z
+
+@x
+@!ocp_list_info:array[ocp_list_index] of memory_word;
+ {the big collection of ocp list data}
+@!ocp_listmem_ptr:ocp_list_index; {first unused word of |ocp_list_info|}
+@!ocp_listmem_run_ptr:ocp_list_index; {temp unused word of |ocp_list_info|}
+@!ocp_lstack_info:array[ocp_lstack_index] of memory_word;
+ {the big collection of ocp lstack data}
+@!ocp_lstackmem_ptr:ocp_lstack_index; {first unused word of |ocp_lstack_info|}
+@!ocp_lstackmem_run_ptr:ocp_lstack_index; {temp unused word of |ocp_lstack_info|}
+@!ocp_list_ptr:internal_ocp_list_number; {largest internal ocp list number in use}
+@!ocp_list_list:array[internal_ocp_list_number] of ocp_list_index;
+@y
+@!ocp_list_info:^memory_word;
+ {the big collection of ocp list data}
+@!ocp_listmem_ptr:ocp_list_index; {first unused word of |ocp_list_info|}
+@!ocp_listmem_run_ptr:ocp_list_index; {temp unused word of |ocp_list_info|}
+@!ocp_lstack_info:^memory_word;
+ {the big collection of ocp lstack data}
+@!ocp_lstackmem_ptr:ocp_lstack_index; {first unused word of |ocp_lstack_info|}
+@!ocp_lstackmem_run_ptr:ocp_lstack_index; {temp unused word of |ocp_lstack_info|}
+@!ocp_list_ptr:internal_ocp_list_number; {largest internal ocp list number in use}
+@!ocp_list_list:^ocp_list_index;
+@z
+
+@x
+@!dvi_buf:array[dvi_index] of real_eight_bits; {buffer for \.{DVI} output}
+@!half_buf:dvi_index; {half of |dvi_buf_size|}
+@!dvi_limit:dvi_index; {end of the current half buffer}
+@!dvi_ptr:dvi_index; {the next available buffer address}
+@y
+@!dvi_buf:^real_eight_bits; {buffer for \.{DVI} output}
+@!half_buf:integer; {half of |dvi_buf_size|}
+@!dvi_limit:integer; {end of the current half buffer}
+@!dvi_ptr:integer; {the next available buffer address}
+@z
+
+@x
+@p procedure write_dvi(@!a,@!b:dvi_index);
+var k:dvi_index;
+begin for k:=a to b do write(dvi_file,dvi_buf[k]);
+end;
+@y
+In C, we use a macro to call |fwrite| or |write| directly, writing all
+the bytes in one shot. Much better even than writing four
+bytes at a time.
+@z
+
+@x
+ old_setting:=selector; selector:=new_string;
+@y
+if output_comment then
+ begin l:=strlen(output_comment); dvi_out(l);
+ for s:=0 to l-1 do dvi_out(output_comment[s]);
+ end
+else begin {the default code is unchanged}
+ old_setting:=selector; selector:=new_string;
+@z
+
+@x
+ pool_ptr:=str_start_macro(str_ptr); {flush the current string}
+@y
+ pool_ptr:=str_start_macro(str_ptr); {flush the current string}
+end;
+@z
+
+@x
+dvi_out(eop); incr(total_pages); cur_s:=-1;
+@y
+dvi_out(eop); incr(total_pages); cur_s:=-1;
+ifdef ('IPC')
+if ipcon>0 then
+ begin if dvi_limit=half_buf then
+ begin write_dvi(half_buf, dvi_buf_size-1);
+ flush_dvi;
+ dvi_gone:=dvi_gone+half_buf;
+ end;
+ if dvi_ptr>0 then
+ begin write_dvi(0, dvi_ptr-1);
+ flush_dvi;
+ dvi_offset:=dvi_offset+dvi_ptr; dvi_gone:=dvi_gone+dvi_ptr;
+ end;
+ dvi_ptr:=0; dvi_limit:=dvi_buf_size;
+ ipcpage(dvi_gone);
+ end;
+endif ('IPC');
+@z
+
+@x
+ k:=4+((dvi_buf_size-dvi_ptr) mod 4); {the number of 223's}
+@y
+ifdef ('IPC')
+ k:=7-((3+dvi_offset+dvi_ptr) mod 4); {the number of 223's}
+endif ('IPC')
+ifndef ('IPC')
+ k:=4+((dvi_buf_size-dvi_ptr) mod 4); {the number of 223's}
+endifn ('IPC')
+@z
+
+@x
+ print_nl("Output written on "); slow_print(output_file_name);
+@y
+ print_nl("Output written on "); print_file_name(0, output_file_name, 0);
+@z
+
+@x
+ print(" ("); print_int(total_pages); print(" page");
+ if total_pages<>1 then print_char("s");
+@y
+ print(" ("); print_int(total_pages);
+ if total_pages<>1 then print(" pages")
+ else print(" page");
+@z
+
+@x
+@<Append character |cur_chr|...@>=
+continue: adjust_space_factor;@/
+@y
+@<Append character |cur_chr|...@>=
+if ((head=tail) and (mode>0)) then begin
+ if (insertsrcspecialauto) then append_src_special;
+end;
+continue: adjust_space_factor;@/
+@z
+
+@x
+print("' in "); print_mode(mode);
+@y
+print_in_mode(mode);
+@z
+
+@x
+if indented then begin
+ p:=new_null_box; box_dir(p):=par_direction;
+ width(p):=par_indent;@+
+ tail_append(p);
+@y
+if indented then begin
+ p:=new_null_box; box_dir(p):=par_direction;
+ width(p):=par_indent;@+
+ tail_append(p);
+ if (insertsrcspecialeverypar) then insert_src_special;@+
+@z
+
+@x
+begin print_err("Extra "); print_esc("endcsname");
+@.Extra \\endcsname@>
+help1("I'm ignoring this, since I wasn't doing a \csname.");
+@y
+begin
+if cur_chr = 10 then
+begin
+ print_err("Extra "); print_esc("endmubyte");
+@.Extra \\endmubyte@>
+ help1("I'm ignoring this, since I wasn't doing a \mubyte.");
+end else begin
+ print_err("Extra "); print_esc("endcsname");
+@.Extra \\endcsname@>
+ help1("I'm ignoring this, since I wasn't doing a \csname.");
+end;
+@z
+
+@x
+if every_math<>null then begin_token_list(every_math,every_math_text);
+@y
+if (insertsrcspecialeverymath) then insert_src_special;
+if every_math<>null then begin_token_list(every_math,every_math_text);
+@z
+
+@x
+ if every_vbox<>null then begin_token_list(every_vbox,every_vbox_text);
+@y
+ if (insertsrcspecialeveryvbox) then insert_src_special;
+ if every_vbox<>null then begin_token_list(every_vbox,every_vbox_text);
+@z
+
+@x
+if (cur_cs=0)or(cur_cs>frozen_control_sequence) then
+@y
+if (cur_cs=0)or(cur_cs>eqtb_top)or
+ ((cur_cs>frozen_control_sequence)and(cur_cs<=eqtb_size)) then
+@z
+
+@x
+@!flushable_string:str_number; {string not yet referenced}
+@y
+@z
+
+@x
+interaction:=cur_chr;
+@y
+interaction:=cur_chr;
+if interaction = batch_mode
+then kpsemaketexdiscarderrors := 1
+else kpsemaketexdiscarderrors := 0;
+@z
+
+@x
+slow_print(s); update_terminal;
+@y
+print(s); update_terminal;
+@z
+
+@x
+begin print_err(""); slow_print(s);
+@y
+begin print_err(""); print(s);
+@z
+
+@x
+format_ident:=" (INITEX)";
+@y
+if ini_version then format_ident:=" (INITEX)";
+@z
+
+@x
+@!w: four_quarters; {four ASCII codes}
+@y
+@!format_engine: ^packed_ASCII_code;
+@z
+
+@x
+@!w: four_quarters; {four ASCII codes}
+@y
+@!format_engine: ^packed_ASCII_code;
+@z
+
+@x
+@d dump_wd(#)==begin fmt_file^:=#; put(fmt_file);@+end
+@d dump_int(#)==begin fmt_file^.int:=#; put(fmt_file);@+end
+@d dump_hh(#)==begin fmt_file^.hh:=#; put(fmt_file);@+end
+@d dump_qqqq(#)==begin fmt_file^.qqqq:=#; put(fmt_file);@+end
+@y
+@z
+
+@x
+@d undump_wd(#)==begin get(fmt_file); #:=fmt_file^;@+end
+@d undump_int(#)==begin get(fmt_file); #:=fmt_file^.int;@+end
+@d undump_hh(#)==begin get(fmt_file); #:=fmt_file^.hh;@+end
+@d undump_qqqq(#)==begin get(fmt_file); #:=fmt_file^.qqqq;@+end
+@y
+@z
+
+@x
+@d undump_size_end_end(#)==too_small(#)@+else undump_end_end
+@y
+@d format_debug_end(#)==
+ writeln (stderr, ' = ', #);
+ end;
+@d format_debug(#)==
+ if debug_format_file then begin
+ write (stderr, 'fmtdebug:', #);
+ format_debug_end
+@d undump_size_end_end(#)==
+ too_small(#)@+else format_debug (#)(x); undump_end_end
+@z
+
+@x
+dump_int(@$);@/
+@y
+dump_int(@"57325458); {Web2C \TeX's magic constant: "W2TX"}
+{Align engine to 4 bytes with one or more trailing NUL}
+x:=strlen(engine_name);
+format_engine:=xmallocarray(packed_ASCII_code,x+4);
+strcpy(stringcast(format_engine), stringcast(engine_name));
+for k:=x to x+3 do format_engine[k]:=0;
+x:=x+4-(x mod 4);
+dump_int(x);dump_things(format_engine[0], x);
+libcfree(format_engine);@/
+dump_int(@$);@/
+dump_int(max_halfword);@/
+dump_int(hash_high);
+@z
+
+@x
+x:=fmt_file^.int;
+if x<>@$ then goto bad_fmt; {check that strings are the same}
+@y
+@+Init
+libcfree(str_pool); libcfree(str_start);
+libcfree(yhash); libcfree(zeqtb); libcfree(fixmem); libcfree(varmem);
+@+Tini
+undump_int(x);
+format_debug('format magic number')(x);
+if x<>@"57325458 then goto bad_fmt; {not a format file}
+undump_int(x);
+format_debug('engine name size')(x);
+if (x<0) or (x>256) then goto bad_fmt; {corrupted format file}
+format_engine:=xmallocarray(packed_ASCII_code, x);
+undump_things(format_engine[0], x);
+format_engine[x-1]:=0; {force string termination, just in case}
+if strcmp(stringcast(engine_name), stringcast(format_engine)) then
+ begin wake_up_terminal;
+ wterm_ln('---! ', stringcast(nameoffile+1), ' was written by ', format_engine);
+ libcfree(format_engine);
+ goto bad_fmt;
+end;
+libcfree(format_engine);
+undump_int(x);
+format_debug('string pool checksum')(x);
+if x<>@$ then begin {check that strings are the same}
+ wake_up_terminal;
+ wterm_ln('---! ', stringcast(nameoffile+1), ' was written by an older version');
+ goto bad_fmt;
+end;
+undump_int(x);
+if x<>max_halfword then goto bad_fmt; {check |max_halfword|}
+undump_int(hash_high);
+ if (hash_high<0)or(hash_high>sup_hash_extra) then goto bad_fmt;
+ if hash_extra<hash_high then hash_extra:=hash_high;
+ eqtb_top:=eqtb_size+hash_extra;
+ if hash_extra=0 then hash_top:=undefined_control_sequence else
+ hash_top:=eqtb_top;
+ yhash:=xmallocarray(two_halves,1+hash_top-hash_offset);
+ hash:=yhash - hash_offset;
+ next(hash_base):=0; text(hash_base):=0;
+ for x:=hash_base+1 to hash_top do hash[x]:=hash[hash_base];
+ zeqtb:=xmallocarray (memory_word,eqtb_top+1);
+ eqtb:=zeqtb;
+
+ eq_type(undefined_control_sequence):=undefined_cs;
+ equiv(undefined_control_sequence):=null;
+ eq_level(undefined_control_sequence):=level_zero;
+ for x:=eqtb_size+1 to eqtb_top do
+ eqtb[x]:=eqtb[undefined_control_sequence];
+@z
+
+@x
+dump_int(str_ptr);
+for k:=string_offset to str_ptr do dump_int(str_start_macro(k));
+k:=0;
+while k+4<pool_ptr do
+ begin dump_four_ASCII; k:=k+4;
+ end;
+k:=pool_ptr-4; dump_four_ASCII;
+@y
+dump_int((str_ptr-string_offset));
+dump_things(str_start[0], (str_ptr-string_offset)+1);
+dump_things(str_pool[0], pool_ptr);
+@z
+
+@x
+undump_size(0)(pool_size)('string pool size')(pool_ptr);
+undump_size(0)(max_strings)('max strings')(str_ptr);
+for k:=string_offset to str_ptr do undump(0)(pool_ptr)(str_start_macro(k));
+k:=0;
+while k+4<pool_ptr do
+ begin undump_four_ASCII; k:=k+4;
+ end;
+k:=pool_ptr-4; undump_four_ASCII;
+@y
+undump_size(0)(sup_pool_size-pool_free)('string pool size')(pool_ptr);
+if pool_size<pool_ptr+pool_free then
+ pool_size:=pool_ptr+pool_free;
+undump_size(0)(sup_max_strings-strings_free)('sup strings')(str_ptr);@/
+if max_strings<str_ptr+strings_free then
+ max_strings:=str_ptr+strings_free;
+str_start:=xmallocarray(pool_pointer, max_strings);
+str_ptr:=str_ptr + string_offset;
+undump_checked_things(0, pool_ptr, str_start[0], (str_ptr-string_offset)+1);@/
+str_pool:=xmallocarray(packed_ASCII_code, pool_size);
+undump_things(str_pool[0], pool_ptr);
+@z
+
+@x
+for k:=fix_mem_min to fix_mem_end do dump_wd(mem(k));
+@y
+dump_things(mem(fix_mem_min), fix_mem_end-fix_mem_min+1);
+@z
+
+@x
+for k:=fix_mem_min to fix_mem_end do undump_wd(mem(k));
+@y
+undump_things (mem(fix_mem_min), fix_mem_end-fix_mem_min+1);
+@z
+
+@x
+undump(hash_base)(frozen_control_sequence)(par_loc);
+par_token:=cs_token_flag+par_loc;@/
+undump(hash_base)(frozen_control_sequence)(write_loc);@/
+@y
+undump(hash_base)(hash_top)(par_loc);
+par_token:=cs_token_flag+par_loc;@/
+undump(hash_base)(hash_top)(write_loc);@/
+@z
+
+@x
+while k<l do
+ begin dump_wd(eqtb[k]); incr(k);
+ end;
+@y
+dump_things(eqtb[k], l-k);
+@z
+
+@x
+while k<l do
+ begin dump_wd(eqtb[k]); incr(k);
+ end;
+@y
+dump_things(eqtb[k], l-k);
+@z
+
+@x
+k:=j+1; dump_int(k-l);
+until k>eqtb_size
+@y
+k:=j+1; dump_int(k-l);
+until k>eqtb_size;
+if hash_high>0 then dump_things(eqtb[eqtb_size+1],hash_high);
+ {dump |hash_extra| part}
+@z
+
+@x
+for j:=k to k+x-1 do undump_wd(eqtb[j]);
+@y
+undump_things(eqtb[k], x);
+@z
+
+@x
+until k>eqtb_size
+@y
+until k>eqtb_size;
+if hash_high>0 then undump_things(eqtb[eqtb_size+1],hash_high);
+ {undump |hash_extra| part}
+@z
+
+@x
+dump_int(hash_used); cs_count:=frozen_control_sequence-1-hash_used;
+@y
+dump_int(hash_used); cs_count:=frozen_control_sequence-1-hash_used+hash_high;
+@z
+
+@x
+for p:=hash_used+1 to undefined_control_sequence-1 do dump_hh(hash[p]);
+@y
+dump_things(hash[hash_used+1], undefined_control_sequence-1-hash_used);
+if hash_high>0 then dump_things(hash[eqtb_size+1], hash_high);
+@z
+
+@x
+for p:=hash_used+1 to undefined_control_sequence-1 do undump_hh(hash[p]);
+@y
+undump_things (hash[hash_used+1], undefined_control_sequence-1-hash_used);
+if debug_format_file then begin
+ print_csnames (hash_base, undefined_control_sequence - 1);
+end;
+if hash_high > 0 then begin
+ undump_things (hash[eqtb_size+1], hash_high);
+ if debug_format_file then begin
+ print_csnames (eqtb_size + 1, hash_high - (eqtb_size + 1));
+ end;
+end;
+@z
+
+@x
+@ @<Undump the array info for internal font number |k|@>=
+begin undump_font(k);@/
+end
+@y
+@ @<Undump the array info for internal font number |k|@>=
+begin undump_font(k);@/
+end;
+make_pdftex_banner
+@z
+
+@x
+for k:=0 to active_max_ptr-1 do dump_wd(active_info[k]);
+if active_max_ptr>0 then begin
+ print_ln; print_int(active_max_ptr); print(" words of active ocps");
+ end;
+
+@ @<Undump the active ocp information@>=
+undump_size(0)(active_mem_size)('active start point')(active_min_ptr);
+undump_size(0)(active_mem_size)('active mem size')(active_max_ptr);
+for k:=0 to active_max_ptr-1 do undump_wd(active_info[k]);
+@y
+if active_max_ptr>0 then
+ dump_things(active_info[0], active_max_ptr);
+if active_max_ptr>0 then begin
+ print_ln; print_int(active_max_ptr); print(" words of active ocps");
+ end;
+
+@ @<Undump the active ocp information@>=
+undump_size(0)(active_mem_size)('active start point')(active_min_ptr);
+undump_size(0)(active_mem_size)('active mem size')(active_max_ptr);
+if active_max_ptr>0 then
+ undump_things(active_info[0], active_max_ptr);
+@z
+
+@x
+@ @<Dump the ocp list information@>=
+dump_int(ocp_listmem_ptr);
+for k:=0 to ocp_listmem_ptr-1 do dump_wd(ocp_list_info[k]);
+dump_int(ocp_list_ptr);
+for k:=null_ocp_list to ocp_list_ptr do begin
+ dump_int(ocp_list_list[k]);
+ if null_ocp_list<>ocp_list_ptr then begin
+ print_nl("\ocplist");
+ print_esc(ocp_list_id_text(k));
+ print_char("=");
+ print_ocp_list(ocp_list_list[k]);
+ end;
+ end;
+dump_int(ocp_lstackmem_ptr);
+for k:=0 to ocp_lstackmem_ptr-1 do dump_wd(ocp_lstack_info[k])
+@y
+@ @<Dump the ocp list information@>=
+dump_int(ocp_listmem_ptr);
+dump_things(ocp_list_info[0], ocp_listmem_ptr);
+dump_int(ocp_list_ptr);
+dump_things(ocp_list_list[null_ocp_list], ocp_list_ptr+1-null_ocp_list);
+for k:=null_ocp_list to ocp_list_ptr do begin
+ if null_ocp_list<>ocp_list_ptr then begin
+ print_nl("\ocplist");
+ print_esc(ocp_list_id_text(k));
+ print_char("=");
+ print_ocp_list(ocp_list_list[k]);
+ end;
+ end;
+dump_int(ocp_lstackmem_ptr);
+dump_things(ocp_lstack_info[0], ocp_lstackmem_ptr)
+@z
+
+@x
+@ @<Undump the ocp list information@>=
+undump_size(1)(1000000)('ocp list mem size')(ocp_listmem_ptr);
+for k:=0 to ocp_listmem_ptr-1 do undump_wd(ocp_list_info[k]);
+undump_size(ocp_list_base)(ocp_list_biggest)('ocp list max')(ocp_list_ptr);
+for k:=null_ocp_list to ocp_list_ptr do
+ undump_int(ocp_list_list[k]);
+undump_size(1)(1000000)('ocp lstack mem size')(ocp_lstackmem_ptr);
+for k:=0 to ocp_lstackmem_ptr-1 do undump_wd(ocp_lstack_info[k])
+@y
+@ @<Undump the ocp list information@>=
+undump_size(1)(1000000)('ocp list mem size')(ocp_listmem_ptr);
+undump_things(ocp_list_info[0], ocp_listmem_ptr);
+undump_size(0)(1000000)('ocp list max')(ocp_list_ptr);
+undump_things(ocp_list_list[null_ocp_list], ocp_list_ptr+1-null_ocp_list);
+undump_size(0)(1000000)('ocp lstack mem size')(ocp_lstackmem_ptr);
+undump_things(ocp_lstack_info[0], ocp_lstackmem_ptr)
+@z
+
+@x
+undump(batch_mode)(error_stop_mode)(interaction);
+@y
+undump(batch_mode)(error_stop_mode)(interaction);
+if interactionoption<>unspecified_mode then interaction:=interactionoption;
+@z
+
+@x
+if (x<>69069)or eof(fmt_file) then goto bad_fmt
+@y
+if x<>69069 then goto bad_fmt
+@z
+
+@x
+print(" (preloaded format="); print(job_name); print_char(" ");
+@y
+print(" (format="); print(job_name); print_char(" ");
+@z
+
+@x
+@p begin @!{|start_here|}
+@y
+@d const_chk(#)==begin if # < inf_@&# then # := inf_@&# else
+ if # > sup_@&# then # := sup_@&# end
+
+{|setup_bound_var| stuff duplicated in \.{mf.ch}.}
+@d setup_bound_var(#)==bound_default:=#; setup_bound_var_end
+@d setup_bound_var_end(#)==bound_name:=#; setup_bound_var_end_end
+@d setup_bound_var_end_end(#)==if luainit>0 then begin
+ get_lua_number('texconfig',bound_name,addressof(#));
+ if #=0 then #:=bound_default;
+ end
+ else
+ setupboundvariable(addressof(#), bound_name, bound_default);
+
+@p procedure main_body;
+begin @!{|start_here|}
+
+{Bounds that may be set from the configuration file. We want the user to
+ be able to specify the names with underscores, but \.{TANGLE} removes
+ underscores, so we're stuck giving the names twice, once as a string,
+ once as the identifier. How ugly.}
+
+ setup_bound_var (100000)('pool_size')(pool_size);
+ setup_bound_var (75000)('string_vacancies')(string_vacancies);
+ setup_bound_var (5000)('pool_free')(pool_free); {min pool avail after fmt}
+ setup_bound_var (15000)('max_strings')(max_strings);
+ setup_bound_var (100)('strings_free')(strings_free);
+ setup_bound_var (3000)('buf_size')(buf_size);
+ setup_bound_var (50)('nest_size')(nest_size);
+ setup_bound_var (15)('max_in_open')(max_in_open);
+ setup_bound_var (60)('param_size')(param_size);
+ setup_bound_var (4000)('save_size')(save_size);
+ setup_bound_var (300)('stack_size')(stack_size);
+ setup_bound_var (16384)('dvi_buf_size')(dvi_buf_size);
+ setup_bound_var (79)('error_line')(error_line);
+ setup_bound_var (50)('half_error_line')(half_error_line);
+ setup_bound_var (79)('max_print_line')(max_print_line);
+ setup_bound_var(1000)('ocp_list_size')(ocp_list_size);
+ setup_bound_var(1000)('ocp_buf_size')(ocp_buf_size);
+ setup_bound_var(1000)('ocp_stack_size')(ocp_stack_size);
+ setup_bound_var (0)('hash_extra')(hash_extra);
+ setup_bound_var (72)('pk_dpi')(pk_dpi);
+ setup_bound_var (10000)('expand_depth')(expand_depth);
+
+ {Check other constants against their sup and inf.}
+ const_chk (buf_size);
+ const_chk (nest_size);
+ const_chk (max_in_open);
+ const_chk (param_size);
+ const_chk (save_size);
+ const_chk (stack_size);
+ const_chk (dvi_buf_size);
+ const_chk (pool_size);
+ const_chk (string_vacancies);
+ const_chk (pool_free);
+ const_chk (max_strings);
+ const_chk (strings_free);
+ const_chk (hash_extra);
+ const_chk (obj_tab_size);
+ const_chk (pdf_mem_size);
+ const_chk (dest_names_size);
+ const_chk (pk_dpi);
+ if error_line > ssup_error_line then error_line := ssup_error_line;
+
+ {array memory allocation}
+ buffer:=xmallocarray (packed_ASCII_code, buf_size);
+ nest:=xmallocarray (list_state_record, nest_size);
+ save_stack:=xmallocarray (memory_word, save_size);
+ input_stack:=xmallocarray (in_state_record, stack_size);
+ input_file:=xmallocarray (alpha_file, max_in_open);
+ input_file_callback_id:=xmallocarray (integer, max_in_open);
+ line_stack:=xmallocarray (integer, max_in_open);
+ eof_seen:=xmallocarray (boolean, max_in_open);
+ grp_stack:=xmallocarray (save_pointer, max_in_open);
+ if_stack:=xmallocarray (pointer, max_in_open);
+ source_filename_stack:=xmallocarray (str_number, max_in_open);
+ full_source_filename_stack:=xmallocarray (str_number, max_in_open);
+ param_stack:=xmallocarray (halfword, param_size);
+ dvi_buf:=xmallocarray (real_eight_bits, dvi_buf_size);
+ ocp_list_info:=xmallocarray (memory_word, ocp_list_size);
+ memset(ocp_list_info,0,sizeof(memory_word)* ocp_list_size);
+ ocp_lstack_info:=xmallocarray (memory_word, ocp_list_size);
+ memset(ocp_lstack_info,0,sizeof(memory_word)* ocp_list_size);
+ ocp_list_list:=xmallocarray (ocp_list_index, ocp_list_size);
+ otp_init_input_buf:=xmallocarray (quarterword, ocp_buf_size);
+ otp_input_buf:=xmallocarray (quarterword, ocp_buf_size);
+ otp_output_buf:=xmallocarray (quarterword, ocp_buf_size);
+ otp_stack_buf:=xmallocarray (quarterword, ocp_stack_size);
+ otp_calcs:=xmallocarray (halfword, ocp_stack_size);
+ otp_states:=xmallocarray (halfword, ocp_stack_size);
+ obj_tab:=xmallocarray (obj_entry, inf_obj_tab_size); {will grow dynamically}
+ obj_offset(0):=0;
+ pdf_mem:=xmallocarray (integer, inf_pdf_mem_size); {will grow dynamically}
+ dest_names:=xmallocarray (dest_name_entry, inf_dest_names_size); {will grow dynamically}
+ pdf_op_buf:=xmallocarray (real_eight_bits, pdf_op_buf_size);
+ pdf_os_buf:=xmallocarray (real_eight_bits, inf_pdf_os_buf_size); {will grow dynamically}
+ pdf_os_objnum:=xmallocarray (integer, pdf_os_max_objs);
+ pdf_os_objoff:=xmallocarray (integer, pdf_os_max_objs);
+@+Init
+ fixmem:=xmallocarray (smemory_word, fix_mem_init+1);
+ memset (voidcast(fixmem), 0, (fix_mem_init+1)*sizeof(smemory_word));
+ fix_mem_min:=0;
+ fix_mem_max:=fix_mem_init;
+
+ eqtb_top := eqtb_size+hash_extra;
+ if hash_extra=0 then hash_top:=undefined_control_sequence else
+ hash_top:=eqtb_top;
+ yhash:=xmallocarray (two_halves,1+hash_top-hash_offset);
+ hash:=yhash - hash_offset; {Some compilers require |hash_offset=0|}
+ next(hash_base):=0; text(hash_base):=0;
+ for hash_used:=hash_base+1 to hash_top do hash[hash_used]:=hash[hash_base];
+ zeqtb:=xmallocarray (memory_word, eqtb_top);
+ eqtb:=zeqtb;
+
+ str_start:=xmallocarray (pool_pointer, max_strings);
+ str_pool:=xmallocarray (packed_ASCII_code, pool_size);
+@+Tini
+@z
+
+@x
+@!init if not get_strings_started then goto final_end;
+init_prim; {call |primitive| for each primitive}
+init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr; fix_date_and_time;
+tini@/
+@y
+@!Init if not get_strings_started then goto final_end;
+init_prim; {call |primitive| for each primitive}
+init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr; fix_date_and_time;
+Tini@/
+@z
+
+@x
+end_of_TEX: close_files_and_terminate;
+final_end: ready_already:=0;
+end.
+@y
+close_files_and_terminate;
+final_end: do_final_end;
+end {|main_body|};
+@z
+
+@x
+ wterm(banner);
+@y
+ if srcspecialsp or filelineerrorstylep or parsefirstlinep then
+ wterm(banner_k)
+ else
+ wterm(banner);
+@z
+
+@x
+ if format_ident=0 then wterm_ln(' (no format preloaded)')
+ else begin slow_print(format_ident); print_ln;
+ end;
+@y
+ wterm(versionstring);
+ if format_ident>0 then slow_print(format_ident);
+ print_ln;
+ if shellenabledp then begin
+ wterm_ln(' \write18 enabled.')
+ end;
+ if srcspecialsp then begin
+ wterm_ln(' Source specials enabled.')
+ end;
+ if filelineerrorstylep then begin
+ wterm_ln(' file:line:error style messages enabled.')
+ end;
+ if parsefirstlinep then begin
+ wterm_ln(' %&-line parsing enabled.')
+ end;
+@z
+
+
+
+@x
+ slow_print(log_name); print_char(".");
+@y
+ print_file_name(0, log_name, 0); print_char(".");
+@z
+
+@x
+ end;
+@y
+ end;
+print_ln;
+if (edit_name_start<>0) and (interaction>batch_mode) then
+ calledit(str_pool,edit_name_start,edit_name_length,edit_line);
+@z
+
+@x
+ wlog_ln(' ',cs_count:1,' multiletter control sequences out of ',
+ hash_size:1);@/
+@y
+ wlog_ln(' ',cs_count:1,' multiletter control sequences out of ',
+ hash_size:1, '+', hash_extra:1);@/
+@z
+
+@x
+ begin @!init for i:=0 to biggest_used_mark do begin
+@y
+ begin @!Init for i:=0 to biggest_used_mark do begin
+@z
+
+@x
+ store_fmt_file; return;@+tini@/
+@y
+ store_fmt_file; return;@+Tini@/
+@z
+
+@x
+if (format_ident=0)or(buffer[loc]="&") then
+@y
+if (format_ident=0)or(buffer[loc]="&")or dump_line then
+@z
+
+@x
+ w_close(fmt_file);
+@y
+ w_close(fmt_file);
+ eqtb:=zeqtb;
+@z
+
+@x
+fix_date_and_time;@/
+@y
+fix_date_and_time;@/
+@!init
+make_pdftex_banner;
+tini@/
+@z
+
+@x
+ begin goto breakpoint;@\ {go to every label at least once}
+ breakpoint: m:=0; @{'BREAKPOINT'@}@\
+ end
+@y
+ abort {do something to cause a core dump}
+@z
+
+@x
+primitive("special",extension,special_node);@/
+@y
+primitive("special",extension,special_node);@/
+text(frozen_special):="special"; eqtb[frozen_special]:=eqtb[cur_val];@/
+@z
+
+@x
+ else if cur_val>15 then cur_val:=16;
+@y
+ else if (cur_val>15) and (cur_val <> 18) then cur_val:=16;
+@z
+
+@x
+begin @<Expand macros in the token list
+@y
+@!d:integer; {number of characters in incomplete current string}
+@!clobbered:boolean; {system string is ok?}
+begin @<Expand macros in the token list
+@z
+
+@x
+if write_open[j] then selector:=j
+@y
+if j=18 then selector := new_string
+else if write_open[j] then selector:=j
+@z
+
+@x
+flush_list(def_ref); selector:=old_setting;
+@y
+flush_list(def_ref);
+if j=18 then
+ begin if (tracing_online<=0) then
+ selector:=log_only {Show what we're doing in the log file.}
+ else selector:=term_and_log; {Show what we're doing.}
+ {If the log file isn't open yet, we can only send output to the terminal.
+ Calling |open_log_file| from here seems to result in bad data in the log.}
+ if not log_opened then selector:=term_only;
+ print_nl("system(");
+ for d:=0 to cur_length-1 do
+ begin {|print| gives up if passed |str_ptr|, so do it by hand.}
+ print(so(str_pool[str_start_macro(str_ptr)+d])); {N.B.: not |print_char|}
+ end;
+ print(")...");
+ if shellenabledp then
+ begin str_room(1); append_char(0); {Append a null byte to the expansion.}
+ clobbered:=false;
+ for d:=0 to cur_length-1 do {Convert to external character set.}
+ begin str_pool[str_start_macro(str_ptr)+d]:=xchr[str_pool[str_start_macro(str_ptr)+d]];
+ if (str_pool[str_start_macro(str_ptr)+d]=null_code)
+ and (d<cur_length-1) then clobbered:=true;
+ {minimal checking: NUL not allowed in argument string of |system|()}
+ end;
+ if clobbered then print("clobbered")
+ else begin {We have the string; run system(3). We don't have anything
+ reasonable to do with the return status, unfortunately discard it.}
+ system(stringcast(addressof(str_pool[str_start_macro(str_ptr)])));
+ print("executed");
+ end;
+ end
+ else begin print("disabled");
+ end;
+ print_char("."); print_nl(""); print_ln;
+ pool_ptr:=str_start_macro(str_ptr); {erase the string}
+end;
+selector:=old_setting;
+@z
+
+@x
+@!eof_seen : array[1..max_in_open] of boolean; {has eof been seen?}
+@y
+@!eof_seen : ^boolean; {has eof been seen?}
+@z
+
+@x
+@!grp_stack : array[0..max_in_open] of save_pointer; {initial |cur_boundary|}
+@!if_stack : array[0..max_in_open] of pointer; {initial |cond_ptr|}
+@y
+@!grp_stack : ^save_pointer; {initial |cur_boundary|}
+@!if_stack : ^pointer; {initial |cond_ptr|}
+@z
+
+@x
+@!otp_init_input_buf:array[0..20000] of quarterword;
+
+@!otp_input_start:halfword;
+@!otp_input_last:halfword;
+@!otp_input_end:halfword;
+@!otp_input_buf:array[0..20000] of quarterword;
+
+@!otp_output_end:halfword;
+@!otp_output_buf:array[0..20000] of quarterword;
+
+@!otp_stack_used:halfword;
+@!otp_stack_last:halfword;
+@!otp_stack_new:halfword;
+@!otp_stack_buf:array[0..1000] of quarterword;
+
+@!otp_pc:halfword;
+
+@!otp_calc_ptr:halfword;
+@!otp_calcs:array[0..1000] of halfword;
+@!otp_state_ptr:halfword;
+@!otp_states:array[0..1000] of halfword;
+@y
+@!otp_init_input_buf:^quarterword;
+
+@!otp_input_start:halfword;
+@!otp_input_last:halfword;
+@!otp_input_end:halfword;
+@!otp_input_buf:^quarterword;
+
+@!otp_output_end:halfword;
+@!otp_output_buf:^quarterword;
+
+@!otp_stack_used:halfword;
+@!otp_stack_last:halfword;
+@!otp_stack_new:halfword;
+@!otp_stack_buf:^quarterword;
+
+@!otp_pc:halfword;
+
+@!otp_calc_ptr:halfword;
+@!otp_calcs:^halfword;
+@!otp_state_ptr:halfword;
+@!otp_states:^halfword;
+@z
+
+@x
+@* \[54] System-dependent changes.
+@y
+@* \[54/web2c] System-dependent changes for Web2c.
+Here are extra variables for Web2c. (This numbering of the
+system-dependent section allows easy integration of Web2c and e-\TeX, etc.)
+@^<system dependencies@>
+
+@<Glob...@>=
+@!edit_name_start: pool_pointer; {where the filename to switch to starts}
+@!edit_name_length,@!edit_line: integer; {what line to start editing at}
+@!ipcon: cinttype; {level of IPC action, 0 for none [default]}
+@!stop_at_space: boolean; {whether |more_name| returns false for space}
+
+@ The |edit_name_start| will be set to point into |str_pool| somewhere after
+its beginning if \TeX\ is supposed to switch to an editor on exit.
+
+@<Set init...@>=
+edit_name_start:=0;
+stop_at_space:=true;
+
+@ These are used when we regenerate the representation of the first 256
+strings.
+
+@<Global...@> =
+@!save_str_ptr: str_number;
+@!save_pool_ptr: pool_pointer;
+@!shellenabledp: cinttype;
+@!output_comment: ^char;
+@!k,l: 0..255; {used by `Make the first 256 strings', etc.}
+
+@ When debugging a macro package, it can be useful to see the exact
+control sequence names in the format file. For example, if ten new
+csnames appear, it's nice to know what they are, to help pinpoint where
+they came from. (This isn't a truly ``basic'' printing procedure, but
+that's a convenient module in which to put it.)
+
+@<Basic printing procedures@> =
+procedure print_csnames (hstart:integer; hfinish:integer);
+var c,h:integer;
+begin
+ writeln(stderr, 'fmtdebug:csnames from ', hstart, ' to ', hfinish, ':');
+ for h := hstart to hfinish do begin
+ if text(h) > 0 then begin {if have anything at this position}
+ for c := str_start_macro(text(h)) to str_start_macro(text(h) + 1) - 1
+ do begin
+ putbyte(str_pool[c], stderr); {print the characters}
+ end;
+ writeln(stderr, '|');
+ end;
+ end;
+end;
+
+@ Are we printing extra info as we read the format file?
+
+@<Glob...@> =
+@!debug_format_file: boolean;
+
+
+@ A helper for printing file:line:error style messages. Look for a
+filename in |full_source_filename_stack|, and if we fail to find
+one fall back on the non-file:line:error style.
+
+@<Basic print...@>=
+procedure print_file_line;
+var level: 0..max_in_open;
+begin
+ level:=in_open;
+ while (level>0) and (full_source_filename_stack[level]=0) do
+ decr(level);
+ if level=0 then
+ print_nl("! ")
+ else begin
+ print_nl (""); print (full_source_filename_stack[level]); print (":");
+ if level=in_open then print_int (line)
+ else print_int (line_stack[index+1-(in_open-level)]);
+ print (": ");
+ end;
+end;
+
+@ To be able to determine whether \.{\\write18} is enabled from within
+\TeX\ we also implement \.{\\eof18}. We sort of cheat by having an
+additional route |scan_four_bit_int_or_18| which is the same as
+|scan_four_bit_int| except it also accepts the value 18.
+
+@<Declare procedures that scan restricted classes of integers@>=
+procedure scan_four_bit_int_or_18;
+begin scan_int;
+if (cur_val<0)or((cur_val>15)and(cur_val<>18)) then
+ begin print_err("Bad number");
+@.Bad number@>
+ help2("Since I expected to read a number between 0 and 15,")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+
+@* \[54/web2c-string] The string recycling routines. \TeX{} uses 2
+upto 4 {\it new\/} strings when scanning a filename in an \.{\\input},
+\.{\\openin}, or \.{\\openout} operation. These strings are normally
+lost because the reference to them are not saved after finishing the
+operation. |search_string| searches through the string pool for the
+given string and returns either 0 or the found string number.
+
+@<Declare additional routines for string recycling@>=
+function search_string(@!search:str_number):str_number;
+label found;
+var result: str_number;
+@!s: str_number; {running index}
+@!len: integer; {length of searched string}
+begin result:=0; len:=length(search);
+if len=0 then {trivial case}
+ begin result:=""; goto found;
+ end
+else begin s:=search-1; {start search with newest string below |s|; |search>1|!}
+ while s>=string_offset do {first |string_offset| strings depend on implementation!!}
+ begin if length(s)=len then
+ if str_eq_str(s,search) then
+ begin result:=s; goto found;
+ end;
+ decr(s);
+ end;
+ end;
+found:search_string:=result;
+end;
+
+@ The following routine is a variant of |make_string|. It searches
+the whole string pool for a string equal to the string currently built
+and returns a found string. Otherwise a new string is created and
+returned. Be cautious, you can not apply |flush_string| to a replaced
+string!
+
+@<Declare additional routines for string recycling@>=
+function slow_make_string : str_number;
+label exit;
+var s: str_number; {result of |search_string|}
+@!t: str_number; {new string}
+begin t:=make_string; s:=search_string(t);
+if s>0 then
+ begin flush_string; slow_make_string:=s; return;
+ end;
+slow_make_string:=t;
+exit:end;
+
+
+@* \[54] System-dependent changes.
+@z
+
+
+@x
+@* \[55] Index.
+@y
+
+@ @<Declare action procedures for use by |main_control|@>=
+
+procedure insert_src_special;
+var toklist, p, q,r : pointer;
+begin
+ if (source_filename_stack[in_open] > 0 and isnewsource (source_filename_stack[in_open]
+, line)) then begin
+ toklist := get_avail;
+ p := toklist;
+ info(p) := cs_token_flag+frozen_special;
+ r := get_avail; link(p):=r; p := link(p);
+ info(p) := left_brace_token+"{";
+ q := str_toks (makesrcspecial (source_filename_stack[in_open], line));
+ link(p) := link(temp_token_head);
+ p := q;
+ r := get_avail; link(p):=r; p := link(p);
+ info(p) := right_brace_token+"}";
+ ins_list (toklist);
+ remembersourceinfo (source_filename_stack[in_open], line);
+ end;
+end;
+
+procedure append_src_special;
+var q : pointer;
+begin
+ if (source_filename_stack[in_open] > 0 and isnewsource (source_filename_stack[in_open]
+, line)) then begin
+ new_whatsit (special_node);
+ write_stream(tail) := 0;
+ q:=get_avail; def_ref := q;
+ token_ref_count(def_ref) := null;
+ q := str_toks (makesrcspecial (source_filename_stack[in_open], line));
+ link(def_ref) := link(temp_head);
+ write_tokens(tail) := def_ref;
+ remembersourceinfo (source_filename_stack[in_open], line);
+ end;
+end;
+
+@ This function used to be in pdftex, but is useful in tex too.
+
+@p function get_nullstr: str_number;
+begin
+ get_nullstr := "";
+end;
+
+@* \[55] Index.
+@z
+
diff --git a/Build/source/texk/web2c/luatexdir/luatex.defines b/Build/source/texk/web2c/luatexdir/luatex.defines
new file mode 100644
index 00000000000..b2d296671dc
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatex.defines
@@ -0,0 +1,560 @@
+{
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id $
+}
+
+{ luatex.defines: additions for luaTeX }
+
+@define function new_node();
+@define function new_glyph_node;
+@define procedure flush_node();
+@define function copy_node();
+@define procedure couple_nodes();
+@define function copy_node_list();
+@define procedure flush_node_list();
+@define function string_to_pseudo();
+@define function do_set_attribute();
+@define function copy_attribute_list();
+@define procedure add_node_attr_ref();
+@define procedure replace_attribute_list();
+@define procedure update_attribute_cache;
+
+@define function new_span_node();
+
+@define function sizeof();
+@define procedure memset();
+@define function realloc();
+@define function malloc();
+@define function voidcast();
+@define function fixmemcast();
+@define function varmemcast();
+@define type void;
+@define procedure init_node_mem();
+@define procedure print_node_mem_stats();
+@define procedure dump_node_mem;
+@define procedure undump_node_mem;
+@define function visible_last_node_type();
+@define var NULL;
+@define var varmem;
+@define var var_mem_max;
+@define procedure check_buffer_overflow();
+@define procedure check_pool_overflow();
+
+@define function new_ligkern();
+@define function make_lang_data();
+@define procedure ext_do_line_break();
+@define procedure initialize_active;
+@define var active_node_size;
+@define var prev_char_p;
+@define function cur_break();
+@define function break_node();
+
+@define function divide_scaled();
+@define function divide_scaled_n();
+
+@define procedure new_hyphenation();
+@define procedure load_tex_hyphenation();
+@define procedure load_tex_patterns();
+@define procedure dump_language_data;
+@define procedure undump_language_data;
+@define function insert_discretionary();
+@define procedure set_pre_hyphen_char();
+@define procedure set_post_hyphen_char();
+@define function get_pre_hyphen_char();
+@define function get_post_hyphen_char();
+
+{ macros from luatex.h }
+@define function pdf_char_marked();
+@define function tex_b_open_in();
+@define function vf_b_open_in ();
+@define procedure pdf_mark_char();
+@define procedure writepdf();
+@define procedure pdfassert();
+
+@define procedure luacall();
+@define procedure luatokencall();
+@define procedure closelua();
+
+@define function luacstring_input;
+@define function luacstring_penultimate;
+@define function luacstring_detokenized;
+@define function luacstring_cattable;
+@define function luacstring_defaultcattable;
+@define function luacstring_simple;
+@define procedure luacstring_close();
+@define procedure luacstring_start();
+
+{ for callbacks }
+
+@define function run_callback();
+@define function run_and_save_callback();
+@define function run_saved_callback();
+@define procedure destroy_saved_callback();
+@define function callback_defined();
+@define function callbackluaid();
+@define var find_write_file_callback;
+@define var find_output_file_callback;
+@define var find_image_file_callback;
+@define var find_format_file_callback;
+@define var find_read_file_callback;
+@define var open_read_file_callback;
+@define var find_ocp_file_callback;
+@define var read_ocp_file_callback;
+@define var find_vf_file_callback;
+@define var read_vf_file_callback;
+@define var find_data_file_callback;
+@define var read_data_file_callback;
+@define var find_font_file_callback;
+@define var read_font_file_callback;
+@define var find_map_file_callback;
+@define var read_map_file_callback;
+@define var find_enc_file_callback;
+@define var read_enc_file_callback;
+@define var find_type1_file_callback;
+@define var read_type1_file_callback;
+@define var find_truetype_file_callback;
+@define var read_truetype_file_callback;
+@define var find_opentype_file_callback;
+@define var read_opentype_file_callback;
+@define var find_sfd_file_callback;
+@define var read_sfd_file_callback;
+@define var find_pk_file_callback;
+@define var read_pk_file_callback;
+@define var show_error_hook_callback;
+@define var process_input_buffer_callback;
+@define var start_page_number_callback;
+@define var stop_page_number_callback;
+@define var start_run_callback;
+@define var stop_run_callback;
+@define var define_font_callback;
+@define var token_filter_callback;
+@define var pre_linebreak_filter_callback;
+@define var post_linebreak_filter_callback;
+@define var buildpage_filter_callback;
+@define var hyphenate_callback;
+
+@define function lua_hyphenate_callback();
+
+@define procedure get_saved_lua_boolean();
+@define procedure get_saved_lua_number();
+@define procedure get_saved_lua_string();
+@define procedure get_lua_boolean();
+@define procedure get_lua_number();
+@define procedure get_lua_string();
+
+@define procedure get_token_lua;
+@define procedure lua_node_filter();
+@define procedure lua_node_filter_s();
+@define function lua_hpack_filter();
+@define function lua_vpack_filter();
+
+{ bits for extended char code access }
+
+@define function get_math_code();
+@define procedure set_math_code();
+@define function get_del_code_a();
+@define function get_del_code_b();
+@define procedure set_del_code();
+
+@define procedure unsave_math_codes ();
+@define procedure initialize_math_codes;
+@define procedure dump_math_codes;
+@define procedure undump_math_codes;
+
+@define function get_lc_code();
+@define procedure set_lc_code();
+
+@define function get_uc_code();
+@define procedure set_uc_code();
+
+@define function get_sf_code();
+@define procedure set_sf_code();
+
+@define function get_cat_code();
+@define procedure set_cat_code();
+
+@define function valid_catcode_table ();
+@define procedure clear_catcode_stack ();
+@define procedure copy_cat_codes ();
+@define procedure initex_cat_codes ();
+@define procedure unsave_cat_codes ();
+@define procedure unsave_text_codes ();
+@define procedure initializetextcodes;
+@define procedure dumptextcodes;
+@define procedure undumptextcodes;
+
+@define procedure dumpluacregisters;
+@define procedure undumpluacregisters;
+
+@define function do_a_open_out();
+@define function do_b_open_out();
+
+@define procedure flush_loggable_info;
+
+@define var extra_version_info;
+
+{ bits and pieces from aleph }
+
+@define procedure btestin ;
+
+@define function readtfmfile();
+@define function next_vf_byte;
+@define function read_vf_file();
+@define function read_ocp_file();
+@define function read_data_file();
+
+@define var ocp_tables;
+
+@define procedure allocate_ocp_table ();
+@define procedure dump_ocp_table ();
+@define procedure undump_ocp_table ();
+@define procedure run_external_ocp ();
+
+@define function loadpoolstrings();
+
+{ 'texfont' library definitions }
+
+@define procedure dump_font ();
+@define procedure undump_font ();
+@define function is_valid_font();
+@define function copy_font();
+@define function scale_font();
+@define function max_font_id;
+@define procedure set_max_font_id();
+
+@define function font_name();
+@define function font_area();
+@define function get_font_name();
+@define function get_font_area();
+@define function font_bc();
+@define function font_ec();
+
+@define function tex_font_name();
+@define function tex_font_area();
+@define procedure set_tex_font_name();
+
+@define procedure set_pdf_font_size();
+@define procedure set_pdf_font_num();
+@define procedure set_pdf_font_blink();
+@define procedure set_pdf_font_elink();
+@define procedure set_pdf_font_expand_ratio();
+@define procedure set_pdf_font_shrink();
+@define procedure set_pdf_font_stretch();
+@define procedure set_pdf_font_step();
+@define procedure set_pdf_font_auto_expand();
+@define procedure set_pdf_font_attr();
+
+@define function pdf_font_size();
+@define function pdf_font_num();
+@define function pdf_font_blink();
+@define function pdf_font_elink();
+@define function pdf_font_expand_ratio();
+@define function pdf_font_shrink();
+@define function pdf_font_stretch();
+@define function pdf_font_step();
+@define function pdf_font_auto_expand();
+@define function pdf_font_attr();
+
+@define function cmp_font_area();
+@define function cmp_font_name();
+@define function font_shareable();
+
+@define function fontglue();
+@define procedure setfontglue();
+
+@define function font_check_0();
+@define function font_check_1();
+@define function font_check_2();
+@define function font_check_3();
+
+@define function font_size();
+@define function font_slant();
+@define function font_extend();
+@define function font_used();
+@define procedure set_font_used();
+@define function font_touched();
+@define procedure set_font_touched();
+
+@define function font_dsize();
+@define function font_natural_dir();
+
+@define function font_params();
+@define function font_param();
+@define procedure set_font_params();
+@define procedure set_font_param();
+@define function slant();
+@define function quad();
+@define function x_height();
+@define function space();
+@define function extra_space();
+@define function space_stretch();
+@define function space_shrink();
+
+@define function font_kerns();
+@define function font_kern_sc();
+@define procedure adjust_font_kern();
+
+@define function font_italics();
+@define function font_italic();
+@define procedure set_font_italic();
+
+@define function has_lig();
+@define function has_kern();
+
+@define type liginfo;
+
+@define function get_ligature();
+@define function is_valid_ligature();
+@define function lig_type();
+@define function lig_replacement();
+
+@define function is_ligature();
+@define function is_leftboundary();
+@define function is_rightboundary();
+
+@define procedure set_to_character();
+@define procedure set_to_glyph();
+@define procedure set_is_leftghost();
+@define procedure set_is_rightghost();
+
+@define var non_boundarychar;
+
+@define function ext_top();
+@define function ext_mid();
+@define function ext_bot();
+@define function ext_rep();
+
+@define var ext_tag;
+@define var list_tag;
+
+@define var virtual_font_type;
+@define function font_type();
+
+@define function font_format();
+@define function char_index();
+@define function font_cidregistry();
+@define function font_encodingbytes();
+
+@define function font_map();
+@define procedure set_font_map();
+
+
+@define function hyphen_char();
+@define function skew_char();
+@define procedure set_hyphen_char();
+@define procedure set_skew_char();
+@define function char_exists();
+
+@define function char_used();
+@define function char_name();
+@define function char_width();
+@define function char_height();
+@define function char_depth();
+@define function char_italic();
+@define function char_tag();
+@define procedure set_char_tag();
+@define function char_remainder();
+
+@define function char_info_short();
+
+@define function has_packet();
+@define procedure do_vf_packet();
+@define function expand_font_name();
+@define function auto_expand_font();
+@define procedure vf_expand_local_fonts();
+@define function letter_space_font();
+@define function read_font_info();
+
+@define function get_tag_code();
+@define function get_lp_code();
+@define function get_rp_code();
+@define function get_ef_code();
+@define procedure set_tag_code();
+@define procedure set_lp_code();
+@define procedure set_rp_code();
+@define procedure set_ef_code();
+
+@define function test_no_ligatures();
+@define procedure set_no_ligatures();
+
+@define function get_kern();
+@define function charkern();
+
+{ functions from mapfile.c }
+@define function hasfmentry();
+@define procedure checkextfm();
+@define procedure pdfmapfile();
+@define procedure pdfmapline();
+@define procedure pdf_init_map_file();
+
+@define procedure writefontstuff;
+
+{ functions from utils.c }
+@define procedure escapehex();
+@define procedure escapename();
+@define procedure escapestring();
+@define function ext_xn_over_d();
+@define procedure getcreationdate;
+@define function get_resname_prefix;
+@define function makecstring();
+
+@define procedure append_string();
+@define procedure matchstrings();
+@define procedure libpdffinish;
+@define procedure makepdftexbanner;
+@define procedure printcreationdate;
+@define procedure printmoddate;
+@define procedure print_ID();
+@define procedure set_job_id();
+@define procedure unescapehex();
+@define procedure write_stream_length();
+@define procedure removepdffile;
+@define procedure garbagewarning;
+@define function newcolorstack();
+@define function colorstackset();
+@define function colorstackpush();
+@define function colorstackpop();
+@define function colorstackcurrent();
+@define function colorstackused;
+@define function colorstackskippagestart();
+@define procedure checkpdfsave();
+@define procedure checkpdfrestore();
+@define procedure pdfshipoutbegin();
+@define procedure pdfshipoutend();
+@define procedure pdfsetmatrix();
+@define procedure matrixtransformpoint();
+@define procedure matrixtransformrect();
+@define function matrixused;
+@define procedure matrixrecalculate();
+@define function getllx;
+@define function getlly;
+@define function geturx;
+@define function getury;
+
+{functions from texpdf.c }
+
+@define procedure pdf_print_char();
+@define procedure pdf_print();
+@define procedure pdf_print_int();
+@define procedure pdf_print_real();
+@define procedure pdf_print_str();
+
+{functions from textoken.c }
+
+@define function get_next;
+
+{ functions from vfpacket.c }
+@define function new_vf_packet();
+@define function packet_byte;
+@define procedure start_packet();
+@define procedure store_packet();
+
+{ functions from writefont.c }
+@define procedure do_pdf_font();
+
+{ functions from writeimg.c }
+@define function check_image_b();
+@define function check_image_c();
+@define function check_image_i();
+@define function epdf_orig_x();
+@define function epdf_orig_y();
+@define function image_pages();
+@define function image_colordepth();
+@define function image_index();
+@define function image_width();
+@define function image_height();
+@define function image_depth();
+@define function image_objnum();
+@define function image_imgnum();
+@define function is_pdf_image();
+@define function read_image();
+@define function new_image_entry;
+@define procedure update_image_procset();
+@define procedure write_image();
+@define procedure scale_image();
+@define procedure set_image_dimensions();
+@define procedure set_image_index();
+@define procedure out_image();
+
+{ functions from limglib.c }
+@define procedure lua_setximage();
+
+{ functions from writet3.c }
+@define function get_pk_char_width();
+
+{ functions from writezip.c }
+@define procedure write_zip();
+
+{ functions from avlstuff.c }
+@define procedure avl_put_obj();
+@define function avl_find_obj();
+
+{ functions from tounicode.c }
+@define procedure def_tounicode();
+
+{ end of luatex.defines }
+
+{texmf.defines}
+
+@define type two_halves;
+@define type four_quarters;
+
+@define function input_ln ();
+@define function is_new_source ();
+@define function get_job_name ();
+@define function make_full_name_string;
+
+@define procedure seconds_and_micros ();
+@define function ocp_open_in ();
+@define function open_in_name_ok ();
+@define function open_out_name_ok ();
+
+@define function w_open_in ();
+@define function w_open_out ();
+
+@define procedure dump_hh ();
+@define procedure dump_int ();
+@define procedure dump_things ();
+@define procedure dump_wd ();
+
+@define procedure undump_hh ();
+@define procedure undump_int ();
+@define procedure undump_qqqq ();
+@define procedure undump_things ();
+@define procedure undump_checked_things ();
+@define procedure undump_upper_check_things ();
+@define procedure undump_wd ();
+@define procedure w_close ();
+
+{common.defines}
+
+@define type memory_word; {for gftodvi, TeX, and Metafont}
+
+@define function a_open_in ();
+@define procedure a_close ();
+@define procedure b_close ();
+@define function a_open_out ();
+@define function b_open_out ();
+
+@define procedure write_dvi ();
+@define procedure write_pdf ();
+@define procedure write_ln ();
+
+@define procedure recorder_change_filename ();
diff --git a/Build/source/texk/web2c/luatexdir/luatex.h b/Build/source/texk/web2c/luatexdir/luatex.h
new file mode 100644
index 00000000000..aef2f355396
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatex.h
@@ -0,0 +1,173 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id $
+*/
+
+/* some code array functions */
+
+extern void set_math_code (integer n, halfword v, quarterword grouplevel);
+extern halfword get_math_code (integer n);
+
+extern void set_del_code (integer n, halfword v, halfword w, quarterword grouplevel);
+extern halfword get_del_code_a (integer n);
+extern halfword get_del_code_b (integer n);
+
+extern void unsavemathcodes (quarterword grouplevel);
+extern void initializemathcodes ();
+extern void dumpmathcodes ();
+extern void undumpmathcodes ();
+
+extern void set_lc_code (integer n, halfword v, quarterword grouplevel);
+extern halfword get_lc_code (integer n);
+extern void set_uc_code (integer n, halfword v, quarterword grouplevel);
+extern halfword get_uc_code (integer n);
+extern void set_sf_code (integer n, halfword v, quarterword grouplevel);
+extern halfword get_sf_code (integer n);
+extern void set_cat_code (integer h, integer n, halfword v, quarterword grouplevel);
+extern halfword get_cat_code (integer h, integer n);
+
+extern void unsavetextcodes (quarterword grouplevel);
+extern void unsavecatcodes (integer h,quarterword grouplevel);
+extern void copy_cat_codes (int from, int to);
+extern void initex_cat_codes (int h);
+extern void clearcatcodestack (integer h);
+extern boolean validcatcodetable (int h);
+
+extern void initializetextcodes ();
+extern void dumptextcodes ();
+extern void undumptextcodes ();
+
+typedef enum {
+ escape, left_brace, right_brace, math_shift,
+ tab_mark, car_ret, mac_param, sup_mark,
+ sub_mark, ignore, spacer, letter,
+ other_char, active_char, comment, invalid_char } cat_codes;
+
+
+extern void do_vf(internal_font_number tmp_f);
+
+extern int readbinfile(FILE *f, unsigned char **b, integer *s);
+
+#define read_tfm_file readbinfile
+#define read_vf_file readbinfile
+#define read_ocp_file readbinfile
+#define read_data_file readbinfile
+
+extern int **ocp_tables;
+
+extern void allocate_ocp_table();
+extern void dump_ocp_table();
+extern void undump_ocp_table();
+
+extern void run_external_ocp();
+extern void b_test_in();
+
+/* Additions to texmfmp.h for pdfTeX */
+
+/* mark a char in font */
+#define pdf_mark_char(f,c) set_char_used(f,c,true)
+
+/* test whether a char in font is marked */
+#define pdf_char_marked char_used
+
+/* writepdf() always writes by fwrite() */
+#define write_pdf(a, b) \
+ (void) fwrite ((char *) &pdf_buf[a], sizeof (pdf_buf[a]), \
+ (int) ((b) - (a) + 1), pdf_file)
+
+#define tex_b_open_in(f) \
+ open_input (&(f), kpse_tex_format, FOPEN_RBIN_MODE)
+#define ovf_b_open_in(f) \
+ open_input (&(f), kpse_ovf_format, FOPEN_RBIN_MODE)
+#define vf_b_open_in(f) \
+ open_input (&(f), kpse_vf_format, FOPEN_RBIN_MODE)
+
+extern int open_outfile(FILE **f, char *name, char *mode);
+
+#define do_a_open_out(f) open_outfile(&(f),(char *)(nameoffile+1),FOPEN_W_MODE)
+#define do_b_open_out(f) open_outfile(&(f),(char *)(nameoffile+1),FOPEN_WBIN_MODE)
+
+#define pdfassert assert
+#define voidcast(a) (void *)(a)
+#define varmemcast(a) (memory_word *)(a)
+#define fixmemcast(a) (smemory_word *)(a)
+extern volatile memory_word *varmem;
+extern halfword var_mem_min;
+extern halfword var_mem_max;
+extern halfword get_node (integer s);
+extern void free_node (halfword p, integer s) ;
+extern void init_node_mem (integer r, integer s) ;
+extern void dump_node_mem (void) ;
+extern void undump_node_mem (void);
+
+
+typedef enum {
+ find_write_file_callback = 1,
+ find_output_file_callback,
+ find_image_file_callback,
+ find_format_file_callback,
+ find_read_file_callback, open_read_file_callback,
+ find_ocp_file_callback, read_ocp_file_callback,
+ find_vf_file_callback, read_vf_file_callback,
+ find_data_file_callback, read_data_file_callback,
+ find_font_file_callback, read_font_file_callback,
+ find_map_file_callback, read_map_file_callback,
+ find_enc_file_callback, read_enc_file_callback,
+ find_type1_file_callback, read_type1_file_callback,
+ find_truetype_file_callback, read_truetype_file_callback,
+ find_opentype_file_callback, read_opentype_file_callback,
+ find_sfd_file_callback, read_sfd_file_callback,
+ find_pk_file_callback, read_pk_file_callback,
+ show_error_hook_callback,
+ process_input_buffer_callback,
+ start_page_number_callback, stop_page_number_callback,
+ start_run_callback, stop_run_callback,
+ define_font_callback,
+ token_filter_callback,
+ pre_output_filter_callback,
+ buildpage_filter_callback,
+ hpack_filter_callback, vpack_filter_callback,
+ char_exists_callback,
+ hyphenate_callback,
+ ligaturing_callback,
+ kerning_callback,
+ pre_linebreak_filter_callback,
+ linebreak_filter_callback,
+ post_linebreak_filter_callback,
+ total_callbacks } callback_callback_types;
+
+extern int callback_set[];
+
+#define callback_defined(a) callback_set[a]
+
+extern int run_callback (int i, char *values, ...);
+extern int run_saved_callback (int i, char *name, char *values, ...);
+extern int run_and_save_callback (int i, char *values, ...);
+extern void destroy_saved_callback (int i);
+
+extern void get_saved_lua_boolean (int i, char *name, boolean *target);
+extern void get_saved_lua_number (int i, char *name, integer *target);
+extern void get_saved_lua_string (int i, char *name, char **target);
+
+extern void get_lua_boolean (char *table, char *name, boolean *target);
+extern void get_lua_number (char *table, char *name, integer *target);
+extern void get_lua_string (char *table, char *name, char **target);
+
+#include <luatexdir/ptexlib.h>
diff --git a/Build/source/texk/web2c/luatexdir/luatex.mk b/Build/source/texk/web2c/luatexdir/luatex.mk
new file mode 100644
index 00000000000..ed745cd261d
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatex.mk
@@ -0,0 +1,170 @@
+# Makefile fragment for pdfeTeX and web2c. --infovore@xs4all.nl. Public domain.
+# This fragment contains the parts of the makefile that are most likely to
+# differ between releases of pdfeTeX.
+
+# We build luatex
+luatex = @LTEX@ luatex
+luatexdir = luatexdir
+
+# libz
+ZLIBDIR=../../libs/zlib
+ZLIBSRCDIR=$(srcdir)/$(ZLIBDIR)
+# libpng
+LIBPNGDIR=../../libs/libpng
+LIBPNGSRCDIR=$(srcdir)/$(LIBPNGDIR)
+# libxpdf
+LIBXPDFDIR=../../libs/xpdf
+LIBXPDFSRCDIR=$(srcdir)/$(LIBXPDFDIR)
+# libobsdcompa
+LIBOBSDCOMPATDIR=../../libs/obsdcompat
+LIBOBSDCOMPATFSRCDIR=$(srcdir)/$(LIBOBSDCOMPATDIR)
+
+XCPPFLAGS=-I$(LIBOBSDCOMPATDIR) -I$(LIBOBSDCOMPATDIR)/.. -I$(LIBOBSDCOMPATFSRCDIR) -I$(LIBOBSDCOMPATFSRCDIR)/.. -I$(ZLIBSRCDIR) -I$(LIBPNGSRCDIR) -I$(LIBXPDFSRCDIR) -Dextra_version_info=`date +-%Y%m%d%H`
+
+Makefile: $(srcdir)/$(luatexdir)/luatex.mk
+
+# luatex_bin = luatex ttf2afm pdftosrc
+luatex_bin = luatex
+linux_build_dir = $(HOME)/luatex/build/linux/texk/web2c
+
+
+# Extract luatex version
+$(luatexdir)/luatex.version: $(srcdir)/$(luatexdir)/luatex.web
+ test -d $(luatexdir) || mkdir $(luatexdir)
+ grep '^@d luatex_version_string==' $(srcdir)/$(luatexdir)/luatex.web \
+ | sed "s/^.*=='//;s/' .*$$//" \
+ >$(luatexdir)/luatex.version
+
+# The C sources.
+luatex_c = luatexini.c luatex0.c luatex1.c luatex2.c luatex3.c
+luatex_o = luatexini.o luatex0.o luatex1.o luatex2.o luatex3.o luatexextra.o loadpool.o
+
+# Making luatex
+luatex: luatexd.h $(luatex_o) $(luatexextra_o) $(luatexlibsdep)
+ @CXXHACKLINK@ $(luatex_o) $(luatexextra_o) $(luatexlibs) $(socketlibs) @CXXHACKLDLIBS@ @CXXLDEXTRA@
+
+# C file dependencies.
+$(luatex_c) luatexcoerce.h luatexd.h: luatex.p $(web2c_texmf) $(srcdir)/$(luatexdir)/luatex.defines $(srcdir)/$(luatexdir)/luatex.h
+ $(web2c) luatex
+luatexextra.c: $(luatexdir)/luatexextra.h lib/texmfmp.c
+ test -d $(luatexdir) || mkdir $(luatexdir)
+ sed s/TEX-OR-MF-OR-MP/luatex/ $(srcdir)/lib/texmfmp.c >$@
+$(luatexdir)/luatexextra.h: $(luatexdir)/luatexextra.in $(luatexdir)/luatex.version
+ test -d $(luatexdir) || mkdir $(luatexdir)
+ sed -e s/LUATEX-VERSION/`cat $(luatexdir)/luatex.version`/ \
+ $(srcdir)/$(luatexdir)/luatexextra.in >$@
+loadpool.c: luatex.pool $(luatexdir)/makecpool
+ $(native)/$(luatexdir)/makecpool luatex.pool luatexdir/ptexlib.h > loadpool.c
+
+# luatangle we need a private version of tangle
+
+luatangle: luatangle.o
+ $(kpathsea_link) luatangle.o $(LOADLIBES)
+
+luatangle.c luatangle.h: luatangle.p
+ $(web2c) luatangle
+
+luatangle.p: tangle $(srcdir)/$(luatexdir)/luatangle.web $(srcdir)/$(luatexdir)/luatangle.ch
+ $(TANGLE) $(srcdir)/$(luatexdir)/luatangle.web $(srcdir)/$(luatexdir)/luatangle.ch
+
+# Tangling
+luatex.p luatex.pool: luatangle $(srcdir)/$(luatexdir)/luatex.web $(srcdir)/$(luatexdir)/luatex.ch
+ $(native)/luatangle --underlines $(srcdir)/$(luatexdir)/luatex.web $(srcdir)/$(luatexdir)/luatex.ch
+
+# Sources for luatex.ch:
+#luatex_ch_srcs = $(srcdir)/$(luatexdir)/luatex.web \
+# $(srcdir)/$(luatexdir)/lua.ch \
+# $(srcdir)/$(luatexdir)/lua.ch0
+
+# Rules:
+#luatex.ch: $(TIE) $(luatex_ch_srcs)
+# $(TIE) -c luatex.ch $(luatex_ch_srcs)
+
+# for developing only
+#luatex-org.web: $(TIE) $(luatex_ch_srcs_org)
+# $(TIE) -m $@ $(luatex_ch_srcs_org)
+#luatex-all.web: $(TIE) $(srcdir)/$(luatexdir)/luatex.web luatex.ch
+# $(TIE) -m $@ $(srcdir)/$(luatexdir)/luatex.web luatex.ch
+#luatex-all.tex: luatex-all.web
+# $(WEAVE) luatex-all.web
+# echo -e '1s/ webmac/ pdfwebmac/\nw\nq' | ed $@ >/dev/null 2>&1
+#luatex-all.pdf: luatex-all.tex
+# $(luatex) luatex-all.tex
+
+check: @PETEX@ luatex-check
+luatex-check: luatex luatex.fmt
+
+clean:: luatex-clean
+luatex-clean:
+ $(LIBTOOL) --mode=clean $(RM) luatex
+ rm -f $(luatex_o) $(luatex_c) luatexextra.c luatexcoerce.h
+ rm -f $(luatexdir)/luatexextra.h
+ rm -f luatexd.h luatex.p luatex.pool luatex.ch strpool.c
+ rm -f luatex.fmt luatex.log
+
+# Dumps
+all_luafmts = @FMU@ luatex.fmt $(luafmts)
+
+dumps: @LTEX@ luafmts
+luafmts: $(all_luafmts)
+
+luafmtdir = $(web2cdir)/luatex
+$(luafmtdir)::
+ $(SHELL) $(top_srcdir)/../mkinstalldirs $(luafmtdir)
+
+luatex.fmt: luatex
+ $(dumpenv) $(MAKE) progname=luatex files="etex.src plain.tex cmr10.tfm" prereq-check
+ $(dumpenv) ./luatex --progname=luatex --jobname=luatex --ini \*\\pdfoutput=1\\input etex.src \\dump </dev/null
+
+#
+# Installation.
+install-luatex: install-luatex-exec
+install-luatex-exec: install-luatex-links
+
+# The actual binary executables and pool files.
+install-programs: @PETEX@ install-luatex-programs
+install-luatex-programs: $(luatex) $(bindir)
+ for p in luatex; do $(INSTALL_LIBTOOL_PROG) $$p $(bindir); done
+
+install-links: @PETEX@ install-luatex-links
+install-luatex-links: install-luatex-programs
+ #cd $(bindir) && (rm -f luainitex luavirtex; \
+ # $(LN) luatex luainitex; $(LN) luatex luavirtex)
+
+install-fmts: @PETEX@ install-luatex-fmts
+install-luatex-fmts: luafmts $(luafmtdir)
+ luafmts="$(all_luafmts)"; \
+ for f in $$luafmts; do $(INSTALL_DATA) $$f $(luafmtdir)/$$f; done
+ luafmts="$(luafmts)"; \
+ for f in $$luafmts; do base=`basename $$f .fmt`; \
+ (cd $(bindir) && (rm -f $$base; $(LN) luatex $$base)); done
+
+#
+# luatex binaries archive
+luatexbin:
+ $(MAKE) $(luatex_bin)
+
+luatex-cross:
+ $(MAKE) web2c-cross
+ $(MAKE) luatexbin
+
+web2c-cross: $(web2c_programs)
+ @if test ! -x $(linux_build_dir)/luatangle; then echo Error: linux_build_dir not ready; exit -1; fi
+ rm -f web2c/fixwrites web2c/splitup web2c/web2c
+ cp -f $(linux_build_dir)/web2c/fixwrites web2c
+ cp -f $(linux_build_dir)/web2c/splitup web2c
+ cp -f $(linux_build_dir)/web2c/web2c web2c
+ touch web2c/fixwrites web2c/splitup web2c/web2c
+ $(MAKE) tangleboot && rm -f tangleboot && \
+ cp -f $(linux_build_dir)/tangleboot . && touch tangleboot
+ $(MAKE) ctangleboot && rm -f ctangleboot && \
+ cp -f $(linux_build_dir)/ctangleboot . && touch ctangleboot
+ $(MAKE) ctangle && rm -f ctangle && \
+ cp -f $(linux_build_dir)/ctangle . && touch ctangle
+ $(MAKE) tie && rm -f tie && \
+ cp -f $(linux_build_dir)/tie . && touch tie
+ $(MAKE) luatangle && rm -f luatangle && \
+ cp -f $(linux_build_dir)/luatangle . && touch luatangle
+
+# vim: set noexpandtab
+# end of luatex.mk
diff --git a/Build/source/texk/web2c/luatexdir/luatex.web b/Build/source/texk/web2c/luatexdir/luatex.web
new file mode 100644
index 00000000000..b1c977706ff
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatex.web
@@ -0,0 +1,35760 @@
+% Copyright (c) 2007 Hartmut Henkel, Taco Hoekwater
+
+% This file is part of luaTeX.
+
+% luaTeX is free software; you can redistribute it and/or modify it under the
+% terms of the GNU General Public License as published by the Free Software
+% Foundation; either version 2 of the License, or (at your option) any later
+% version.
+
+% luaTeX is distributed in the hope that it will be useful, but WITHOUT ANY
+% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+% A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+% You should have received a copy of the GNU General Public License
+% along with luaTeX; if not, write to the Free Software Foundation, Inc.,
+% 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+% pdfTeX is copyright (C) 1996-2006 Han The Thanh, <thanh@@pdftex.org>.
+% e-TeX is copyright (C) 1994,98 by Peter Breitenlohner.
+
+% This program is directly derived from Donald E. Knuth's TeX;
+% the change history which follows and the reward offered for finders of
+% bugs refer specifically to TeX; they should not be taken as referring
+% to e-TeX, although the change history is relevant in that it
+% demonstrates the evolutionary path followed. This program is not TeX;
+% that name is reserved strictly for the program which is the creation
+% and sole responsibility of Professor Knuth.
+
+% Version 0 was released in September 1982 after it passed a variety of tests.
+% Version 1 was released in November 1983 after thorough testing.
+% Version 1.1 fixed ``disappearing font identifiers'' et alia (July 1984).
+% Version 1.2 allowed `0' in response to an error, et alia (October 1984).
+% Version 1.3 made memory allocation more flexible and local (November 1984).
+% Version 1.4 fixed accents right after line breaks, et alia (April 1985).
+% Version 1.5 fixed \the\toks after other expansion in \edefs (August 1985).
+% Version 2.0 (almost identical to 1.5) corresponds to "Volume B" (April 1986).
+% Version 2.1 corrected anomalies in discretionary breaks (January 1987).
+% Version 2.2 corrected "(Please type...)" with null \endlinechar (April 1987).
+% Version 2.3 avoided incomplete page in premature termination (August 1987).
+% Version 2.4 fixed \noaligned rules in indented displays (August 1987).
+% Version 2.5 saved cur_order when expanding tokens (September 1987).
+% Version 2.6 added 10sp slop when shipping leaders (November 1987).
+% Version 2.7 improved rounding of negative-width characters (November 1987).
+% Version 2.8 fixed weird bug if no \patterns are used (December 1987).
+% Version 2.9 made \csname\endcsname's "relax" local (December 1987).
+% Version 2.91 fixed \outer\def\a0{}\a\a bug (April 1988).
+% Version 2.92 fixed \patterns, also file names with complex macros (May 1988).
+% Version 2.93 fixed negative halving in allocator when mem_min<0 (June 1988).
+% Version 2.94 kept open_log_file from calling fatal_error (November 1988).
+% Version 2.95 solved that problem a better way (December 1988).
+% Version 2.96 corrected bug in "Infinite shrinkage" recovery (January 1989).
+% Version 2.97 corrected blunder in creating 2.95 (February 1989).
+% Version 2.98 omitted save_for_after at outer level (March 1989).
+% Version 2.99 caught $$\begingroup\halign..$$ (June 1989).
+% Version 2.991 caught .5\ifdim.6... (June 1989).
+% Version 2.992 introduced major changes for 8-bit extensions (September 1989).
+% Version 2.993 fixed a save_stack synchronization bug et alia (December 1989).
+% Version 3.0 fixed unusual displays; was more \output robust (March 1990).
+% Version 3.1 fixed nullfont, disabled \write{\the\prevgraf} (September 1990).
+% Version 3.14 fixed unprintable font names and corrected typos (March 1991).
+% Version 3.141 more of same; reconstituted ligatures better (March 1992).
+% Version 3.1415 preserved nonexplicit kerns, tidied up (February 1993).
+% Version 3.14159 allowed fontmemsize to change; bulletproofing (March 1995).
+% Version 3.141592 fixed \xleaders, glueset, weird alignments (December 2002).
+
+
+% Although considerable effort has been expended to make the luaTeX program
+% correct and reliable, no warranty is implied; the authors disclaim any
+% obligation or liability for damages, including but not limited to
+% special, indirect, or consequential damages arising out of or in
+% connection with the use or performance of this software. This work has
+% been a ``labor of love'' and the authors hope that users enjoy it.
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\noindent\ignorespaces}
+\def\hangg#1 {\hang\hbox{#1 }}
+\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+\def\pdfTeX{pdf\TeX}
+\def\pdfeTeX{pdf\eTeX}
+\def\PDF{PDF}
+\def\Aleph{Aleph}
+\def\eTeX{e\TeX}
+\def\LuaTeX{Lua\TeX}
+\def\THANH{H\`an Th\^e\llap{\raise 0.5ex\hbox{\'{}}} Th\`anh}
+\def\ph{\hbox{Pascal-H}}
+\def\pct!{{\char`\%}} % percent sign in ordinary text
+\def\grp{\.{\char'173...\char'175}}
+\font\logo=logo10 % font used for the METAFONT logo
+\def\MF{{\logo META}\-{\logo FONT}}
+\def\<#1>{$\langle#1\rangle$}
+\def\section{\mathhexbox278}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+
+\outer\def\N#1. \[#2]#3.{\MN#1.\vfil\eject % begin starred section
+ \def\rhead{PART #2:\uppercase{#3}} % define running headline
+ \message{*\modno} % progress report
+ \edef\next{\write\cont{\Z{\?#2]#3}{\modno}{\the\pageno}}}\next
+ \ifon\startsection{\bf\ignorespaces#3.\quad}\ignorespaces}
+\let\?=\relax % we want to be able to \write a \?
+
+\def\title{LuaTeX}
+\let\maybe=\iffalse % print only changed modules
+\def\topofcontents{\hsize 5.5in
+ \vglue 0pt plus 1fil minus 1.5in
+ \def\?##1]{\hbox to 1in{\hfil##1.\ }}
+ }
+\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
+\pageno=3
+\def\glob{13} % this should be the section number of "<Global...>"
+\def\gglob{20, 26} % this should be the next two sections of "<Global...>"
+
+@* \[1] Introduction.
+
+This is LuaTeX, a continuation of $\pdfTeX$ and $\Aleph$. LuaTeX is a
+document compiler intended to simplify high-quality typesetting for
+many of the world's languages. It is an extension of D. E. Knuth's
+\TeX, which was designed essentially for the typesetting of languages
+using the Latin alphabet.
+
+The $\Aleph$ subsystem loosens many of the restrictions imposed by~\TeX:
+register numbers are no longer limited to 8~bits; fonts may have more
+than 256~characters; more than 256~fonts may be used; etc.
+
+The \PASCAL\ program that follows is the definition of \TeX82, a standard
+@:PASCAL}{\PASCAL@>
+@!@:TeX82}{\TeX82@>
+version of \TeX\ that is designed to be highly portable so that
+identical output will be obtainable on a great variety of computers.
+
+The main purpose of the following program is to explain the algorithms of \TeX\
+as clearly as possible. As a result, the program will not necessarily be very
+efficient when a particular \PASCAL\ compiler has translated it into a
+particular machine language. However, the program has been written so that it
+can be tuned to run efficiently in a wide variety of operating environments
+by making comparatively few changes. Such flexibility is possible because
+the documentation that follows is written in the \.{WEB} language, which is
+at a higher level than \PASCAL; the preprocessing step that converts \.{WEB}
+to \PASCAL\ is able to introduce most of the necessary refinements.
+Semi-automatic translation to other languages is also feasible, because the
+program below does not make extensive use of features that are peculiar to
+\PASCAL.
+
+A large piece of software like \TeX\ has inherent complexity that cannot
+be reduced below a certain level of difficulty, although each individual
+part is fairly simple by itself. The \.{WEB} language is intended to make
+the algorithms as readable as possible, by reflecting the way the
+individual program pieces fit together and by providing the
+cross-references that connect different parts. Detailed comments about
+what is going on, and about why things were done in certain ways, have
+been liberally sprinkled throughout the program. These comments explain
+features of the implementation, but they rarely attempt to explain the
+\TeX\ language itself, since the reader is supposed to be familiar with
+{\sl The \TeX book}.
+@.WEB@>
+@:TeXbook}{\sl The \TeX book@>
+
+@ The present implementation has a long ancestry, beginning in the summer
+of~1977, when Michael~F. Plass and Frank~M. Liang designed and coded
+a prototype
+@^Plass, Michael Frederick@>
+@^Liang, Franklin Mark@>
+@^Knuth, Donald Ervin@>
+based on some specifications that the author had made in May of that year.
+This original proto\TeX\ included macro definitions and elementary
+manipulations on boxes and glue, but it did not have line-breaking,
+page-breaking, mathematical formulas, alignment routines, error recovery,
+or the present semantic nest; furthermore,
+it used character lists instead of token lists, so that a control sequence
+like \.{\\halign} was represented by a list of seven characters. A
+complete version of \TeX\ was designed and coded by the author in late
+1977 and early 1978; that program, like its prototype, was written in the
+{\mc SAIL} language, for which an excellent debugging system was
+available. Preliminary plans to convert the {\mc SAIL} code into a form
+somewhat like the present ``web'' were developed by Luis Trabb~Pardo and
+the author at the beginning of 1979, and a complete implementation was
+created by Ignacio~A. Zabala in 1979 and 1980. The \TeX82 program, which
+@^Zabala Salelles, Ignacio Andr\'es@>
+was written by the author during the latter part of 1981 and the early
+part of 1982, also incorporates ideas from the 1979 implementation of
+@^Guibas, Leonidas Ioannis@>
+@^Sedgewick, Robert@>
+@^Wyatt, Douglas Kirk@>
+\TeX\ in {\mc MESA} that was written by Leonidas Guibas, Robert Sedgewick,
+and Douglas Wyatt at the Xerox Palo Alto Research Center. Several hundred
+refinements were introduced into \TeX82 based on the experiences gained with
+the original implementations, so that essentially every part of the system
+has been substantially improved. After the appearance of ``Version 0'' in
+September 1982, this program benefited greatly from the comments of
+many other people, notably David~R. Fuchs and Howard~W. Trickey.
+A final revision in September 1989 extended the input character set to
+eight-bit codes and introduced the ability to hyphenate words from
+different languages, based on some ideas of Michael~J. Ferguson.
+@^Fuchs, David Raymond@>
+@^Trickey, Howard Wellington@>
+@^Ferguson, Michael John@>
+
+No doubt there still is plenty of room for improvement, but the author
+is firmly committed to keeping \TeX82 ``frozen'' from now on; stability
+and reliability are to be its main virtues.
+
+On the other hand, the \.{WEB} description can be extended without changing
+the core of \TeX82 itself, and the program has been designed so that such
+extensions are not extremely difficult to make.
+The |banner| string defined here should be changed whenever \TeX\
+undergoes any modifications, so that it will be clear which version of
+\TeX\ might be the guilty party when a problem arises.
+@^extensions to \TeX@>
+@^system dependencies@>
+
+This program contains code for various features extending \TeX,
+therefore this program is called `\eTeX' and not
+`\TeX'; the official name `\TeX' by itself is reserved
+for software systems that are fully compatible with each other.
+A special test suite called the ``\.{TRIP} test'' is available for
+helping to determine whether a particular implementation deserves to be
+known as `\TeX' [cf.~Stanford Computer Science report CS1027,
+November 1984].
+
+A similar test suite called the ``\.{e-TRIP} test'' is available for
+helping to determine whether a particular implementation deserves to be
+known as `\eTeX'.
+
+@d eTeX_version_string=="2.2" {current \eTeX\ version}
+@d Omega_version_string=="1.15" { \.{\\OmegaVersion} }
+@d Aleph_version_string=="0.0" { \.{\\AlephVersion} }
+@d eTeX_version=2 { \.{\\eTeXversion} }
+@d Omega_version=1 { \.{\\Omegaversion} }
+@d Aleph_version=0 { \.{\\Alephversion} }
+@d eTeX_minor_version=1 { \.{\\eTeXminorversion} }
+@d Omega_minor_version=15 { \.{\\Omegaminorversion} }
+@d Aleph_minor_version=0 { \.{\\Alephminorversion} }
+@d eTeX_revision==".2" { \.{\\eTeXrevision} }
+@d Omega_revision==".15" { \.{\\Omegarevision} }
+@d Aleph_revision==".0" { \.{\\Alephrevision} }
+@#
+@d pdftex_version==200 { \.{\\pdftexversion} }
+@d pdftex_revision=="0" { \.{\\pdftexrevision} }
+@d pdftex_version_string=='-2.00.0' {current \pdfTeX\ version}
+@#
+@d luatex_version==25 { \.{\\luatexversion} }
+@d luatex_revision=="1" { \.{\\luatexrevision} }
+@d luatex_version_string=='snapshot-0.25.1' {current \LuaTeX\ version}
+@d luatex_date_info==-extra_version_info { the compile date is negated }
+@#
+@d luaTeX_banner=='This is LuaTeX, Version ',luatex_version_string,extra_version_info
+ {printed when \LuaTeX\ starts}
+@#
+@d banner==luaTeX_banner
+@#
+@d TEX==ETEX {change program name into |ETEX|}
+
+@ Different \PASCAL s have slightly different conventions, and the present
+@!@:PASCAL H}{\ph@>
+program expresses \TeX\ in terms of the \PASCAL\ that was
+available to the author in 1982. Constructions that apply to
+this particular compiler, which we shall call \ph, should help the
+reader see how to make an appropriate interface for other systems
+if necessary. (\ph\ is Charles Hedrick's modification of a compiler
+@^Hedrick, Charles Locke@>
+for the DECsystem-10 that was originally developed at the University of
+Hamburg; cf.\ {\sl SOFTWARE---Practice \AM\ Experience \bf6} (1976),
+29--42. The \TeX\ program below is intended to be adaptable, without
+extensive changes, to most other versions of \PASCAL, so it does not fully
+use the admirable features of \ph. Indeed, a conscious effort has been
+made here to avoid using several idiosyncratic features of standard
+\PASCAL\ itself, so that most of the code can be translated mechanically
+into other high-level languages. For example, the `\&{with}' and `\\{new}'
+features are not used, nor are pointer types, set types, or enumerated
+scalar types; there are no `\&{var}' parameters, except in the case of files
+--- \eTeX, however, does use `\&{var}' parameters for the |reverse| function;
+there are no tag fields on variant records; there are no assignments
+|real:=integer|; no procedures are declared local to other procedures.)
+
+The portions of this program that involve system-dependent code, where
+changes might be necessary because of differences between \PASCAL\ compilers
+and/or differences between
+operating systems, can be identified by looking at the sections whose
+numbers are listed under `system dependencies' in the index. Furthermore,
+the index entries for `dirty \PASCAL' list all places where the restrictions
+of \PASCAL\ have not been followed perfectly, for one reason or another.
+@!@^system dependencies@>
+@!@^dirty \PASCAL@>
+
+Incidentally, \PASCAL's standard |round| function can be problematical,
+because it disagrees with the IEEE floating-point standard.
+Many implementors have
+therefore chosen to substitute their own home-grown rounding procedure.
+
+@ The program begins with a normal \PASCAL\ program heading, whose
+components will be filled in later, using the conventions of \.{WEB}.
+@.WEB@>
+For example, the portion of the program called `\X\glob:Global
+variables\X' below will be replaced by a sequence of variable declarations
+that starts in $\section\glob$ of this documentation. In this way, we are able
+to define each individual global variable when we are prepared to
+understand what it means; we do not have to define all of the globals at
+once. Cross references in $\section\glob$, where it says ``See also
+sections \gglob, \dots,'' also make it possible to look at the set of
+all global variables, if desired. Similar remarks apply to the other
+portions of the program heading.
+
+Actually the heading shown here is not quite normal: The |program| line
+does not mention any |output| file, because \ph\ would ask the \TeX\ user
+to specify a file name if |output| were specified here.
+@^system dependencies@>
+
+@d mtype==t@&y@&p@&e {this is a \.{WEB} coding trick:}
+@f mtype==type {`\&{mtype}' will be equivalent to `\&{type}'}
+@f type==true {but `|type|' will not be treated as a reserved word}
+
+@p @t\4@>@<Compiler directives@>@/
+program TEX; {all file names are defined dynamically}
+label @<Labels in the outer block@>@/
+const @<Constants in the outer block@>@/
+mtype @<Types in the outer block@>@/
+var @<Global variables@>@/
+@#
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin @<Initialize whatever \TeX\ might access@>@;
+ end;@#
+@t\4@>@<Basic printing procedures@>@/
+@t\4@>@<Error handling procedures@>@/
+
+@ The overall \TeX\ program begins with the heading just shown, after which
+comes a bunch of procedure declarations and function declarations.
+Finally we will get to the main program, which begins with the
+comment `|start_here|'. If you want to skip down to the
+main program now, you can look up `|start_here|' in the index.
+But the author suggests that the best way to understand this program
+is to follow pretty much the order of \TeX's components as they appear in the
+\.{WEB} description you are now reading, since the present ordering is
+intended to combine the advantages of the ``bottom up'' and ``top down''
+approaches to the problem of understanding a somewhat complicated system.
+
+@ Three labels must be declared in the main program, so we give them
+symbolic names.
+
+@d start_of_TEX=1 {go here when \TeX's variables are initialized}
+@d end_of_TEX=9998 {go here to close files and terminate gracefully}
+@d final_end=9999 {this label marks the ending of the program}
+
+@<Labels in the out...@>=
+start_of_TEX@t\hskip-2pt@>, end_of_TEX@t\hskip-2pt@>,@,final_end;
+ {key control points}
+
+@ Some of the code below is intended to be used only when diagnosing the
+strange behavior that sometimes occurs when \TeX\ is being installed or
+when system wizards are fooling around with \TeX\ without quite knowing
+what they are doing. Such code will not normally be compiled; it is
+delimited by the codewords `$|debug|\ldots|gubed|$', with apologies
+to people who wish to preserve the purity of English.
+
+Similarly, there is some conditional code delimited by
+`$|stat|\ldots|tats|$' that is intended for use when statistics are to be
+kept about \TeX's memory usage. The |stat| $\ldots$ |tats| code also
+implements diagnostic information for \.{\\tracingparagraphs} and
+\.{\\tracingpages}.
+@^debugging@>
+
+@d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging}
+@d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging}
+@f debug==begin
+@f gubed==end
+@#
+@d stat==@{ {change this to `$\\{stat}\equiv\null$' when gathering
+ usage statistics}
+@d tats==@t@>@} {change this to `$\\{tats}\equiv\null$' when gathering
+ usage statistics}
+@f stat==begin
+@f tats==end
+
+@ This program has two important variations: (1) There is a long and slow
+version called \.{INITEX}, which does the extra calculations needed to
+@.INITEX@>
+initialize \TeX's internal tables; and (2)~there is a shorter and faster
+production version, which cuts the initialization to a bare minimum.
+Parts of the program that are needed in (1) but not in (2) are delimited by
+the codewords `$|init|\ldots|tini|$'.
+
+@d init== {change this to `$\\{init}\equiv\.{@@\{}$' in the production version}
+@d tini== {change this to `$\\{tini}\equiv\.{@@\}}$' in the production version}
+@f init==begin
+@f tini==end
+
+@<Initialize whatever...@>=
+@<Set initial values of key variables@>@/
+@!init @<Initialize table entries (done by \.{INITEX} only)@>@;@+tini
+
+@ If the first character of a \PASCAL\ comment is a dollar sign,
+\ph\ treats the comment as a list of ``compiler directives'' that will
+affect the translation of this program into machine language. The
+directives shown below specify full checking and inclusion of the \PASCAL\
+debugger when \TeX\ is being debugged, but they cause range checking and other
+redundant code to be eliminated when the production system is being generated.
+Arithmetic overflow will be detected in all cases.
+@^system dependencies@>
+@^Overflow in arithmetic@>
+
+@<Compiler directives@>=
+@{@&$C-,A+,D-@} {no range check, catch arithmetic overflow, no debug overhead}
+@!debug @{@&$C+,D+@}@+ gubed {but turn everything on when debugging}
+
+@ This \TeX\ implementation conforms to the rules of the {\sl Pascal User
+@:PASCAL}{\PASCAL@>
+@^system dependencies@>
+Manual} published by Jensen and Wirth in 1975, except where system-dependent
+@^Wirth, Niklaus@>
+@^Jensen, Kathleen@>
+code is necessary to make a useful system program, and except in another
+respect where such conformity would unnecessarily obscure the meaning
+and clutter up the code: We assume that |case| statements may include a
+default case that applies if no matching label is found. Thus, we shall use
+constructions like
+$$\vbox{\halign{\ignorespaces#\hfil\cr
+|case x of|\cr
+1: $\langle\,$code for $x=1\,\rangle$;\cr
+3: $\langle\,$code for $x=3\,\rangle$;\cr
+|othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr
+|endcases|\cr}}$$
+since most \PASCAL\ compilers have plugged this hole in the language by
+incorporating some sort of default mechanism. For example, the \ph\
+compiler allows `|others|:' as a default label, and other \PASCAL s allow
+syntaxes like `\&{else}' or `\&{otherwise}' or `\\{otherwise}:', etc. The
+definitions of |othercases| and |endcases| should be changed to agree with
+local conventions. Note that no semicolon appears before |endcases| in
+this program, so the definition of |endcases| should include a semicolon
+if the compiler wants one. (Of course, if no default mechanism is
+available, the |case| statements of \TeX\ will have to be laboriously
+extended by listing all remaining cases. People who are stuck with such
+\PASCAL s have, in fact, done this, successfully but not happily!)
+
+@d othercases == others: {default for cases not listed explicitly}
+@d endcases == @+end {follows the default case in an extended |case| statement}
+@f othercases == else
+@f endcases == end
+
+@ The following parameters can be changed at compile time to extend or
+reduce \TeX's capacity. They may have different values in \.{INITEX} and
+in production versions of \TeX.
+@.INITEX@>
+@^system dependencies@>
+
+@<Constants...@>=
+@!buf_size=500; {maximum number of characters simultaneously present in
+ current lines of open files and in control sequences between
+ \.{\\csname} and \.{\\endcsname}; must not exceed |max_halfword|}
+@!error_line=72; {width of context lines on terminal error messages}
+@!half_error_line=42; {width of first lines of contexts in terminal
+ error messages; should be between 30 and |error_line-15|}
+@!max_print_line=79; {width of longest text lines output; should be at least 60}
+@!stack_size=200; {maximum number of simultaneous input sources}
+@!max_in_open=6; {maximum number of input files and error insertions that
+ can be going on simultaneously}
+@!param_size=60; {maximum number of simultaneous macro parameters}
+@!nest_size=40; {maximum number of semantic levels simultaneously active}
+@!max_strings=3000; {maximum number of strings; must not exceed |max_halfword|}
+@!string_vacancies=8000; {the minimum number of characters that should be
+ available for the user's control sequences and font names,
+ after \TeX's own error messages are stored}
+@!pool_size=32000; {maximum number of characters in strings, including all
+ error messages and help texts, and the names of all fonts and
+ control sequences; must exceed |string_vacancies| by the total
+ length of \TeX's own strings, which is currently about 23000}
+@!save_size=600; {space for saving values outside of current group; must be
+ at most |max_halfword|}
+@!dvi_buf_size=800; {size of the output buffer; must be a multiple of 8}
+@!expand_depth=10000; {limits recursive calls of the |expand| procedure}
+@!file_name_size=40; {file names shouldn't be longer than this}
+@!pool_name='TeXformats:TEX.POOL ';
+ {string of length |file_name_size|; tells where the string pool appears}
+@.TeXformats@>
+@!active_mem_size=50000; {number of words of |active_info| for active ocps}
+@!ocp_maxint=@"10000000;
+
+
+@ Like the preceding parameters, the following quantities can be changed
+at compile time to extend or reduce \TeX's capacity. But if they are changed,
+it is necessary to rerun the initialization program \.{INITEX}
+@.INITEX@>
+to generate new tables for the production \TeX\ program.
+One can't simply make helter-skelter changes to the following constants,
+since certain rather complex initialization
+numbers are computed from them. They are defined here using
+\.{WEB} macros, instead of being put into \PASCAL's |const| list, in order to
+emphasize this distinction.
+
+@d font_base=0 {smallest internal font number; must not be less
+ than |min_quarterword|}
+@d hash_size=2100 {maximum number of control sequences; it should be at most
+ about |(fix_mem_max-fix_mem_min)/10|}
+@d hash_prime=1777 {a prime number equal to about 85\pct! of |hash_size|}
+@d ocp_base=0 {smallest internal ocp number; must not be less
+ than |min_quarterword|}
+@d ocp_biggest=32767 {the real biggest ocp}
+@d number_ocps=ocp_biggest-ocp_base+1
+@d ocp_list_base=0 {smallest internal ocp list number; must not be less
+ than |min_quarterword|}
+@d ocp_list_biggest=32727 {the real biggest ocp list}
+@d number_ocp_lists=ocp_list_biggest-ocp_list_base+1
+@d max_active_ocp_lists=32768
+@d biggest_reg=65535 {the largest allowed register number; must be |<=max_quarterword|}
+@d number_regs=65536 {|biggest_reg+1|}
+@d number_attrs=65536 {total numbeer of attributes}
+@d biggest_mark=65535 {the largest allowed marks class; must be |<=max_quarterword|}
+@d number_marks=65536 {|biggest_mark+1|}
+{using |2^20+2^16| characters instead of |2^21| saves 286MB on the virtual memory size
+ of the running executable}
+@d biggest_char=1114111 {2097151} {the largest allowed character number; must be |<=max_halfword|}
+@d too_big_char=1114112 {2097152} {|biggest_char+1|}
+@d special_char=1114113 {2097153} {|biggest_char+2|}
+@d number_chars=1114112 {2097152} {|biggest_char+1|}
+@d number_active_chars=65536+65536 {to reduce the memory req. only two planes }
+@d string_offset=2097152
+@d font_biggest=5535 {the real biggest font}
+@d number_fonts=font_biggest-font_base+1
+@d number_math_fonts=768
+@d math_font_biggest=767
+@d biggest_lang=32767
+@d too_big_lang=32768
+@d text_size=0 {size code for the largest size in a family}
+@d script_size=256 {size code for the medium size in a family}
+@d script_script_size=512 {size code for the smallest size in a family}
+
+
+@ In case somebody has inadvertently made bad settings of the ``constants,''
+\TeX\ checks them using a global variable called |bad|.
+
+This is the first of many sections of \TeX\ where global variables are
+defined.
+
+@<Glob...@>=
+@!bad:integer; {is some ``constant'' wrong?}
+@!luainit:boolean; {are we using lua for initializations }
+@!tracefilenames:boolean; { print file open-close info? }
+
+@ Later on we will say `\ignorespaces|if X>=max_halfword then bad:=14|',
+or something similar. (We can't do that until |max_halfword| has been defined.)
+
+@<Check the ``constant'' values for consistency@>=
+bad:=0;
+if not luainit then tracefilenames:=true;
+if (half_error_line<30)or(half_error_line>error_line-15) then bad:=1;
+if max_print_line<60 then bad:=2;
+if dvi_buf_size mod 8<>0 then bad:=3;
+if hash_prime>hash_size then bad:=5;
+if max_in_open>=128 then bad:=6;
+{ |if null_list<256 then bad:=7;| } {we will want |null_list>255|}
+
+@ Labels are given symbolic names by the following definitions, so that
+occasional |goto| statements will be meaningful. We insert the label
+`|exit|' just before the `\ignorespaces|end|\unskip' of a procedure in
+which we have used the `|return|' statement defined below; the label
+`|restart|' is occasionally used at the very beginning of a procedure; and
+the label `|reswitch|' is occasionally used just prior to a |case|
+statement in which some cases change the conditions and we wish to branch
+to the newly applicable case. Loops that are set up with the |loop|
+construction defined below are commonly exited by going to `|done|' or to
+`|found|' or to `|not_found|', and they are sometimes repeated by going to
+`|continue|'. If two or more parts of a subroutine start differently but
+end up the same, the shared code may be gathered together at
+`|common_ending|'.
+
+Incidentally, this program never declares a label that isn't actually used,
+because some fussy \PASCAL\ compilers will complain about redundant labels.
+
+@d exit=10 {go here to leave a procedure}
+@d restart=20 {go here to start a procedure again}
+@d reswitch=21 {go here to start a case statement again}
+@d continue=22 {go here to resume a loop}
+@d done=30 {go here to exit a loop}
+@d done1=31 {like |done|, when there is more than one loop}
+@d done2=32 {for exiting the second loop in a long block}
+@d done3=33 {for exiting the third loop in a very long block}
+@d done4=34 {for exiting the fourth loop in an extremely long block}
+@d done5=35 {for exiting the fifth loop in an immense block}
+@d done6=36 {for exiting the sixth loop in a block}
+@d found=40 {go here when you've found it}
+@d found1=41 {like |found|, when there's more than one per routine}
+@d found2=42 {like |found|, when there's more than two per routine}
+@d not_found=45 {go here when you've found nothing}
+@d not_found1=46 {like |not_found|, when there's more than one}
+@d not_found2=47 {like |not_found|, when there's more than two}
+@d not_found3=48 {like |not_found|, when there's more than three}
+@d not_found4=49 {like |not_found|, when there's more than four}
+@d common_ending=50 {go here when you want to merge with another branch}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d negate(#) == #:=-# {change the sign of a variable}
+@d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
+@f loop == xclause
+ {\.{WEB}'s |xclause| acts like `\ignorespaces|while true do|\unskip'}
+@d do_nothing == pdfassert(1) {empty statement}
+@d return == goto exit {terminate a procedure call}
+@f return == nil
+@d empty=0 {symbolic name for a null constant}
+
+@* \[2] The character set.
+In order to make \TeX\ readily portable to a wide variety of
+computers, all of its input text is converted to an internal
+twenty-one-bit code that covers all of unicode, including ASCII, the
+``American Standard Code for Information Interchange.'' This
+conversion is done immediately when each character is read
+in. Conversely, characters are converted from ASCII to the user's
+external representation just before they are output to a text file.
+
+Such an internal code is relevant to users of \TeX\ primarily because it
+governs the positions of characters in the fonts. For example, the
+character `\.A' has ASCII code $65=@'101$, and when \TeX\ typesets
+this letter it specifies character number 65 in the current font.
+If that font actually has `\.A' in a different position, \TeX\ doesn't
+know what the real position is; the program that does the actual printing from
+\TeX's device-independent files is responsible for converting from ASCII to
+a particular font encoding.
+@^ASCII code@>
+
+\TeX's internal code also defines the value of constants
+that begin with a reverse apostrophe; and it provides an index to the
+\.{\\catcode}, \.{\\mathcode}, \.{\\uccode}, \.{\\lccode}, and \.{\\delcode}
+tables.
+
+@ Characters of text that have been converted to \TeX's internal form
+are said to be of type |ASCII_code|, which is a subrange of the integers.
+
+@<Types...@>=
+@!ASCII_code=0..biggest_char; {eight-bit numbers}
+@!BMP_code=0..65535; {sixteen-bit numbers}
+
+@ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
+character sets were common, so it did not make provision for lowercase
+letters. Nowadays, of course, we need to deal with both capital and small
+letters in a convenient way, especially in a program for typesetting;
+so the present specification of \TeX\ has been written under the assumption
+that the \PASCAL\ compiler and run-time system permit the use of text files
+with more than 64 distinguishable characters. More precisely, we assume that
+the character set contains at least the letters and symbols associated
+with ASCII codes @'40 through @'176; all of these characters are now
+available on most computer terminals.
+
+Since we are dealing with more characters than were present in the first
+\PASCAL\ compilers, we have to decide what to call the associated data
+type. Some \PASCAL s use the original name |char| for the
+characters in text files, even though there now are more than 64 such
+characters, while other \PASCAL s consider |char| to be a 64-element
+subrange of a larger data type that has some other name.
+
+In order to accommodate this difference, we shall use the name |text_char|
+to stand for the data type of the characters that are converted to and
+from |ASCII_code| when they are input and output. We shall also assume
+that |text_char| consists of the elements |chr(first_text_char)| through
+|chr(last_text_char)|, inclusive. The following definitions should be
+adjusted if necessary.
+@^system dependencies@>
+
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=255 {ordinal number of the largest element of |text_char|}
+
+@<Local variables for init...@>=
+@!i:integer;
+
+@ The \TeX\ processor converts between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to \PASCAL's |ord| and |chr| functions.
+
+@<Glob...@>=
+@!xchr: array [ASCII_code] of text_char;
+ {specifies conversion of output characters}
+
+@ Since we are assuming that our \PASCAL\ system is able to read and
+write the visible characters of standard ASCII (although not
+necessarily using the ASCII codes to represent them), the following
+assignment statements initialize the standard part of the |xchr| array
+properly, without needing any system-dependent changes. On the other
+hand, it is possible to implement \TeX\ with less complete character
+sets, and in such cases it will be necessary to change something here.
+@^system dependencies@>
+
+@<Set init...@>=
+xchr[@'40]:=' ';
+xchr[@'41]:='!';
+xchr[@'42]:='"';
+xchr[@'43]:='#';
+xchr[@'44]:='$';
+xchr[@'45]:='%';
+xchr[@'46]:='&';
+xchr[@'47]:='''';@/
+xchr[@'50]:='(';
+xchr[@'51]:=')';
+xchr[@'52]:='*';
+xchr[@'53]:='+';
+xchr[@'54]:=',';
+xchr[@'55]:='-';
+xchr[@'56]:='.';
+xchr[@'57]:='/';@/
+xchr[@'60]:='0';
+xchr[@'61]:='1';
+xchr[@'62]:='2';
+xchr[@'63]:='3';
+xchr[@'64]:='4';
+xchr[@'65]:='5';
+xchr[@'66]:='6';
+xchr[@'67]:='7';@/
+xchr[@'70]:='8';
+xchr[@'71]:='9';
+xchr[@'72]:=':';
+xchr[@'73]:=';';
+xchr[@'74]:='<';
+xchr[@'75]:='=';
+xchr[@'76]:='>';
+xchr[@'77]:='?';@/
+xchr[@'100]:='@@';
+xchr[@'101]:='A';
+xchr[@'102]:='B';
+xchr[@'103]:='C';
+xchr[@'104]:='D';
+xchr[@'105]:='E';
+xchr[@'106]:='F';
+xchr[@'107]:='G';@/
+xchr[@'110]:='H';
+xchr[@'111]:='I';
+xchr[@'112]:='J';
+xchr[@'113]:='K';
+xchr[@'114]:='L';
+xchr[@'115]:='M';
+xchr[@'116]:='N';
+xchr[@'117]:='O';@/
+xchr[@'120]:='P';
+xchr[@'121]:='Q';
+xchr[@'122]:='R';
+xchr[@'123]:='S';
+xchr[@'124]:='T';
+xchr[@'125]:='U';
+xchr[@'126]:='V';
+xchr[@'127]:='W';@/
+xchr[@'130]:='X';
+xchr[@'131]:='Y';
+xchr[@'132]:='Z';
+xchr[@'133]:='[';
+xchr[@'134]:='\';
+xchr[@'135]:=']';
+xchr[@'136]:='^';
+xchr[@'137]:='_';@/
+xchr[@'140]:='`';
+xchr[@'141]:='a';
+xchr[@'142]:='b';
+xchr[@'143]:='c';
+xchr[@'144]:='d';
+xchr[@'145]:='e';
+xchr[@'146]:='f';
+xchr[@'147]:='g';@/
+xchr[@'150]:='h';
+xchr[@'151]:='i';
+xchr[@'152]:='j';
+xchr[@'153]:='k';
+xchr[@'154]:='l';
+xchr[@'155]:='m';
+xchr[@'156]:='n';
+xchr[@'157]:='o';@/
+xchr[@'160]:='p';
+xchr[@'161]:='q';
+xchr[@'162]:='r';
+xchr[@'163]:='s';
+xchr[@'164]:='t';
+xchr[@'165]:='u';
+xchr[@'166]:='v';
+xchr[@'167]:='w';@/
+xchr[@'170]:='x';
+xchr[@'171]:='y';
+xchr[@'172]:='z';
+xchr[@'173]:='{';
+xchr[@'174]:='|';
+xchr[@'175]:='}';
+xchr[@'176]:='~';@/
+
+@ Some of the ASCII codes without visible characters have been given symbolic
+names in this program because they are used with a special meaning.
+
+@d null_code=@'0 {ASCII code that might disappear}
+@d carriage_return=@'15 {ASCII code used at end of line}
+@d invalid_code=@'177 {ASCII code that many systems prohibit in text files}
+
+@ The ASCII code is ``standard'' only to a certain extent, since many
+computer installations have found it advantageous to have ready access
+to more than 94 printing characters. Appendix~C of {\sl The \TeX book\/}
+gives a complete specification of the intended correspondence between
+characters and \TeX's internal representation.
+@:TeXbook}{\sl The \TeX book@>
+
+If \TeX\ is being used
+on a garden-variety \PASCAL\ for which only standard ASCII
+codes will appear in the input and output files, it doesn't really matter
+what codes are specified in |xchr[0..@'37]|, but the safest policy is to
+blank everything out by using the code shown below.
+
+However, other settings of |xchr| will make \TeX\ more friendly on
+computers that have an extended character set, so that users can type things
+like `\.^^Z' instead of `\.{\\ne}'. People with extended character sets can
+assign codes arbitrarily, giving an |xchr| equivalent to whatever
+characters the users of \TeX\ are allowed to have in their input files.
+It is best to make the codes correspond to the intended interpretations as
+shown in Appendix~C whenever possible; but this is not necessary. For
+example, in countries with an alphabet of more than 26 letters, it is
+usually best to map the additional letters into codes less than~@'40.
+To get the most ``permissive'' character set, change |' '| on the
+right of these assignment statements to |chr(i)|.
+@^character set dependencies@>
+@^system dependencies@>
+
+@<Set init...@>=
+for i:=0 to biggest_char do xchr[i]:=i;
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
+where |i<j<@'177|, the value of |xord[xchr[i]]| will turn out to be
+|j| or more; hence, standard ASCII code numbers will be used instead of
+codes below @'40 in case there is a coincidence.
+
+@<Set init...@>=
+
+@* \[3] Input and output.
+The bane of portability is the fact that different operating systems treat
+input and output quite differently, perhaps because computer scientists
+have not given sufficient attention to this problem. People have felt somehow
+that input and output are not part of ``real'' programming. Well, it is true
+that some kinds of programming are more fun than others. With existing
+input/output conventions being so diverse and so messy, the only sources of
+joy in such parts of the code are the rare occasions when one can find a
+way to make the program a little less bad than it might have been. We have
+two choices, either to attack I/O now and get it over with, or to postpone
+I/O until near the end. Neither prospect is very attractive, so let's
+get it over with.
+
+The basic operations we need to do are (1)~inputting and outputting of
+text, to or from a file or the user's terminal; (2)~inputting and
+outputting of eight-bit bytes, to or from a file; (3)~instructing the
+operating system to initiate (``open'') or to terminate (``close'') input or
+output from a specified file; (4)~testing whether the end of an input
+file has been reached.
+
+\TeX\ needs to deal with two kinds of files.
+We shall use the term |alpha_file| for a file that contains textual data,
+and the term |byte_file| for a file that contains eight-bit binary information.
+These two types turn out to be the same on many computers, but
+sometimes there is a significant distinction, so we shall be careful to
+distinguish between them. Standard protocols for transferring
+such files from computer to computer, via high-speed networks, are
+now becoming available to more and more communities of users.
+
+The program actually makes use also of a third kind of file, called a
+|word_file|, when dumping and reloading base information for its own
+initialization. We shall define a word file later; but it will be possible
+for us to specify simple operations on word files before they are defined.
+
+@<Types...@>=
+@!eight_bits=0..65535; {unsigned one-byte quantity}
+@!real_eight_bits=0..255; {unsigned one-byte quantity}
+@!alpha_file=packed file of text_char; {files that contain textual data}
+@!byte_file=packed file of real_eight_bits; {files that contain binary data}
+
+@ Most of what we need to do with respect to input and output can be handled
+by the I/O facilities that are standard in \PASCAL, i.e., the routines
+called |get|, |put|, |eof|, and so on. But
+standard \PASCAL\ does not allow file variables to be associated with file
+names that are determined at run time, so it cannot be used to implement
+\TeX; some sort of extension to \PASCAL's ordinary |reset| and |rewrite|
+is crucial for our purposes. We shall assume that |nameoffile| is a variable
+of an appropriate type such that the \PASCAL\ run-time system being used to
+implement \TeX\ can open a file whose external name is specified by
+|nameoffile|.
+@^system dependencies@>
+
+@<Glob...@>=
+@!nameoffile:packed array[1..file_name_size] of char;@;@/
+ {on some systems this may be a \&{record} variable}
+@!namelength:0..file_name_size;@/{this many characters are actually
+ relevant in |nameoffile| (the rest are blank)}
+@!name_file_pointer:alpha_file;
+
+@ The \ph\ compiler with which the present version of \TeX\ was prepared has
+extended the rules of \PASCAL\ in a very convenient way. To open file~|f|,
+we can write
+$$\vbox{\halign{#\hfil\qquad&#\hfil\cr
+|reset(f,@t\\{name}@>,'/O')|&for input;\cr
+|rewrite(f,@t\\{name}@>,'/O')|&for output.\cr}}$$
+The `\\{name}' parameter, which is of type `{\bf packed array
+$[\langle\\{any}\rangle]$ of \\{char}}', stands for the name of
+the external file that is being opened for input or output.
+Blank spaces that might appear in \\{name} are ignored.
+
+The `\.{/O}' parameter tells the operating system not to issue its own
+error messages if something goes wrong. If a file of the specified name
+cannot be found, or if such a file cannot be opened for some other reason
+(e.g., someone may already be trying to write the same file), we will have
+|@!erstat(f)<>0| after an unsuccessful |reset| or |rewrite|. This allows
+\TeX\ to undertake appropriate corrective action.
+@:PASCAL H}{\ph@>
+@^system dependencies@>
+
+\TeX's file-opening procedures return |false| if no file identified by
+|nameoffile| could be opened.
+
+@d reset_OK(#)==erstat(#)=0
+@d rewrite_OK(#)==erstat(#)=0
+
+@p function a_open_in(var f:alpha_file):boolean;
+ {open a text file for input}
+begin reset(f,nameoffile,'/O'); a_open_in:=reset_OK(f);
+end;
+@#
+function a_open_out(var f:alpha_file):boolean;
+ {open a text file for output}
+begin rewrite(f,nameoffile,'/O'); a_open_out:=rewrite_OK(f);
+end;
+@#
+function b_open_in(var f:byte_file):boolean;
+ {open a binary file for input}
+begin reset(f,nameoffile,'/O'); b_open_in:=reset_OK(f);
+end;
+@#
+function b_open_out(var f:byte_file):boolean;
+ {open a binary file for output}
+begin rewrite(f,nameoffile,'/O'); b_open_out:=rewrite_OK(f);
+end;
+@#
+function w_open_in(var f:word_file):boolean;
+ {open a word file for input}
+begin reset(f,nameoffile,'/O'); w_open_in:=reset_OK(f);
+end;
+@#
+function w_open_out(var f:word_file):boolean;
+ {open a word file for output}
+begin rewrite(f,nameoffile,'/O'); w_open_out:=rewrite_OK(f);
+end;
+
+@ When input files are opened via a callback, they will also be read using
+callbacks. for that purpose, the |open_read_file_callback| returns an
+integer to uniquely identify a callback table. This id replaces the file
+point |f| in this case, because the input does not have to be a file
+in the traditional sense.
+
+Signalling this fact is achieved by having two arrays of integers.
+
+@<Glob...@>=
+@!input_file_callback_id : ^integer;
+@!read_file_callback_id : array[0..16] of integer;
+
+@
+@p function lua_a_open_in(var f:alpha_file; n:quarterword):boolean;
+var k:integer; { a temporary value }
+ fnam:str_number; { string returned by find callback }
+ callback_id:integer;
+ file_ok:boolean; { the status so far }
+begin
+ file_ok:=true;
+ if n=0 then begin
+ texinputtype := 1; {Tell |open_input| we are \.{\\input}.}
+ input_file_callback_id[index] := 0;
+ end
+ else begin
+ texinputtype:=0;
+ read_file_callback_id[n] := 0;
+ end;
+ callback_id:=callback_defined(find_read_file_callback);
+ if callback_id>0 then begin
+ fnam:=0;
+ file_ok:=run_callback(callback_id,'dS->s',n,stringcast(nameoffile+1),addressof(fnam));
+ if (file_ok)and(fnam<>0)and(length(fnam)>0) then begin
+ @<Fixup |nameoffile| after callback@>;
+ end
+ else
+ file_ok:=false; {file not found}
+ end;
+ if file_ok then begin
+ callback_id:=callback_defined(open_read_file_callback);
+ if callback_id>0 then begin
+ k := run_and_save_callback(callback_id,'S->',stringcast(nameoffile+1));
+ if k>0 then begin
+ lua_a_open_in := true;
+ if n=0 then
+ input_file_callback_id[index] := k
+ else
+ read_file_callback_id[n] := k;
+ end
+ else
+ file_ok:=false; {read failed}
+ end
+ else begin {no read callback}
+ if openinnameok(stringcast(nameoffile+1)) then begin
+ lua_a_open_in := a_open_in(f,kpsetexformat);
+ name_file_pointer := f;
+ end
+ else
+ file_ok:=false; {open failed}
+ end;
+ end;
+ if not file_ok then begin
+ lua_a_open_in := false;
+ name_file_pointer := 0;
+ end;
+end;
+@#
+function lua_a_open_out(var f:alpha_file; n:quarterword):boolean;
+var test:boolean;
+ k:integer;
+ fnam:str_number;
+ callback_id:integer;
+begin
+ name_file_pointer := 0;
+ callback_id:=callback_defined(find_write_file_callback);
+ if callback_id>0 then begin
+ fnam:=0;
+ test:=run_callback(callback_id,'dS->s',n,stringcast(nameoffile+1),addressof(fnam));
+ if (test)and(fnam<>0)and(length(fnam)>0) then begin
+ @<Fixup |nameoffile| after callback@>;
+ lua_a_open_out := do_a_open_out(f);
+ name_file_pointer := f;
+ end
+ else
+ lua_a_open_out := false;
+ end
+ else begin
+ if openoutnameok(stringcast(nameoffile+1)) then begin
+ lua_a_open_out := a_open_out(f);
+ name_file_pointer := f;
+ end
+ else
+ lua_a_open_out := false;
+ end;
+end;
+function lua_b_open_out(var f:alpha_file):boolean;
+var test:boolean;
+ k:integer;
+ fnam:str_number;
+ callback_id:integer;
+begin
+ name_file_pointer := 0;
+ callback_id:=callback_defined(find_output_file_callback);
+ if callback_id>0 then begin
+ fnam:=0;
+ test:=run_callback(callback_id,'S->s',stringcast(nameoffile+1),addressof(fnam));
+ if (test)and(fnam<>0)and(length(fnam)>0) then begin
+ @<Fixup |nameoffile| after callback@>;
+ lua_b_open_out := do_b_open_out(f);
+ name_file_pointer := f;
+ end
+ else
+ lua_b_open_out := false;
+ end
+ else begin
+ if openoutnameok(stringcast(nameoffile+1)) then begin
+ lua_b_open_out := b_open_out(f);
+ name_file_pointer := f;
+ end
+ else
+ lua_b_open_out := false;
+ end;
+end;
+
+@
+@<Fixup |nameoffile| after callback@>=
+libcfree (nameoffile);
+nameoffile := xmallocarray (packed_ASCII_code, length(fnam)+2);
+for k:=str_start_macro(fnam) to str_start_macro(fnam+1)-1 do
+ nameoffile[k-str_start_macro(fnam)+1] := str_pool[k];
+nameoffile[length(fnam)+1]:=0;
+namelength := length(fnam);
+flush_string
+
+@ Files can be closed with the \ph\ routine `|close(f)|', which
+@^system dependencies@>
+should be used when all input or output with respect to |f| has been completed.
+This makes |f| available to be opened again, if desired; and if |f| was used for
+output, the |close| operation makes the corresponding external file appear
+on the user's area, ready to be read.
+
+These procedures should not generate error messages if a file is
+being closed before it has been successfully opened.
+
+@p procedure a_close(var f:alpha_file); {close a text file}
+begin close(f);
+end;
+@#
+procedure b_close(var f:byte_file); {close a binary file}
+begin close(f);
+end;
+@#
+procedure w_close(var f:word_file); {close a word file}
+begin close(f);
+end;
+
+
+@
+
+@p procedure lua_a_close_in(var f:alpha_file; n:quarterword); {close a text file}
+var ret:boolean;
+ callback_id:integer;
+begin
+if n=0 then
+ callback_id:=input_file_callback_id[index]
+else
+ callback_id:=read_file_callback_id[n];
+if callback_id>0 then begin
+ ret:=run_saved_callback(callback_id,'close','->');
+ destroy_saved_callback(callback_id);
+ if n=0 then
+ input_file_callback_id[index] := 0
+ else
+ read_file_callback_id[n] := 0;
+ end
+else
+ a_close(f);
+end;
+@#
+procedure lua_a_close_out(var f:alpha_file); {close a text file}
+begin
+ a_close(f);
+end;
+
+
+@ Binary input and output are done with \PASCAL's ordinary |get| and |put|
+procedures, so we don't have to make any other special arrangements for
+binary~I/O. Text output is also easy to do with standard \PASCAL\ routines.
+The treatment of text input is more difficult, however, because
+of the necessary translation to |ASCII_code| values.
+\TeX's conventions should be efficient, and they should
+blend nicely with the user's operating environment.
+
+@ Input from text files is read one line at a time, using a routine called
+|lua_input_ln|. This function is defined in terms of global variables called
+|buffer|, |first|, and |last| that will be described in detail later; for
+now, it suffices for us to know that |buffer| is an array of |ASCII_code|
+values, and that |first| and |last| are indices into this array
+representing the beginning and ending of a line of text.
+
+@<Glob...@>=
+@!buffer:array[0..buf_size] of packed_ASCII_code; {lines of characters being read}
+@!first:0..buf_size; {the first unused position in |buffer|}
+@!last:0..buf_size; {end of the line just input to |buffer|}
+@!max_buf_stack:0..buf_size; {largest index used in |buffer|}
+
+@ The |lua_input_ln| function brings the next line of input from the specified
+file into available positions of the buffer array and returns the value
+|true|, unless the file has already been entirely read, in which case it
+returns |false| and sets |last:=first|. In general, the |ASCII_code|
+numbers that represent the next line of the file are input into
+|buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
+global variable |last| is set equal to |first| plus the length of the
+line. Trailing blanks are removed from the line; thus, either |last=first|
+(in which case the line was entirely blank) or |buffer[last-1]<>" "|.
+
+An overflow error is given, however, if the normal actions of |lua_input_ln|
+would make |last>=buf_size|; this is done so that other parts of \TeX\
+can safely look at the contents of |buffer[last+1]| without overstepping
+the bounds of the |buffer| array. Upon entry to |lua_input_ln|, the condition
+|first<buf_size| will always hold, so that there is always room for an
+``empty'' line.
+
+The variable |max_buf_stack|, which is used to keep track of how large
+the |buf_size| parameter must be to accommodate the present job, is
+also kept up to date by |lua_input_ln|.
+
+If the |bypass_eoln| parameter is |true|, |lua_input_ln| will do a |get|
+before looking at the first character of the line; this skips over
+an |eoln| that was in |f^|. The procedure does not do a |get| when it
+reaches the end of the line; therefore it can be used to acquire input
+from the user's terminal as well as from ordinary text files.
+
+Standard \PASCAL\ says that a file should have |eoln| immediately
+before |eof|, but \TeX\ needs only a weaker restriction: If |eof|
+occurs in the middle of a line, the system function |eoln| should return
+a |true| result (even though |f^| will be undefined).
+
+Since the inner loop of |lua_input_ln| is part of \TeX's ``inner loop''---each
+character of input comes in at this place---it is wise to reduce system
+overhead by making use of special routines that read in an entire array
+of characters at once, if such routines are available. The following
+code uses standard \PASCAL\ to illustrate what needs to be done, but
+finer tuning is often possible at well-developed \PASCAL\ sites.
+@^inner loop@>
+
+@p function input_ln(var f:alpha_file;@!bypass_eoln:boolean):boolean;
+ {inputs the next line or returns |false|}
+var last_nonblank:0..buf_size; {|last| with trailing blanks removed}
+begin if bypass_eoln then if not eof(f) then get(f);
+ {input the first character of the line into |f^|}
+last:=first; {cf.\ Matthew 19\thinspace:\thinspace30}
+if eof(f) then input_ln:=false
+else begin last_nonblank:=first;
+ while not eoln(f) do
+ begin if last>=max_buf_stack then
+ begin max_buf_stack:=last+1;
+ if max_buf_stack=buf_size then
+ @<Report overflow of the input buffer, and abort@>;
+ end;
+ buffer[last]:=f^; get(f); incr(last);
+ if buffer[last-1]<>" " then last_nonblank:=last;
+ end;
+ last:=last_nonblank; input_ln:=true;
+ end;
+end;
+
+function lua_input_ln(var f:alpha_file;n:quarterword;@!bypass_eoln:boolean):boolean;
+var lua_result:boolean;
+ last_ptr:integer;
+ callback_id:integer;
+ bypass_p:boolean;
+begin
+if n=0 then
+ callback_id:=input_file_callback_id[index]
+else
+ callback_id:=read_file_callback_id[n];
+if callback_id>0 then begin
+ last:=first;
+ last_ptr := first;
+ lua_result := run_saved_callback(callback_id,'reader','->l', addressof(last_ptr));
+ if (lua_result=true)and(last_ptr<>0) then begin
+ last := last_ptr;
+ if last>max_buf_stack then max_buf_stack:=last;
+ lua_input_ln := true;
+ @<Fix up the input buffer using callbacks@>;
+ end
+ else
+ lua_input_ln := false;
+ end
+ else begin
+ bypass_p := bypass_eoln; {this is for -Wextra}
+ lua_result := input_ln(f,bypass_p);
+ if lua_result=true then begin
+ lua_input_ln := true;
+ @<Fix up the input buffer using callbacks@>;
+ end
+ else
+ lua_input_ln := false;
+ end
+end;
+
+@
+@<Fix up the input buffer using callbacks@>=
+if last>=first then begin
+ callback_id := callback_defined(process_input_buffer_callback);
+ if callback_id>0 then begin
+ last_ptr := first;
+ lua_result := run_callback(callback_id, 'l->l', (last-first), addressof(last_ptr));
+ if (lua_result=true)and(last_ptr<>0) then begin
+ last := last_ptr;
+ if last>max_buf_stack then max_buf_stack:=last;
+ end;
+ end;
+ end
+
+
+
+@ The user's terminal acts essentially like other files of text, except
+that it is used both for input and for output. When the terminal is
+considered an input file, the file variable is called |term_in|, and when it
+is considered an output file the file variable is |term_out|.
+@^system dependencies@>
+
+@<Glob...@>=
+@!term_in:alpha_file; {the terminal as an input file}
+@!term_out:alpha_file; {the terminal as an output file}
+
+@ Here is how to open the terminal files
+in \ph. The `\.{/I}' switch suppresses the first |get|.
+@^system dependencies@>
+
+@d t_open_in==reset(term_in,'TTY:','/O/I') {open the terminal for text input}
+@d t_open_out==rewrite(term_out,'TTY:','/O') {open the terminal for text output}
+
+@ Sometimes it is necessary to synchronize the input/output mixture that
+happens on the user's terminal, and three system-dependent
+procedures are used for this
+purpose. The first of these, |update_terminal|, is called when we want
+to make sure that everything we have output to the terminal so far has
+actually left the computer's internal buffers and been sent.
+The second, |clear_terminal|, is called when we wish to cancel any
+input that the user may have typed ahead (since we are about to
+issue an unexpected error message). The third, |wake_up_terminal|,
+is supposed to revive the terminal if the user has disabled it by
+some instruction to the operating system. The following macros show how
+these operations can be specified in \ph:
+@^system dependencies@>
+
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+@d clear_terminal == break_in(term_in,true) {clear the terminal input buffer}
+@d wake_up_terminal == do_nothing {cancel the user's cancellation of output}
+
+@ We need a special routine to read the first line of \TeX\ input from
+the user's terminal. This line is different because it is read before we
+have opened the transcript file; there is sort of a ``chicken and
+egg'' problem here. If the user types `\.{\\input paper}' on the first
+line, or if some macro invoked by that line does such an \.{\\input},
+the transcript file will be named `\.{paper.log}'; but if no \.{\\input}
+commands are performed during the first line of terminal input, the transcript
+file will acquire its default name `\.{texput.log}'. (The transcript file
+will not contain error messages generated by the first line before the
+first \.{\\input} command.)
+@.texput@>
+
+The first line is even more special if we are lucky enough to have an operating
+system that treats \TeX\ differently from a run-of-the-mill \PASCAL\ object
+program. It's nice to let the user start running a \TeX\ job by typing
+a command line like `\.{tex paper}'; in such a case, \TeX\ will operate
+as if the first line of input were `\.{paper}', i.e., the first line will
+consist of the remainder of the command line, after the part that invoked
+\TeX.
+
+The first line is special also because it may be read before \TeX\ has
+input a format file. In such cases, normal error messages cannot yet
+be given. The following code uses concepts that will be explained later.
+(If the \PASCAL\ compiler does not support non-local |@!goto|\unskip, the
+@^system dependencies@>
+statement `|goto final_end|' should be replaced by something that
+quietly terminates the program.)
+
+@<Report overflow of the input buffer, and abort@>=
+if format_ident=0 then
+ begin writeln(term_out,'Buffer size exceeded!'); goto final_end;
+@.Buffer size exceeded@>
+ end
+else
+ check_buffer_overflow(buf_size+10) { need a little bit more}
+
+@ Different systems have different ways to get started. But regardless of
+what conventions are adopted, the routine that initializes the terminal
+should satisfy the following specifications:
+
+\yskip\textindent{1)}It should open file |term_in| for input from the
+ terminal. (The file |term_out| will already be open for output to the
+ terminal.)
+
+\textindent{2)}If the user has given a command line, this line should be
+ considered the first line of terminal input. Otherwise the
+ user should be prompted with `\.{**}', and the first line of input
+ should be whatever is typed in response.
+
+\textindent{3)}The first line of input, which might or might not be a
+ command line, should appear in locations |first| to |last-1| of the
+ |buffer| array.
+
+\textindent{4)}The global variable |loc| should be set so that the
+ character to be read next by \TeX\ is in |buffer[loc]|. This
+ character should not be blank, and we should have |loc<last|.
+
+\yskip\noindent(It may be necessary to prompt the user several times
+before a non-blank line comes in. The prompt is `\.{**}' instead of the
+later `\.*' because the meaning is slightly different: `\.{\\input}' need
+not be typed immediately after~`\.{**}'.)
+
+@d loc==cur_input.loc_field {location of first unread character in |buffer|}
+
+@ The following program does the required initialization
+without retrieving a possible command line.
+It should be clear how to modify this routine to deal with command lines,
+if the system permits them.
+@^system dependencies@>
+
+@p function init_terminal:boolean; {gets the terminal input started}
+label exit;
+begin t_open_in;
+loop@+begin wake_up_terminal; write(term_out,'**'); update_terminal;
+@.**@>
+ if not input_ln(term_in,true)
+then {this shouldn't happen}
+ begin writeln(term_out);
+ write(term_out,'! End of file on the terminal... why?');
+@.End of file on the terminal@>
+ init_terminal:=false; return;
+ end;
+ loc:=first;
+ while (loc<last)and(buffer[loc]=" ") do incr(loc);
+ if loc<last then
+ begin init_terminal:=true;
+ return; {return unless the line was all blank}
+ end;
+ writeln(term_out,'Please type the name of your input file.');
+ end;
+exit:end;
+
+@* \[4] String handling.
+Control sequence names and diagnostic messages are variable-length strings
+of eight-bit characters. Since \PASCAL\ does not have a well-developed string
+mechanism, \TeX\ does all of its string processing by homegrown methods.
+
+Elaborate facilities for dynamic strings are not needed, so all of the
+necessary operations can be handled with a simple data structure.
+The array |str_pool| contains all of the (eight-bit) ASCII codes in all
+of the strings, and the array |str_start| contains indices of the starting
+points of each string. Strings are referred to by integer numbers, so that
+string number |s| comprises the characters |str_pool[j]| for
+|str_start_macro(s)<=j<str_start_macro(s+1)|. Additional integer variables
+|pool_ptr| and |str_ptr| indicate the number of entries used so far
+in |str_pool| and |str_start|, respectively; locations
+|str_pool[pool_ptr]| and |str_start_macro(str_ptr)| are
+ready for the next string to be allocated.
+
+String numbers 0 to |biggest_char| are reserved for strings that correspond to single
+UNICODE characters. This is in accordance with the conventions of \.{WEB},
+@.WEB@>
+which converts single-character strings into the ASCII code number of the
+single character involved, while it converts other strings into integers
+and builds a string pool file. Thus, when the string constant \.{"."} appears
+in the program below, \.{WEB} converts it into the integer 46, which is the
+ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
+into some integer greater than~|biggest_char|.
+
+Some \PASCAL\ compilers won't pack integers into a single byte unless the
+integers lie in the range |-128..127|. To accommodate such systems
+we access the string pool only via macros that can easily be redefined.
+
+@d si(#) == # {convert from |ASCII_code| to |packed_ASCII_code|}
+@d so(#) == # {convert from |packed_ASCII_code| to |ASCII_code|}
+@d str_start_macro(#) == str_start[(#) - string_offset]
+
+@<Types...@>=
+@!pool_pointer = integer; {for variables that point into |str_pool|}
+@!str_number = integer; {for variables that point into |str_start|}
+@!packed_ASCII_code = 0..255; {elements of |str_pool| array}
+
+@ @<Glob...@>=
+@!str_pool:packed array[pool_pointer] of packed_ASCII_code; {the characters}
+@!str_start : array[str_number] of pool_pointer; {the starting pointers}
+@!pool_ptr : pool_pointer; {first unused position in |str_pool|}
+@!str_ptr : str_number; {number of the current string being created}
+@!init_pool_ptr : pool_pointer; {the starting value of |pool_ptr|}
+@!init_str_ptr : str_number; {the starting value of |str_ptr|}
+
+@ Several of the elementary string operations are performed using \.{WEB}
+macros instead of \PASCAL\ procedures, because many of the
+operations are done quite frequently and we want to avoid the
+overhead of procedure calls. For example, here is
+a simple macro that computes the length of a string.
+@.WEB@>
+
+@d length(#)==(str_start_macro(#+1)-str_start_macro(#)) {the number of characters
+ in string number \#}
+
+@ The length of the current string is called |cur_length|:
+
+@d cur_length == (pool_ptr - str_start_macro(str_ptr))
+
+@ Strings are created by appending character codes to |str_pool|.
+The |append_char| macro, defined here, does not check to see if the
+value of |pool_ptr| has gotten too high; this test is supposed to be
+made before |append_char| is used. There is also a |flush_char|
+macro, which erases the last character appended.
+
+To test if there is room to append |l| more characters to |str_pool|,
+we shall write |str_room(l)|, which aborts \TeX\ and gives an
+apologetic error message if there isn't enough room.
+
+@d append_char(#) == {put |ASCII_code| \# at the end of |str_pool|}
+begin str_pool[pool_ptr]:=si(#); incr(pool_ptr);
+end
+@d flush_char == decr(pool_ptr) {forget the last character in the pool}
+@d str_room(#) == check_pool_overflow((pool_ptr+#)) {test or grow the pool}
+
+@p procedure string_room(t:integer);
+begin
+ str_room(t);
+end;
+@#
+procedure append_pool_char(c:ASCII_code);
+begin
+ append_char(c);
+end;
+
+
+@ Once a sequence of characters has been appended to |str_pool|, it
+officially becomes a string when the function |make_string| is called.
+This function returns the identification number of the new string as its
+value.
+
+@p function make_string : str_number; {current string enters the pool}
+begin if str_ptr=(max_strings+string_offset) then
+ overflow("number of strings",max_strings-init_str_ptr);
+@:TeX capacity exceeded number of strings}{\quad number of strings@>
+incr(str_ptr); str_start_macro(str_ptr):=pool_ptr;
+make_string:=str_ptr-1;
+end;
+
+@ To destroy the most recently made string, we say |flush_string|.
+
+The helper routines reads one utf sequence from the pool resp. the
+buffer, and returns its character value.
+
+@d flush_string==begin decr(str_ptr); pool_ptr:=str_start_macro(str_ptr);
+ end
+@d test_sequence_byte(#)==if (#<@"80) or (#>=@"C0) then begin
+ print_err("Text line contains an invalid utf-8 sequence");
+@.Text line contains...@>
+ help2("A funny symbol that I can't read has just been input.")@/
+ ("Just continue, I'll change it to 0xFFFD.");@/
+ deletions_allowed:=false; error; deletions_allowed:=true;
+{the assigment before return is needed because web2c generates incorrect code}
+ a:=@"FFFD; buffer_to_unichar:=a; return; end
+
+
+@p function buffer_to_unichar(@!k:integer):integer;
+label exit;
+var a:@!integer; {a utf char}
+b:@!integer; { a utf nibble}
+begin
+ b := buffer[k];
+ if b<@"80 then
+ a := b
+ else if b>=@"F0 then begin
+ a := (b-@"F0) * 64;
+ b := buffer[k+1];
+ test_sequence_byte(b);
+ a := (a + (b-128)) * 64;
+ b := buffer[k+2];
+ test_sequence_byte(b);
+ a := (a + (b-128)) * 64;
+ b := buffer[k+3];
+ test_sequence_byte(b);
+ a := a + (b-128);
+ end
+ else if b>=@"E0 then begin
+ a := (b-@"E0) * 64;
+ b := buffer[k+1];
+ test_sequence_byte(b);
+ a := (a + (b-128)) * 64;
+ b := buffer[k+2];
+ test_sequence_byte(b);
+ a := a + (b-128);
+ end
+ else if b>=@"C0 then begin
+ a := (b-@"C0) * 64;
+ b := buffer[k+1];
+ test_sequence_byte(b);
+ a := a + (b-128);
+ end
+ else begin { NI: this is an encoding error }
+ print_err("Buffer contains an invalid utf-8 sequence");
+@.Text line contains...@>
+ help2("A funny symbol somehow ended up in the input buffer.")@/
+ ("Just continue, I'll change it to 0xFFFD.");@/
+ deletions_allowed:=false; error; deletions_allowed:=true;
+ a:=@"FFFD;
+ end;
+exit:
+ buffer_to_unichar := a;
+end ;
+
+
+
+@ The following subroutine compares string |s| with another string of the
+same length that appears in |buffer| starting at position |k|;
+the result is |true| if and only if the strings are equal.
+Empirical tests indicate that |str_eq_buf| is used in such a way that
+it tends to return |true| about 80 percent of the time.
+
+@p function str_eq_buf(@!s:str_number;@!k:integer):boolean;
+ {test equality of strings}
+label not_found; {loop exit}
+var j: pool_pointer; {running index}
+a: ASCII_code; {a unicode character }
+@!result: boolean; {result of comparison}
+begin result:=false;
+if s<string_offset then begin
+ a := buffer_to_unichar(k);
+ if a<>s then goto not_found;
+ end
+else begin
+j:=str_start_macro(s);
+while j<str_start_macro(s+1) do
+ begin if so(str_pool[j])<>buffer[k] then
+ begin goto not_found;
+ end;
+ incr(j); incr(k);
+ end;
+end;
+result:=true;
+not_found: str_eq_buf:=result;
+end;
+
+@ Here is a similar routine, but it compares two strings in the string pool,
+and it does not assume that they have the same length.
+
+@p function str_eq_str(@!s,@!t:str_number):boolean;
+ {test equality of strings}
+label found,not_found; {loop exit}
+var j,@!k: pool_pointer; {running indices}
+a: ASCII_code; {a utf char}
+@!result: boolean; {result of comparison}
+begin result:=false;
+a:= 0;
+if s<string_offset then begin
+ if t>=string_offset then begin
+ if s<=@"7F then
+ if length(t)=1 then
+ if str_pool[str_start_macro(t)]=s then
+ goto found;
+ a := pool_to_unichar(str_start_macro(t));
+ if a<>s then goto not_found;
+ end
+ else
+ if t<>s then goto not_found;
+ end
+else if t<string_offset then begin
+ if t<=@"7F then
+ if length(s)=1 then
+ if str_pool[str_start_macro(s)]=t then
+ goto found;
+ a := pool_to_unichar(str_start_macro(s));
+ if a<>t then goto not_found;
+ end
+else begin
+ if length(s)<>length(t) then goto not_found;
+ j:=str_start_macro(s); k:=str_start_macro(t);
+ while j<str_start_macro(s+1) do
+ begin if str_pool[j]<>str_pool[k] then goto not_found;
+ incr(j); incr(k);
+ end;
+ end;
+found: result:=true;
+not_found: str_eq_str:=result;
+end;
+
+@ The initial values of |str_pool|, |str_start|, |pool_ptr|,
+and |str_ptr| are computed by the \.{INITEX} program, based in part
+on the information that \.{WEB} has output while processing \TeX.
+@.INITEX@>
+@^string pool@>
+
+The first |string_offset| strings are single-characters strings matching
+Unicode. There is no point in generating all of these. But |str_ptr| has
+initialized properly, otherwise |print_char| cannot see the difference
+between characters and strings.
+
+@p @!init function get_strings_started:boolean; {initializes the string pool,
+ but returns |false| if something goes wrong}
+label done,exit;
+var @!g:str_number; {garbage}
+begin pool_ptr:=0; str_ptr:=string_offset; str_start[0]:=0;
+@<Read the other strings from the \.{TEX.POOL} file and return |true|,
+ or give an error message and return |false|@>;
+exit:end;
+tini
+
+@ @d app_lc_hex(#)==l:=#;
+ if l<10 then append_char(l+"0")@+else append_char(l-10+"a")
+
+@ The first 128 strings will contain 95 standard ASCII characters, and the
+other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
+unless a system-dependent change is made here. Installations that have
+an extended character set, where for example |xchr[@'32]=@t\.{\'^^Z\'}@>|,
+would like string @'32 to be the single character @'32 instead of the
+three characters @'136, @'136, @'132 (\.{\^\^Z}). On the other hand,
+even people with an extended character set will want to represent string
+@'15 by \.{\^\^M}, since @'15 is |carriage_return|; the idea is to
+produce visible strings instead of tabs or line-feeds or carriage-returns
+or bell-rings or characters that are treated anomalously in text files.
+
+Unprintable characters of codes 128--255 are, similarly, rendered
+\.{\^\^80}--\.{\^\^ff}.
+
+Unprintable characters of codes 256--|65535| are, similarly, rendered
+\.{\^\^\^\^0100}--\.{\^\^\^\^ffff}.
+
+The boolean expression defined here should be |true| unless \TeX\
+internal code number~|k| corresponds to a non-troublesome visible
+symbol in the local character set. An appropriate formula for the
+extended character set recommended in {\sl The \TeX book\/} would, for
+example, be `|k in [0,@'10..@'12,@'14,@'15,@'33,@'177..@'377]|'.
+If character |k| cannot be printed, and |k<@'200|, then character |k+@'100| or
+|k-@'100| must be printable; moreover, ASCII codes |[@'41..@'46,
+@'60..@'71, @'141..@'146, @'160..@'171]| must be printable.
+Thus, at least 80 printable characters are needed.
+@:TeXbook}{\sl The \TeX book@>
+@^character set dependencies@>
+@^system dependencies@>
+
+@ @<Read the other strings...@>=
+ g := loadpoolstrings((pool_size-string_vacancies));
+ if g=0 then begin
+ wake_up_terminal; writeln(term_out,'! You have to increase POOLSIZE.');
+ get_strings_started:=false;
+ return;
+ end;
+ get_strings_started:=true;
+
+@* \[5] On-line and off-line printing.
+Messages that are sent to a user's terminal and to the transcript-log file
+are produced by several `|print|' procedures. These procedures will
+direct their output to a variety of places, based on the setting of
+the global variable |selector|, which has the following possible
+values:
+
+\yskip
+\hang |term_and_log|, the normal setting, prints on the terminal and on the
+ transcript file.
+
+\hang |log_only|, prints only on the transcript file.
+
+\hang |term_only|, prints only on the terminal.
+
+\hang |no_print|, doesn't print at all. This is used only in rare cases
+ before the transcript file is open.
+
+\hang |pseudo|, puts output into a cyclic buffer that is used
+ by the |show_context| routine; when we get to that routine we shall discuss
+ the reasoning behind this curious mode.
+
+\hang |new_string|, appends the output to the current string in the
+ string pool.
+
+\hang 0 to 15, prints on one of the sixteen files for \.{\\write} output.
+
+\yskip
+\noindent The symbolic names `|term_and_log|', etc., have been assigned
+numeric codes that satisfy the convenient relations |no_print+1=term_only|,
+|no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|.
+
+Three additional global variables, |tally| and |term_offset| and
+|file_offset|, record the number of characters that have been printed
+since they were most recently cleared to zero. We use |tally| to record
+the length of (possibly very long) stretches of printing; |term_offset|
+and |file_offset|, on the other hand, keep track of how many characters
+have appeared so far on the current line that has been output to the
+terminal or to the transcript file, respectively.
+
+@d no_print=16 {|selector| setting that makes data disappear}
+@d term_only=17 {printing is destined for the terminal only}
+@d log_only=18 {printing is destined for the transcript file only}
+@d term_and_log=19 {normal |selector| setting}
+@d pseudo=20 {special |selector| setting for |show_context|}
+@d new_string=21 {printing is deflected to the string pool}
+@d max_selector=21 {highest selector setting}
+
+@<Glob...@>=
+@!log_file : alpha_file; {transcript of \TeX\ session}
+@!term_out_mode:halfword;
+@!term_out_translation:halfword;
+@!selector : 0..max_selector; {where to print a message}
+@!dig : array[0..22] of 0..15; {digits in a number being output}
+@!tally : integer; {the number of characters recently printed}
+@!term_offset : 0..max_print_line;
+ {the number of characters on the current terminal line}
+@!file_offset : 0..max_print_line;
+ {the number of characters on the current file line}
+@!trick_buf:array[0..error_line] of packed_ASCII_code; {circular buffer for
+ pseudoprinting}
+@!trick_count: integer; {threshold for pseudoprinting, explained later}
+@!first_count: integer; {another variable for pseudoprinting}
+@!inhibit_par_tokens:boolean; { for minor adjustments to |show_token_list| }
+
+@ @<Initialize the output routines@>=
+selector:=term_only; tally:=0; term_offset:=0; file_offset:=0;
+inhibit_par_tokens:=false;
+
+@ Macro abbreviations for output to the terminal and to the log file are
+defined here for convenience. Some systems need special conventions
+for terminal output, and it is possible to adhere to those conventions
+by changing |wterm|, |wterm_ln|, and |wterm_cr| in this section.
+@^system dependencies@>
+
+@d wterm(#)==write(term_out,#)
+@d wterm_ln(#)==writeln(term_out,#)
+@d wterm_cr==writeln(term_out)
+@d wlog(#)==write(log_file,#)
+@d wlog_ln(#)==writeln(log_file,#)
+@d wlog_cr==writeln(log_file)
+
+@ To end a line of text output, we call |print_ln|.
+
+@<Basic print...@>=
+procedure print_ln; {prints an end-of-line}
+begin case selector of
+term_and_log: begin wterm_cr; wlog_cr;
+ term_offset:=0; file_offset:=0;
+ end;
+log_only: begin wlog_cr; file_offset:=0;
+ end;
+term_only: begin wterm_cr; term_offset:=0;
+ end;
+no_print,pseudo,new_string: do_nothing;
+othercases writeln(write_file[selector])
+endcases;@/
+end; {|tally| is not affected}
+
+@ The |print_char| procedure sends one character to the desired destination,
+using the |xchr| array to map it into an external character compatible with
+|lua_input_ln|. All printing comes through |print_ln| or |print_char|.
+
+@d wterm_char(#)==begin if (#>=@"20)or(#=@"0A)or(#=@"0D)or(#=@"09) then wterm(xchr[#])
+ else begin if term_offset+2>=max_print_line then begin
+ wterm_cr; term_offset:=0;
+ end;
+ incr(term_offset); wterm('^'); incr(term_offset); wterm('^');
+ wterm(xchr[#+64]);
+ end; end
+@d fix_term_offset(#)==
+ if ((#>=@"C0) and (#<=@"DF) and (term_offset+2>=max_print_line)) or
+ ((#>=@"E0) and (#<=@"EF) and (term_offset+3>=max_print_line)) or
+ ((#>=@"F0) and (term_offset+4>=max_print_line)) then begin
+ wterm_cr; term_offset:=0;
+ end
+@d fix_log_offset(#)==
+ if ((#>=@"C0) and (#<=@"DF) and (file_offset+2>=max_print_line)) or
+ ((#>=@"E0) and (#<=@"EF) and (file_offset+3>=max_print_line)) or
+ ((#>=@"F0) and (file_offset+4>=max_print_line)) then begin
+ wlog_cr; file_offset:=0;
+ end
+
+@<Basic print...@>=
+procedure print_char(@!s:ASCII_code); {prints a single character}
+label exit;
+begin if @<Character |s| is the current new-line character@> then
+ if selector<pseudo then
+ begin print_ln; return;
+ end;
+case selector of
+term_and_log: begin
+ fix_term_offset(s); fix_log_offset(s);
+ wterm_char(s); wlog(xchr[s]);
+ incr(term_offset); incr(file_offset);
+ if term_offset=max_print_line then
+ begin wterm_cr; term_offset:=0;
+ end;
+ if file_offset=max_print_line then
+ begin wlog_cr; file_offset:=0;
+ end;
+ end;
+log_only: begin
+ fix_log_offset(s);
+ wlog(xchr[s]); incr(file_offset);
+ if file_offset=max_print_line then print_ln;
+ end;
+term_only: begin
+ fix_term_offset(s);
+ wterm_char(s); incr(term_offset);
+ if term_offset=max_print_line then print_ln;
+ end;
+no_print: do_nothing;
+pseudo: if tally<trick_count then trick_buf[tally mod error_line]:=s;
+new_string: begin if pool_ptr<pool_size then append_char(s);
+ end; {we drop characters if the string space is full}
+othercases write(write_file[selector],xchr[s])
+endcases;@/
+incr(tally);
+exit:end;
+
+@ An entire string is output by calling |print|. Note that if we are outputting
+the single standard ASCII character \.c, we could call |print("c")|, since
+|"c"=99| is the number of a single-character string, as explained above. But
+|print_char("c")| is quicker, so \TeX\ goes directly to the |print_char|
+routine when it knows that this is safe. (The present implementation
+assumes that it is always safe to print a visible ASCII character.)
+@^system dependencies@>
+
+The first 256 entries above the 17th unicode plane are used for a
+special trick: when \TeX\ has to print items in that range, it will
+instead print the character that results from substracting @"110000
+from that value. This allows byte-oriented output to things like
+\.{\\specials} and \.{\\pdfliterals}. Todo: Perhaps it would be useful
+to do the same substraction while typesetting.
+
+@d print_lc_hex(#)==l:=#;
+ if l<10 then print_char(l+"0") else print_char(l-10+"a");
+
+@<Basic print...@>=
+function pool_to_unichar(@!t:pool_pointer):ASCII_code;
+var a,result:@!ASCII_code; {a utf char}
+b:@!quarterword; { a utf nibble}
+begin
+ b := str_pool[t];
+ if b<=@"7F then
+ a := b
+ else if b>=@"F0 then begin
+ a := (b-@"F0) * 64;
+ b := str_pool[t+1];
+ a := (a + (b-128)) * 64;
+ b := str_pool[t+2];
+ a := (a + (b-128)) * 64;
+ b := str_pool[t+3];
+ a := a + (b-128);
+ end
+ else if b>=@"E0 then begin
+ a := (b-@"E0) * 64;
+ b := str_pool[t+1];
+ a := (a + (b-128)) * 64;
+ b := str_pool[t+2];
+ a := a + (b-128);
+ end
+ else if b>=@"C0 then begin
+ a := (b-@"C0) * 64;
+ b := str_pool[t+1];
+ a := a + (b-128);
+ end
+ else begin { NI: this is an encoding error }
+ wlog_ln('! Pool contains an invalid utf-8 sequence');
+ wterm_ln('! Pool contains an invalid utf-8 sequence');
+@.Text line contains...@>
+ help2("A funny symbol somehow ended up in the string pool.")@/
+ ("Just continue, I'll change it to 0xFFFD.");@/
+ deletions_allowed:=false; error; deletions_allowed:=true;
+ a:=@"FFFD;
+ end;
+result := a;
+pool_to_unichar := result;
+end ;
+
+procedure print(@!s:integer); {prints string |s|}
+label exit;
+var j:pool_pointer; {current character code position}
+@!v:integer; { a unicode char }
+begin if s>=str_ptr then s:="???" {this can't happen}
+@.???@>
+else if s<string_offset then
+ if s<0 then s:="???" {can't happen}
+ else begin
+ {TH not sure about this, disabled for now!}
+ if (false)and(selector>pseudo) then
+ begin print_char(s); return; {internal strings are not expanded}
+ end;
+ if (@<Character |s| is the current new-line character@>) then
+ if selector<pseudo then
+ begin print_ln; return;
+ end;
+ if s<=@"7F then
+ print_char(s)
+ else if s<=@"7FF then begin
+ print_char(@"C0 + (s div @"40));
+ print_char(@"80 + (s mod @"40));
+ end
+ else if s<=@"FFFF then begin
+ print_char(@"E0 + (s div @"1000));
+ print_char(@"80 + ((s mod @"1000) div @"40));
+ print_char(@"80 + ((s mod @"1000) mod @"40));
+ end
+ else begin
+ if s>=@"110000 then
+ print_char(s-@"110000)
+ else begin
+ print_char(@"F0 + (s div @"40000));
+ print_char(@"80 + ((s mod @"40000) div @"1000));
+ print_char(@"80 + (((s mod @"40000) mod @"1000) div @"40));
+ print_char(@"80 + (((s mod @"40000) mod @"1000) mod @"40));
+ end;
+ end;
+ return;
+ end;
+j:=str_start_macro(s);
+while j<str_start_macro(s+1) do
+ begin { 0x110000 in utf=8: 0xF4 0x90 0x80 0x80 }
+ if (str_pool[j]=@"F4)and(j<str_start_macro(s+4))and(str_pool[j+1]=@"90) then begin
+ v := (((7*64+63)*64)+ (str_pool[j+2]-128))*64 +(str_pool[j+3]-128);
+ print_char(v-@"110000); j := j+4;
+ end
+ else begin
+ print_char(str_pool[j]); incr(j);
+ end;
+ end;
+exit:end;
+
+procedure print_nl(@!s:str_number); {prints string |s| at beginning of line}
+begin if ((term_offset>0)and(odd(selector)))or@|
+ ((file_offset>0)and(selector>=log_only)) then print_ln;
+print(s);
+end;
+
+procedure print_nlp; {move to beginning of a line}
+begin if ((term_offset>0)and(odd(selector)))or@|
+ ((file_offset>0)and(selector>=log_only)) then print_ln;
+end;
+
+@ Control sequence names, file names, and strings constructed with
+\.{\\string} might contain |ASCII_code| values that can't
+be printed using |print_char|. Therefore we use |slow_print| for them:
+
+@<Basic print...@>=
+procedure slow_print(@!s:integer); {prints string |s|}
+var j:pool_pointer; {current character code position}
+begin if (s>=str_ptr) or (s<string_offset) then print(s)
+else begin j:=str_start_macro(s);
+ while j<str_start_macro(s+1) do
+ begin print(so(str_pool[j])); incr(j);
+ end;
+ end;
+end;
+
+@ Here is the very first thing that \TeX\ prints: a headline that identifies
+the version number and format package. The |term_offset| variable is temporarily
+incorrect, but the discrepancy is not serious since we assume that the banner
+and format identifier together will occupy at most |max_print_line|
+character positions.
+
+@<Initialize the output...@>=
+print_banner;
+
+@ The procedure |print_nl| is like |print|, but it makes sure that the
+string appears at the beginning of a new line. (moved)
+
+@<Basic print...@>=
+
+@ The procedure |print_esc| prints a string that is preceded by
+the user's escape character (which is usually a backslash).
+
+@<Basic print...@>=
+procedure print_esc(@!s:str_number); {prints escape character, then |s|}
+var c:integer; {the escape character code}
+begin @<Set variable |c| to the current escape character@>;
+if c>=0 then if c<string_offset then print(c);
+slow_print(s);
+end;
+
+@ An array of digits in the range |0..15| is printed by |print_the_digs|.
+
+@<Basic print...@>=
+procedure print_the_digs(@!k:eight_bits);
+ {prints |dig[k-1]|$\,\ldots\,$|dig[0]|}
+begin while k>0 do
+ begin decr(k);
+ if dig[k]<10 then print_char("0"+dig[k])
+ else print_char("A"-10+dig[k]);
+ end;
+end;
+
+@ The following procedure, which prints out the decimal representation of a
+given integer |n|, has been written carefully so that it works properly
+if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div|
+to negative arguments, since such operations are not implemented consistently
+by all \PASCAL\ compilers.
+
+@<Basic print...@>=
+procedure print_int(@!n:integer); {prints an integer in decimal form}
+var k:0..23; {index to current digit; we assume that $|n|<10^{23}$}
+@!m:integer; {used to negate |n| in possibly dangerous cases}
+begin k:=0;
+if n<0 then
+ begin print_char("-");
+ if n>-100000000 then negate(n)
+ else begin m:=-1-n; n:=m div 10; m:=(m mod 10)+1; k:=1;
+ if m<10 then dig[0]:=m
+ else begin dig[0]:=0; incr(n);
+ end;
+ end;
+ end;
+repeat dig[k]:=n mod 10; n:=n div 10; incr(k);
+until n=0;
+print_the_digs(k);
+end;
+
+@ Here is a trivial procedure to print two digits; it is usually called with
+a parameter in the range |0<=n<=99|.
+
+@p procedure print_two(@!n:integer); {prints two least significant digits}
+begin n:=abs(n) mod 100; print_char("0"+(n div 10));
+print_char("0"+(n mod 10));
+end;
+
+@ Hexadecimal printing of nonnegative integers is accomplished by |print_hex|.
+
+@p procedure print_hex(@!n:integer);
+ {prints a positive integer in hexadecimal form}
+var k:0..22; {index to current digit; we assume that $0\L n<16^{22}$}
+begin k:=0; print_char("""");
+repeat dig[k]:=n mod 16; n:=n div 16; incr(k);
+until n=0;
+print_the_digs(k);
+end;
+
+@ Old versions of \TeX\ needed a procedure called |print_ASCII| whose function
+is now subsumed by |print|. We retain the old name here as a possible aid to
+future software arch\ae ologists.
+
+@d print_ASCII == print
+@d print_font_name(#)==begin print(tex_font_name(#)); flush_string; end
+
+@ Roman numerals are produced by the |print_roman_int| routine. Readers
+who like puzzles might enjoy trying to figure out how this tricky code
+works; therefore no explanation will be given. Notice that 1990 yields
+\.{mcmxc}, not \.{mxm}.
+
+@p procedure print_roman_int(@!n:integer);
+label exit;
+var j,@!k: pool_pointer; {mysterious indices into |str_pool|}
+@!u,@!v: nonnegative_integer; {mysterious numbers}
+begin j:=str_start_macro("m2d5c2l5x2v5i"); v:=1000;
+loop@+ begin while n>=v do
+ begin print_char(so(str_pool[j])); n:=n-v;
+ end;
+ if n<=0 then return; {nonpositive input produces no output}
+ k:=j+2; u:=v div (so(str_pool[k-1])-"0");
+ if str_pool[k-1]=si("2") then
+ begin k:=k+2; u:=u div (so(str_pool[k-1])-"0");
+ end;
+ if n+u>=v then
+ begin print_char(so(str_pool[k])); n:=n+u;
+ end
+ else begin j:=j+2; v:=v div (so(str_pool[j-1])-"0");
+ end;
+ end;
+exit:end;
+
+@ The |print| subroutine will not print a string that is still being
+created. The following procedure will.
+
+@p procedure print_current_string; {prints a yet-unmade string}
+var j:pool_pointer; {points to current character code}
+begin j:=str_start_macro(str_ptr);
+while j<pool_ptr do
+ begin print_char(so(str_pool[j])); incr(j);
+ end;
+end;
+
+@ Here is a procedure that asks the user to type a line of input,
+assuming that the |selector| setting is either |term_only| or |term_and_log|.
+The input is placed into locations |first| through |last-1| of the
+|buffer| array, and echoed on the transcript file if appropriate.
+
+This procedure is never called when |interaction<scroll_mode|.
+
+@<Basic print...@>=
+procedure prompt_input(s:str_number);
+begin wake_up_terminal; print(s); term_input;
+end;
+
+@
+@p procedure term_input; {gets a line from the terminal}
+var k:0..buf_size; {index into |buffer|}
+begin update_terminal; {now the user sees the prompt for sure}
+if not input_ln(term_in,true)
+then fatal_error("End of file on the terminal!");
+@.End of file on the terminal@>
+term_offset:=0; {the user's line ended with \<\rm return>}
+decr(selector); {prepare to echo the input}
+if last<>first then for k:=first to last-1 do print(buffer[k]);
+print_ln; incr(selector); {restore previous status}
+end;
+
+@* \[6] Reporting errors.
+When something anomalous is detected, \TeX\ typically does something like this:
+$$\vbox{\halign{#\hfil\cr
+|print_err("Something anomalous has been detected");|\cr
+|help3("This is the first line of my offer to help.")|\cr
+|("This is the second line. I'm trying to")|\cr
+|("explain the best way for you to proceed.");|\cr
+|error;|\cr}}$$
+A two-line help message would be given using |help2|, etc.; these informal
+helps should use simple vocabulary that complements the words used in the
+official error message that was printed. (Outside the U.S.A., the help
+messages should preferably be translated into the local vernacular. Each
+line of help is at most 60 characters long, in the present implementation,
+so that |max_print_line| will not be exceeded.)
+
+The |print_err| procedure supplies a `\.!' before the official message,
+and makes sure that the terminal is awake if a stop is going to occur.
+The |error| procedure supplies a `\..' after the official message, then it
+shows the location of the error; and if |interaction=error_stop_mode|,
+it also enters into a dialog with the user, during which time the help
+message may be printed.
+@^system dependencies@>
+
+@ The global variable |interaction| has four settings, representing increasing
+amounts of user interaction:
+
+@d batch_mode=0 {omits all stops and omits terminal output}
+@d nonstop_mode=1 {omits all stops}
+@d scroll_mode=2 {omits error stops}
+@d error_stop_mode=3 {stops at every opportunity to interact}
+@d print_err(#)==begin if interaction=error_stop_mode then wake_up_terminal;
+ print_nl("! "); print(#);
+ last_error:=#; end
+@d print_warn(#)==begin if interaction=error_stop_mode then wake_up_terminal;
+ if prepend_nl then begin print_nl(""); print_ln end;
+ print_nl(#);
+ end
+
+@<Glob...@>=
+@!interaction:batch_mode..error_stop_mode; {current level of interaction}
+@!last_error:str_number;
+
+@ @<Set init...@>=interaction:=error_stop_mode;
+
+@ \TeX\ is careful not to call |error| when the print |selector| setting
+might be unusual. The only possible values of |selector| at the time of
+error messages are
+
+\yskip\hang|no_print| (when |interaction=batch_mode|
+ and |log_file| not yet open);
+
+\hang|term_only| (when |interaction>batch_mode| and |log_file| not yet open);
+
+\hang|log_only| (when |interaction=batch_mode| and |log_file| is open);
+
+\hang|term_and_log| (when |interaction>batch_mode| and |log_file| is open).
+
+@<Initialize the print |selector| based on |interaction|@>=
+if interaction=batch_mode then selector:=no_print@+else selector:=term_only
+
+@ A global variable |deletions_allowed| is set |false| if the |get_next|
+routine is active when |error| is called; this ensures that |get_next|
+and related routines like |get_token| will never be called recursively.
+A similar interlock is provided by |set_box_allowed|.
+@^recursion@>
+
+The global variable |history| records the worst level of error that
+has been detected. It has four possible values: |spotless|, |warning_issued|,
+|error_message_issued|, and |fatal_error_stop|.
+
+Another global variable, |error_count|, is increased by one when an
+|error| occurs without an interactive dialog, and it is reset to zero at
+the end of every paragraph. If |error_count| reaches 100, \TeX\ decides
+that there is no point in continuing further.
+
+@d spotless=0 {|history| value when nothing has been amiss yet}
+@d warning_issued=1 {|history| value when |begin_diagnostic| has been called}
+@d error_message_issued=2 {|history| value when |error| has been called}
+@d fatal_error_stop=3 {|history| value when termination was premature}
+
+@<Glob...@>=
+@!deletions_allowed:boolean; {is it safe for |error| to call |get_token|?}
+@!set_box_allowed:boolean; {is it safe to do a \.{\\setbox} assignment?}
+@!history:spotless..fatal_error_stop; {has the source input been clean so far?}
+@!error_count:-1..100; {the number of scrolled errors since the
+ last paragraph ended}
+
+@ The value of |history| is initially |fatal_error_stop|, but it will
+be changed to |spotless| if \TeX\ survives the initialization process.
+
+@<Set init...@>=
+deletions_allowed:=true; set_box_allowed:=true;
+error_count:=0; {|history| is initialized elsewhere}
+
+@ Since errors can be detected almost anywhere in \TeX, we want to declare the
+error procedures near the beginning of the program. But the error procedures
+in turn use some other procedures, which need to be declared |forward|
+before we get to |error| itself.
+
+It is possible for |error| to be called recursively if some error arises
+when |get_token| is being used to delete a token, and/or if some fatal error
+occurs while \TeX\ is trying to fix a non-fatal one. But such recursion
+@^recursion@>
+is never more than two levels deep.
+
+@<Error handling...@>=
+procedure@?normalize_selector; forward;@t\2@>@/
+procedure@?get_token; forward;@t\2@>@/
+procedure@?term_input; forward;@t\2@>@/
+procedure@?show_context; forward;@t\2@>@/
+procedure@?begin_file_reading; forward;@t\2@>@/
+procedure@?open_log_file; forward;@t\2@>@/
+procedure@?close_files_and_terminate; forward;@t\2@>@/
+procedure@?clear_for_error_prompt; forward;@t\2@>@/
+procedure@?give_err_help; forward;@t\2@>@/
+@t\4\hskip-\fontdimen2\font@>@;@+@!debug@+procedure@?debug_help;
+ forward;@;@+gubed
+
+@ Individual lines of help are recorded in the array |help_line|, which
+contains entries in positions |0..(help_ptr-1)|. They should be printed
+in reverse order, i.e., with |help_line[0]| appearing last.
+
+@d hlp1(#)==help_line[0]:=#;@+end
+@d hlp2(#)==help_line[1]:=#; hlp1
+@d hlp3(#)==help_line[2]:=#; hlp2
+@d hlp4(#)==help_line[3]:=#; hlp3
+@d hlp5(#)==help_line[4]:=#; hlp4
+@d hlp6(#)==help_line[5]:=#; hlp5
+@d help0==help_ptr:=0 {sometimes there might be no help}
+@d help1==@+begin help_ptr:=1; hlp1 {use this with one help line}
+@d help2==@+begin help_ptr:=2; hlp2 {use this with two help lines}
+@d help3==@+begin help_ptr:=3; hlp3 {use this with three help lines}
+@d help4==@+begin help_ptr:=4; hlp4 {use this with four help lines}
+@d help5==@+begin help_ptr:=5; hlp5 {use this with five help lines}
+@d help6==@+begin help_ptr:=6; hlp6 {use this with six help lines}
+
+@p
+procedure dohelp5 (@!a,b,c,d,e:str_number);
+begin
+ help5(a)(b)(c)(d)(e);
+end;
+@#
+procedure dohelp4 (@!a,b,c,d:str_number);
+begin
+ help4(a)(b)(c)(d);
+end;
+@#
+procedure dohelp3 (@!a,b,c:str_number);
+begin
+ help3(a)(b)(c);
+end;
+@#
+procedure dohelp2 (@!a,b:str_number);
+begin
+ help2(a)(b);
+end;
+@#
+procedure dohelp1 (@!a:str_number);
+begin
+ help1(a);
+end;
+@#
+procedure do_print_err (s:str_number);
+begin
+ print_err(s);
+end;
+
+@ @<Glob...@>=
+@!help_line:array[0..5] of str_number; {helps for the next |error|}
+@!help_ptr:0..6; {the number of help lines present}
+@!use_err_help:boolean; {should the |err_help| list be shown?}
+
+@ @<Set init...@>=
+help_ptr:=0; use_err_help:=false;
+
+@ The |jump_out| procedure just cuts across all active procedure levels and
+goes to |end_of_TEX|. This is the only nontrivial |@!goto| statement in the
+whole program. It is used when there is no recovery from a particular error.
+
+Some \PASCAL\ compilers do not implement non-local |goto| statements.
+@^system dependencies@>
+In such cases the body of |jump_out| should simply be
+`|close_files_and_terminate|;\thinspace' followed by a call on some system
+procedure that quietly terminates the program.
+
+@<Error hand...@>=
+procedure jump_out;
+begin goto end_of_TEX;
+end;
+
+@ Here now is the general |error| routine.
+
+@<Error hand...@>=
+procedure error; {completes the job of error reporting}
+label continue,exit;
+var c:ASCII_code; {what the user types}
+callback_id:integer;
+@!s1,@!s2,@!s3,@!s4:integer;
+ {used to save global variables when deleting tokens}
+@!t:boolean;
+begin if history<error_message_issued then history:=error_message_issued;
+print_char(".");
+callback_id := callback_defined(show_error_hook_callback) ;
+if callback_id>0 then t := run_callback(callback_id,'->');
+show_context;
+if interaction=error_stop_mode then @<Get user's advice and |return|@>;
+incr(error_count);
+if error_count=100 then
+ begin print_nl("(That makes 100 errors; please try again.)");
+@.That makes 100 errors...@>
+ history:=fatal_error_stop; jump_out;
+ end;
+@<Put help message on the transcript file@>;
+exit:end;
+
+@ @<Get user's advice...@>=
+loop@+begin continue: clear_for_error_prompt; prompt_input("? ");
+@.?\relax@>
+ if last=first then return;
+ c:=buffer[first];
+ if c>="a" then c:=c+"A"-"a"; {convert to uppercase}
+ @<Interpret code |c| and |return| if done@>;
+ end
+
+@ It is desirable to provide an `\.E' option here that gives the user
+an easy way to return from \TeX\ to the system editor, with the offending
+line ready to be edited. But such an extension requires some system
+wizardry, so the present implementation simply types out the name of the
+file that should be
+edited and the relevant line number.
+@^system dependencies@>
+
+There is a secret `\.D' option available when the debugging routines haven't
+been commented~out.
+@^debugging@>
+
+@<Interpret code |c| and |return| if done@>=
+case c of
+"0","1","2","3","4","5","6","7","8","9": if deletions_allowed then
+ @<Delete \(c)|c-"0"| tokens and |goto continue|@>;
+@t\4\4@>@;@+@!debug "D": begin debug_help; goto continue;@+end;@+gubed@/
+"E": if base_ptr>0 then
+ begin print_nl("You want to edit file ");
+@.You want to edit file x@>
+ slow_print(input_stack[base_ptr].name_field);
+ print(" at line "); print_int(line);
+ interaction:=scroll_mode; jump_out;
+ end;
+"H": @<Print the help information and |goto continue|@>;
+"I":@<Introduce new material from the terminal and |return|@>;
+"Q","R","S":@<Change the interaction level and |return|@>;
+"X":begin interaction:=scroll_mode; jump_out;
+ end;
+othercases do_nothing
+endcases;@/
+@<Print the menu of available options@>
+
+@ @<Print the menu...@>=
+begin print("Type <return> to proceed, S to scroll future error messages,");@/
+@.Type <return> to proceed...@>
+print_nl("R to run without stopping, Q to run quietly,");@/
+print_nl("I to insert something, ");
+if base_ptr>0 then print("E to edit your file,");
+if deletions_allowed then
+ print_nl("1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
+print_nl("H for help, X to quit.");
+end
+
+@ Here the author of \TeX\ apologizes for making use of the numerical
+relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
+|batch_mode|, |nonstop_mode|, |scroll_mode|.
+@^Knuth, Donald Ervin@>
+
+@<Change the interaction...@>=
+begin error_count:=0; interaction:=batch_mode+c-"Q";
+print("OK, entering ");
+case c of
+"Q":begin print_esc("batchmode"); decr(selector);
+ end;
+"R":print_esc("nonstopmode");
+"S":print_esc("scrollmode");
+end; {there are no other cases}
+print("..."); print_ln; update_terminal; return;
+end
+
+@ When the following code is executed, |buffer[(first+1)..(last-1)]| may
+contain the material inserted by the user; otherwise another prompt will
+be given. In order to understand this part of the program fully, you need
+to be familiar with \TeX's input stacks.
+
+@<Introduce new material...@>=
+begin begin_file_reading; {enter a new syntactic level for terminal input}
+{now |state=mid_line|, so an initial blank space will count as a blank}
+if last>first+1 then
+ begin loc:=first+1; buffer[first]:=" ";
+ end
+else begin prompt_input("insert>"); loc:=first;
+@.insert>@>
+ end;
+first:=last;
+cur_input.limit_field:=last-1; {no |end_line_char| ends this line}
+return;
+end
+
+@ We allow deletion of up to 99 tokens at a time.
+
+@<Delete \(c)|c-"0"| tokens...@>=
+begin s1:=cur_tok; s2:=cur_cmd; s3:=cur_chr; s4:=align_state;
+align_state:=1000000; OK_to_interrupt:=false;
+if (last>first+1) and (buffer[first+1]>="0")and(buffer[first+1]<="9") then
+ c:=c*10+buffer[first+1]-"0"*11
+else c:=c-"0";
+while c>0 do
+ begin get_token; {one-level recursive call of |error| is possible}
+ decr(c);
+ end;
+cur_tok:=s1; cur_cmd:=s2; cur_chr:=s3; align_state:=s4; OK_to_interrupt:=true;
+help2("I have just deleted some text, as you asked.")@/
+("You can now delete more, or insert, or whatever.");
+show_context; goto continue;
+end
+
+@ @<Print the help info...@>=
+begin if use_err_help then
+ begin give_err_help; use_err_help:=false;
+ end
+else begin if help_ptr=0 then
+ help2("Sorry, I don't know how to help in this situation.")@/
+ @t\kern1em@>("Maybe you should try asking a human?");
+ repeat decr(help_ptr); print(help_line[help_ptr]); print_ln;
+ until help_ptr=0;
+ end;
+help4("Sorry, I already gave what help I could...")@/
+ ("Maybe you should try asking a human?")@/
+ ("An error might have occurred before I noticed any problems.")@/
+ ("``If all else fails, read the instructions.''");@/
+goto continue;
+end
+
+@ @<Put help message on the transcript file@>=
+if interaction>batch_mode then decr(selector); {avoid terminal output}
+if use_err_help then
+ begin print_ln; give_err_help;
+ end
+else while help_ptr>0 do
+ begin decr(help_ptr); print_nl(help_line[help_ptr]);
+ end;
+print_ln;
+if interaction>batch_mode then incr(selector); {re-enable terminal output}
+print_ln
+
+@ A dozen or so error messages end with a parenthesized integer, so we
+save a teeny bit of program space by declaring the following procedure:
+
+@p procedure int_error(@!n:integer);
+begin print(" ("); print_int(n); print_char(")"); error;
+end;
+
+@ In anomalous cases, the print selector might be in an unknown state;
+the following subroutine is called to fix things just enough to keep
+running a bit longer.
+
+@p procedure normalize_selector;
+begin if log_opened then selector:=term_and_log
+else selector:=term_only;
+if job_name=0 then open_log_file;
+if interaction=batch_mode then decr(selector);
+end;
+
+@ The following procedure prints \TeX's last words before dying.
+
+@d succumb==begin if interaction=error_stop_mode then
+ interaction:=scroll_mode; {no more interaction}
+ if log_opened then error;
+ @!debug if interaction>batch_mode then debug_help;@+gubed@;@/
+ history:=fatal_error_stop; jump_out; {irrecoverable error}
+ end
+
+@<Error hand...@>=
+procedure fatal_error(@!s:str_number); {prints |s|, and that's it}
+begin normalize_selector;@/
+print_err("Emergency stop"); help1(s); succumb;
+@.Emergency stop@>
+end;
+
+@ Here is the most dreaded error message.
+
+@<Error hand...@>=
+procedure lua_norm_error(@!s:str_number); {lua found a problem}
+begin
+print_err("LuaTeX error "); print(s);
+help2("The lua interpreter ran into a problem, so the")@/
+ ("remainder of this lua chunk will be ignored.");
+error;
+end;
+
+procedure lua_fatal_error(@!s:str_number); {lua found a problem}
+begin normalize_selector;
+print_err("LuaTeX fatal error "); print(s);
+succumb;
+end;
+
+procedure overflow(@!s:str_number;@!n:integer); {stop due to finiteness}
+begin normalize_selector;
+print_err("TeX capacity exceeded, sorry [");
+@.TeX capacity exceeded ...@>
+print(s); print_char("="); print_int(n); print_char("]");
+help2("If you really absolutely need more capacity,")@/
+ ("you can ask a wizard to enlarge me.");
+succumb;
+end;
+
+procedure overflow_ocp_buf_size;
+begin
+overflow("ocp_buf_size",ocp_buf_size);
+end;
+
+procedure overflow_ocp_stack_size;
+begin
+overflow("ocp_stack_size",ocp_stack_size);
+end;
+
+
+@ The program might sometime run completely amok, at which point there is
+no choice but to stop. If no previous error has been detected, that's bad
+news; a message is printed that is really intended for the \TeX\
+maintenance person instead of the user (unless the user has been
+particularly diabolical). The index entries for `this can't happen' may
+help to pinpoint the problem.
+@^dry rot@>
+
+@<Error hand...@>=
+procedure confusion(@!s:str_number);
+ {consistency check violated; |s| tells where}
+begin normalize_selector;
+if history<error_message_issued then
+ begin print_err("This can't happen ("); print(s); print_char(")");
+@.This can't happen@>
+ help1("I'm broken. Please show this to someone who can fix can fix");
+ end
+else begin print_err("I can't go on meeting you like this");
+@.I can't go on...@>
+ help2("One of your faux pas seems to have wounded me deeply...")@/
+ ("in fact, I'm barely conscious. Please fix it and try again.");
+ end;
+succumb;
+end;
+
+@ Users occasionally want to interrupt \TeX\ while it's running.
+If the \PASCAL\ runtime system allows this, one can implement
+a routine that sets the global variable |interrupt| to some nonzero value
+when such an interrupt is signalled. Otherwise there is probably at least
+a way to make |interrupt| nonzero using the \PASCAL\ debugger.
+@^system dependencies@>
+@^debugging@>
+
+@<Global...@>=
+@!interrupt:integer; {should \TeX\ pause for instructions?}
+@!OK_to_interrupt:boolean; {should interrupts be observed?}
+@!detokenized_line:boolean; {indicates this is a 'detokenized' input line }
+@!line_catcode_table:integer; {the used catcode table for input lines}
+@!local_catcode_table:boolean; {the used catcode table for input lines}
+@!static_int_base:integer; {C version of |int_base|}
+
+@ @p procedure check_interrupt;
+begin
+if interrupt<>0 then pause_for_instructions;
+end;
+
+
+@ @<Set init...@>=
+interrupt:=0; OK_to_interrupt:=true; detokenized_line:=false;
+line_catcode_table:=0; local_catcode_table:=false;
+
+@ When an interrupt has been detected, the program goes into its
+highest interaction level and lets the user have nearly the full flexibility of
+the |error| routine. \TeX\ checks for interrupts only at times when it is
+safe to do this.
+
+@p procedure pause_for_instructions;
+begin if OK_to_interrupt then
+ begin interaction:=error_stop_mode;
+ if (selector=log_only)or(selector=no_print) then
+ incr(selector);
+ print_err("Interruption");
+@.Interruption@>
+ help3("You rang?")@/
+ ("Try to insert some instructions for me (e.g.,`I\showlists'),")@/
+ ("unless you just want to quit by typing `X'.");
+ deletions_allowed:=false; error; deletions_allowed:=true;
+ interrupt:=0;
+ end;
+end;
+
+@* \[7] Arithmetic with scaled dimensions.
+The principal computations performed by \TeX\ are done entirely in terms of
+integers less than $2^{31}$ in magnitude; and divisions are done only when both
+dividend and divisor are nonnegative. Thus, the arithmetic specified in this
+program can be carried out in exactly the same way on a wide variety of
+computers, including some small ones. Why? Because the arithmetic
+calculations need to be spelled out precisely in order to guarantee that
+\TeX\ will produce identical output on different machines. If some
+quantities were rounded differently in different implementations, we would
+find that line breaks and even page breaks might occur in different places.
+Hence the arithmetic of \TeX\ has been designed with care, and systems that
+claim to be implementations of \TeX82 should follow precisely the
+@:TeX82}{\TeX82@>
+calculations as they appear in the present program.
+
+(Actually there are three places where \TeX\ uses |div| with a possibly negative
+numerator. These are harmless; see |div| in the index. Also if the user
+sets the \.{\\time} or the \.{\\year} to a negative value, some diagnostic
+information will involve negative-numerator division. The same remarks
+apply for |mod| as well as for |div|.)
+
+@ Here is a routine that calculates half of an integer, using an
+unambiguous convention with respect to signed odd numbers.
+
+@p function half(@!x:integer):integer;
+begin if odd(x) then half:=(x+1) div 2
+else half:=x @!div 2;
+end;
+
+@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
+of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
+positions from the right end of a binary computer word.
+
+@d unity == @'200000 {$2^{16}$, represents 1.00000}
+@d two == @'400000 {$2^{17}$, represents 2.00000}
+
+@<Types...@>=
+@!scaled = integer; {this type is used for scaled integers}
+@!nonnegative_integer=0..@'17777777777; {$0\L x<2^{31}$}
+@!small_number=0..63; {this type is self-explanatory}
+
+@ The following function is used to create a scaled integer from a given decimal
+fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
+given in |dig[i]|, and the calculation produces a correctly rounded result.
+
+@p function round_decimals(@!k:small_number) : scaled;
+ {converts a decimal fraction}
+var a:integer; {the accumulator}
+begin a:=0;
+while k>0 do
+ begin decr(k); a:=(a+dig[k]*two) div 10;
+ end;
+round_decimals:=(a+1) div 2;
+end;
+
+@ Conversely, here is a procedure analogous to |print_int|. If the output
+of this procedure is subsequently read by \TeX\ and converted by the
+|round_decimals| routine above, it turns out that the original value will
+be reproduced exactly; the ``simplest'' such decimal number is output,
+but there is always at least one digit following the decimal point.
+
+The invariant relation in the \&{repeat} loop is that a sequence of
+decimal digits yet to be printed will yield the original number if and only if
+they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
+We can stop if and only if $f=0$ satisfies this condition; the loop will
+terminate before $s$ can possibly become zero.
+
+@p procedure print_scaled(@!s:scaled); {prints scaled real, rounded to five
+ digits}
+var delta:scaled; {amount of allowable inaccuracy}
+begin if s<0 then
+ begin print_char("-"); negate(s); {print the sign, if negative}
+ end;
+print_int(s div unity); {print the integer part}
+print_char(".");
+s:=10*(s mod unity)+5; delta:=10;
+repeat if delta>unity then s:=s+@'100000-50000; {round the last digit}
+print_char("0"+(s div unity)); s:=10*(s mod unity); delta:=delta*10;
+until s<=delta;
+end;
+
+@ Physical sizes that a \TeX\ user specifies for portions of documents are
+represented internally as scaled points. Thus, if we define an `sp' (scaled
+@^sp@>
+point) as a unit equal to $2^{-16}$ printer's points, every dimension
+inside of \TeX\ is an integer number of sp. There are exactly
+4,736,286.72 sp per inch. Users are not allowed to specify dimensions
+larger than $2^{30}-1$ sp, which is a distance of about 18.892 feet (5.7583
+meters); two such quantities can be added without overflow on a 32-bit
+computer.
+
+The present implementation of \TeX\ does not check for overflow when
+@^Overflow in arithmetic@>
+dimensions are added or subtracted. This could be done by inserting a
+few dozen tests of the form `\ignorespaces|if x>=@'10000000000 then
+@t\\{report\_overflow}@>|', but the chance of overflow is so remote that
+such tests do not seem worthwhile.
+
+\TeX\ needs to do only a few arithmetic operations on scaled quantities,
+other than addition and subtraction, and the following subroutines do most of
+the work. A single computation might use several subroutine calls, and it is
+desirable to avoid producing multiple error messages in case of arithmetic
+overflow; so the routines set the global variable |arith_error| to |true|
+instead of reporting errors directly to the user. Another global variable,
+|remainder|, holds the remainder after a division.
+
+@<Glob...@>=
+@!arith_error:boolean; {has arithmetic overflow occurred recently?}
+@!remainder:scaled; {amount subtracted to get an exact division}
+
+@ The first arithmetical subroutine we need computes $nx+y$, where |x|
+and~|y| are |scaled| and |n| is an integer. We will also use it to
+multiply integers.
+
+@d nx_plus_y(#)==mult_and_add(#,@'7777777777)
+@d mult_integers(#)==mult_and_add(#,0,@'17777777777)
+
+@p function mult_and_add(@!n:integer;@!x,@!y,@!max_answer:scaled):scaled;
+begin if n<0 then
+ begin negate(x); negate(n);
+ end;
+if n=0 then mult_and_add:=y
+else if ((x<=(max_answer-y) div n)and(-x<=(max_answer+y) div n)) then
+ mult_and_add:=n*x+y
+else begin arith_error:=true; mult_and_add:=0;
+ end;
+end;
+
+@ We also need to divide scaled dimensions by integers.
+
+@p function x_over_n(@!x:scaled;@!n:integer):scaled;
+var negative:boolean; {should |remainder| be negated?}
+begin negative:=false;
+if n=0 then
+ begin arith_error:=true; x_over_n:=0; remainder:=x;
+ end
+else begin if n<0 then
+ begin negate(x); negate(n); negative:=true;
+ end;
+ if x>=0 then
+ begin x_over_n:=x div n; remainder:=x mod n;
+ end
+ else begin x_over_n:=-((-x) div n); remainder:=-((-x) mod n);
+ end;
+ end;
+if negative then negate(remainder);
+end;
+
+@ Then comes the multiplication of a scaled number by a fraction |n/d|,
+where |n| and |d| are nonnegative integers |<=@t$2^{16}$@>| and |d| is
+positive. It would be too dangerous to multiply by~|n| and then divide
+by~|d|, in separate operations, since overflow might well occur; and it
+would be too inaccurate to divide by |d| and then multiply by |n|. Hence
+this subroutine simulates 1.5-precision arithmetic.
+
+@p function xn_over_d(@!x:scaled; @!n,@!d:integer):scaled;
+var positive:boolean; {was |x>=0|?}
+@!t,@!u,@!v:nonnegative_integer; {intermediate quantities}
+begin if x>=0 then positive:=true
+else begin negate(x); positive:=false;
+ end;
+t:=(x mod @'100000)*n;
+u:=(x div @'100000)*n+(t div @'100000);
+v:=(u mod d)*@'100000 + (t mod @'100000);
+if u div d>=@'100000 then arith_error:=true
+else u:=@'100000*(u div d) + (v div d);
+if positive then
+ begin xn_over_d:=u; remainder:=v mod d;
+ end
+else begin xn_over_d:=-u; remainder:=-(v mod d);
+ end;
+end;
+
+@ The next subroutine is used to compute the ``badness'' of glue, when a
+total~|t| is supposed to be made from amounts that sum to~|s|. According
+to {\sl The \TeX book}, the badness of this situation is $100(t/s)^3$;
+however, badness is simply a heuristic, so we need not squeeze out the
+last drop of accuracy when computing it. All we really want is an
+approximation that has similar properties.
+@:TeXbook}{\sl The \TeX book@>
+
+The actual method used to compute the badness is easier to read from the
+program than to describe in words. It produces an integer value that is a
+reasonably close approximation to $100(t/s)^3$, and all implementations
+of \TeX\ should use precisely this method. Any badness of $2^{13}$ or more is
+treated as infinitely bad, and represented by 10000.
+
+It is not difficult to prove that $$\hbox{|badness(t+1,s)>=badness(t,s)
+>=badness(t,s+1)|}.$$ The badness function defined here is capable of
+computing at most 1095 distinct values, but that is plenty.
+
+@d inf_bad = 10000 {infinitely bad value}
+
+@p function badness(@!t,@!s:scaled):halfword; {compute badness, given |t>=0|}
+var r:integer; {approximation to $\alpha t/s$, where $\alpha^3\approx
+ 100\cdot2^{18}$}
+begin if t=0 then badness:=0
+else if s<=0 then badness:=inf_bad
+else begin if t<=7230584 then r:=(t*297) div s {$297^3=99.94\times2^{18}$}
+ else if s>=1663497 then r:=t div (s div 297)
+ else r:=t;
+ if r>1290 then badness:=inf_bad {$1290^3<2^{31}<1291^3$}
+ else badness:=(r*r*r+@'400000) div @'1000000;
+ end; {that was $r^3/2^{18}$, rounded to the nearest integer}
+end;
+
+@ When \TeX\ ``packages'' a list into a box, it needs to calculate the
+proportionality ratio by which the glue inside the box should stretch
+or shrink. This calculation does not affect \TeX's decision making,
+so the precise details of rounding, etc., in the glue calculation are not
+of critical importance for the consistency of results on different computers.
+
+We shall use the type |glue_ratio| for such proportionality ratios.
+A glue ratio should take the same amount of memory as an
+|integer| (usually 32 bits) if it is to blend smoothly with \TeX's
+other data structures. Thus |glue_ratio| should be equivalent to
+|short_real| in some implementations of \PASCAL. Alternatively,
+it is possible to deal with glue ratios using nothing but fixed-point
+arithmetic; see {\sl TUGboat \bf3},1 (March 1982), 10--27. (But the
+routines cited there must be modified to allow negative glue ratios.)
+@^system dependencies@>
+
+@d set_glue_ratio_zero(#) == #:=0.0 {store the representation of zero ratio}
+@d set_glue_ratio_one(#) == #:=1.0 {store the representation of unit ratio}
+@d float(#) == # {convert from |glue_ratio| to type |real|}
+@d unfloat(#) == # {convert from |real| to type |glue_ratio|}
+@d float_constant(#) == #.0 {convert |integer| constant to |real|}
+
+@<Types...@>=
+@!glue_ratio=real; {one-word representation of a glue expansion factor}
+
+@* \[7b] Random numbers.
+
+\font\tenlogo=logo10 % font used for the METAFONT logo
+\def\MP{{\tenlogo META}\-{\tenlogo POST}}
+
+This section is (almost) straight from MetaPost. I had to change
+the types (use |integer| instead of |fraction|), but that should
+not have any influence on the actual calculations (the original
+comments refer to quantities like |fraction_four| ($2^{30}$), and
+that is the same as the numeric representation of |maxdimen|).
+
+I've copied the low-level variables and routines that are needed, but
+only those (e.g. |m_log|), not the accompanying ones like |m_exp|. Most
+of the following low-level numeric routines are only needed within the
+calculation of |norm_rand|. I've been forced to rename |make_fraction|
+to |make_frac| because TeX already has a routine by that name with
+a wholly different function (it creates a |fraction_noad| for math
+typesetting) -- Taco
+
+And now let's complete our collection of numeric utility routines
+by considering random number generation.
+\MP\ generates pseudo-random numbers with the additive scheme recommended
+in Section 3.6 of {\sl The Art of Computer Programming}; however, the
+results are random fractions between 0 and |fraction_one-1|, inclusive.
+
+There's an auxiliary array |randoms| that contains 55 pseudo-random
+fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
+we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
+The global variable |j_random| tells which element has most recently
+been consumed.
+
+@<Glob...@>=
+@!randoms:array[0..54] of integer; {the last 55 random values generated}
+@!j_random:0..54; {the number of unused |randoms|}
+@!random_seed:scaled; {the default random seed}
+
+@ A small bit of metafont is needed.
+
+@d fraction_half==@'1000000000 {$2^{27}$, represents 0.50000000}
+@d fraction_one==@'2000000000 {$2^{28}$, represents 1.00000000}
+@d fraction_four==@'10000000000 {$2^{30}$, represents 4.00000000}
+@d el_gordo == @'17777777777 {$2^{31}-1$, the largest value that \MP\ likes}
+@d halfp(#)==(#) div 2
+@d double(#) == #:=#+# {multiply a variable by two}
+
+@ The |make_frac| routine produces the |fraction| equivalent of
+|p/q|, given integers |p| and~|q|; it computes the integer
+$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
+positive. If |p| and |q| are both of the same scaled type |t|,
+the ``type relation'' |make_frac(t,t)=fraction| is valid;
+and it's also possible to use the subroutine ``backwards,'' using
+the relation |make_frac(t,fraction)=t| between scaled types.
+
+If the result would have magnitude $2^{31}$ or more, |make_frac|
+sets |arith_error:=true|. Most of \MP's internal computations have
+been designed to avoid this sort of error.
+
+If this subroutine were programmed in assembly language on a typical
+machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
+double-precision product can often be input to a fixed-point division
+instruction. But when we are restricted to \PASCAL\ arithmetic it
+is necessary either to resort to multiple-precision maneuvering
+or to use a simple but slow iteration. The multiple-precision technique
+would be about three times faster than the code adopted here, but it
+would be comparatively long and tricky, involving about sixteen
+additional multiplications and divisions.
+
+This operation is part of \MP's ``inner loop''; indeed, it will
+consume nearly 10\pct! of the running time (exclusive of input and output)
+if the code below is left unchanged. A machine-dependent recoding
+will therefore make \MP\ run faster. The present implementation
+is highly portable, but slow; it avoids multiplication and division
+except in the initial stage. System wizards should be careful to
+replace it with a routine that is guaranteed to produce identical
+results in all cases.
+@^system dependencies@>
+
+As noted below, a few more routines should also be replaced by machine-dependent
+code, for efficiency. But when a procedure is not part of the ``inner loop,''
+such changes aren't advisable; simplicity and robustness are
+preferable to trickery, unless the cost is too high.
+@^inner loop@>
+
+@p function make_frac(@!p,@!q:integer):integer;
+var @!f:integer; {the fraction bits, with a leading 1 bit}
+@!n:integer; {the integer part of $\vert p/q\vert$}
+@!negative:boolean; {should the result be negated?}
+@!be_careful:integer; {disables certain compiler optimizations}
+begin if p>=0 then negative:=false
+else begin negate(p); negative:=true;
+ end;
+if q<=0 then
+ begin debug if q=0 then confusion("/");@;@+gubed@;@/
+@:this can't happen /}{\quad \./@>
+ negate(q); negative:=not negative;
+ end;
+n:=p div q; p:=p mod q;
+if n>=8 then
+ begin arith_error:=true;
+ if negative then make_frac:=-el_gordo@+else make_frac:=el_gordo;
+ end
+else begin n:=(n-1)*fraction_one;
+ @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
+ if negative then make_frac:=-(f+n)@+else make_frac:=f+n;
+ end;
+end;
+
+@ The |repeat| loop here preserves the following invariant relations
+between |f|, |p|, and~|q|:
+(i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
+$p_0$ is the original value of~$p$.
+
+Notice that the computation specifies
+|(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
+Let us hope that optimizing compilers do not miss this point; a
+special variable |be_careful| is used to emphasize the necessary
+order of computation. Optimizing compilers should keep |be_careful|
+in a register, not store it in memory.
+@^inner loop@>
+
+@<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
+f:=1;
+repeat be_careful:=p-q; p:=be_careful+p;
+if p>=0 then f:=f+f+1
+else begin double(f); p:=p+q;
+ end;
+until f>=fraction_one;
+be_careful:=p-q;
+if be_careful+p>=0 then incr(f)
+
+@
+
+@p function take_frac(@!q:integer;@!f:integer):integer;
+var @!p:integer; {the fraction so far}
+@!negative:boolean; {should the result be negated?}
+@!n:integer; {additional multiple of $q$}
+@!be_careful:integer; {disables certain compiler optimizations}
+begin @<Reduce to the case that |f>=0| and |q>0|@>;
+if f<fraction_one then n:=0
+else begin n:=f div fraction_one; f:=f mod fraction_one;
+ if q<=el_gordo div n then n:=n*q
+ else begin arith_error:=true; n:=el_gordo;
+ end;
+ end;
+f:=f+fraction_one;
+@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
+be_careful:=n-el_gordo;
+if be_careful+p>0 then
+ begin arith_error:=true; n:=el_gordo-p;
+ end;
+if negative then take_frac:=-(n+p)
+else take_frac:=n+p;
+end;
+
+@ @<Reduce to the case that |f>=0| and |q>0|@>=
+if f>=0 then negative:=false
+else begin negate(f); negative:=true;
+ end;
+if q<0 then
+ begin negate(q); negative:=not negative;
+ end;
+
+@ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
+=\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
+$f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
+@^inner loop@>
+
+@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
+p:=fraction_half; {that's $2^{27}$; the invariants hold now with $k=28$}
+if q<fraction_four then
+ repeat if odd(f) then p:=halfp(p+q)@+else p:=halfp(p);
+ f:=halfp(f);
+ until f=1
+else repeat if odd(f) then p:=p+halfp(q-p)@+else p:=halfp(p);
+ f:=halfp(f);
+ until f=1
+
+@ The subroutines for logarithm and exponential involve two tables.
+The first is simple: |two_to_the[k]| equals $2^k$. The second involves
+a bit more calculation, which the author claims to have done correctly:
+|spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
+2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
+nearest integer.
+
+@<Glob...@>=
+@!two_to_the:array[0..30] of integer; {powers of two}
+@!spec_log:array[1..28] of integer; {special logarithms}
+
+
+@ @<Set init...@>=
+two_to_the[0]:=1;
+for k:=1 to 30 do two_to_the[k]:=2*two_to_the[k-1];
+spec_log[1]:=93032640;
+spec_log[2]:=38612034;
+spec_log[3]:=17922280;
+spec_log[4]:=8662214;
+spec_log[5]:=4261238;
+spec_log[6]:=2113709;
+spec_log[7]:=1052693;
+spec_log[8]:=525315;
+spec_log[9]:=262400;
+spec_log[10]:=131136;
+spec_log[11]:=65552;
+spec_log[12]:=32772;
+spec_log[13]:=16385;
+for k:=14 to 27 do spec_log[k]:=two_to_the[27-k];
+spec_log[28]:=1;
+
+@
+
+@p function m_log(@!x:integer):integer;
+var @!y,@!z:integer; {auxiliary registers}
+@!k:integer; {iteration counter}
+begin if x<=0 then @<Handle non-positive logarithm@>
+else begin y:=1302456956+4-100; {$14\times2^{27}\ln2\approx1302456956.421063$}
+ z:=27595+6553600; {and $2^{16}\times .421063\approx 27595$}
+ while x<fraction_four do
+ begin double(x); y:=y-93032639; z:=z-48782;
+ end; {$2^{27}\ln2\approx 93032639.74436163$
+ and $2^{16}\times.74436163\approx 48782$}
+ y:=y+(z div unity); k:=2;
+ while x>fraction_four+4 do
+ @<Increase |k| until |x| can be multiplied by a
+ factor of $2^{-k}$, and adjust $y$ accordingly@>;
+ m_log:=y div 8;
+ end;
+end;
+
+@ @<Increase |k| until |x| can...@>=
+begin z:=((x-1) div two_to_the[k])+1; {$z=\lceil x/2^k\rceil$}
+while x<fraction_four+z do
+ begin z:=halfp(z+1); k:=k+1;
+ end;
+y:=y+spec_log[k]; x:=x-z;
+end
+
+@ @<Handle non-positive logarithm@>=
+begin print_err("Logarithm of ");
+@.Logarithm...replaced by 0@>
+print_scaled(x); print(" has been replaced by 0");
+help2("Since I don't take logs of non-positive numbers,")@/
+ ("I'm zeroing this one. Proceed, with fingers crossed.");
+error; m_log:=0;
+end
+
+@ The following somewhat different subroutine tests rigorously if $ab$ is
+greater than, equal to, or less than~$cd$,
+given integers $(a,b,c,d)$. In most cases a quick decision is reached.
+The result is $+1$, 0, or~$-1$ in the three respective cases.
+
+@d return_sign(#)==begin ab_vs_cd:=#; return;
+ end
+
+@p function ab_vs_cd(@!a,b,c,d:integer):integer;
+label exit;
+var @!q,@!r:integer; {temporary registers}
+begin @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
+loop@+ begin q := a div d; r := c div b;
+ if q<>r then
+ if q>r then return_sign(1)@+else return_sign(-1);
+ q := a mod d; r := c mod b;
+ if r=0 then
+ if q=0 then return_sign(0)@+else return_sign(1);
+ if q=0 then return_sign(-1);
+ a:=b; b:=q; c:=d; d:=r;
+ end; {now |a>d>0| and |c>b>0|}
+exit:end;
+
+@ @<Reduce to the case that |a...@>=
+if a<0 then
+ begin negate(a); negate(b);
+ end;
+if c<0 then
+ begin negate(c); negate(d);
+ end;
+if d<=0 then
+ begin if b>=0 then
+ if ((a=0)or(b=0))and((c=0)or(d=0)) then return_sign(0)
+ else return_sign(1);
+ if d=0 then
+ if a=0 then return_sign(0)@+else return_sign(-1);
+ q:=a; a:=c; c:=q; q:=-b; b:=-d; d:=q;
+ end
+else if b<=0 then
+ begin if b<0 then if a>0 then return_sign(-1);
+ if c=0 then return_sign(0) else return_sign(-1);
+ end
+
+@ To consume a random integer, the program below will say `|next_random|'
+and then it will fetch |randoms[j_random]|.
+
+@d next_random==if j_random=0 then new_randoms
+ else decr(j_random)
+
+@p procedure new_randoms;
+var @!k:0..54; {index into |randoms|}
+@!x:integer; {accumulator}
+begin for k:=0 to 23 do
+ begin x:=randoms[k]-randoms[k+31];
+ if x<0 then x:=x+fraction_one;
+ randoms[k]:=x;
+ end;
+for k:=24 to 54 do
+ begin x:=randoms[k]-randoms[k-24];
+ if x<0 then x:=x+fraction_one;
+ randoms[k]:=x;
+ end;
+j_random:=54;
+end;
+
+@ To initialize the |randoms| table, we call the following routine.
+
+@p procedure init_randoms(@!seed:integer);
+var @!j,@!jj,@!k:integer; {more or less random integers}
+@!i:0..54; {index into |randoms|}
+begin j:=abs(seed);
+while j>=fraction_one do j:=halfp(j);
+k:=1;
+for i:=0 to 54 do
+ begin jj:=k; k:=j-k; j:=jj;
+ if k<0 then k:=k+fraction_one;
+ randoms[(i*21)mod 55]:=j;
+ end;
+new_randoms; new_randoms; new_randoms; {``warm up'' the array}
+end;
+
+@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
+or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
+
+Note that the call of |take_frac| will produce the values 0 and~|x|
+with about half the probability that it will produce any other particular
+values between 0 and~|x|, because it rounds its answers.
+
+@p function unif_rand(@!x:integer):integer;
+var @!y:integer; {trial value}
+begin next_random; y:=take_frac(abs(x),randoms[j_random]);
+if y=abs(x) then unif_rand:=0
+else if x>0 then unif_rand:=y
+else unif_rand:=-y;
+end;
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}).
+
+@p function norm_rand:integer;
+var @!x,@!u,@!l:integer; {what the book would call $2^{16}X$, $2^{28}U$,
+ and $-2^{24}\ln U$}
+begin repeat
+ repeat next_random;
+ x:=take_frac(112429,randoms[j_random]-fraction_half);
+ {$2^{16}\sqrt{8/e}\approx 112428.82793$}
+ next_random; u:=randoms[j_random];
+ until abs(x)<u;
+x:=make_frac(x,u);
+l:=139548960-m_log(u); {$2^{24}\cdot12\ln2\approx139548959.6165$}
+until ab_vs_cd(1024,l,x,x)>=0;
+norm_rand:=x;
+end;
+
+@* \[8] Packed data.
+In order to make efficient use of storage space, \TeX\ bases its major data
+structures on a |memory_word|, which contains either a (signed) integer,
+possibly scaled, or a (signed) |glue_ratio|, or a small number of
+fields that are one half or one quarter of the size used for storing
+integers.
+
+If |x| is a variable of type |memory_word|, it contains up to four
+fields that can be referred to as follows:
+$$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
+|x|&.|int|&(an |integer|)\cr
+|x|&.|sc|\qquad&(a |scaled| integer)\cr
+|x|&.|gr|&(a |glue_ratio|)\cr
+|x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
+|x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
+ field)\cr
+|x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
+ &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
+This is somewhat cumbersome to write, and not very readable either, but
+macros will be used to make the notation shorter and more transparent.
+The \PASCAL\ code below gives a formal definition of |memory_word| and
+its subsidiary types, using packed variant records. \TeX\ makes no
+assumptions about the relative positions of the fields within a word.
+
+We are assuming 32-bit integers, a halfword must contain at least
+32 bits, and a quarterword must contain at least 16 bits.
+@^system dependencies@>
+
+N.B.: Valuable memory space will be dreadfully wasted unless \TeX\ is compiled
+by a \PASCAL\ that packs all of the |memory_word| variants into
+the space of a single integer. This means, for example, that |glue_ratio|
+words should be |short_real| instead of |real| on some computers. Some
+\PASCAL\ compilers will pack an integer whose subrange is `|0..255|' into
+an eight-bit field, but others insist on allocating space for an additional
+sign bit; on such systems you can get 256 values into a quarterword only
+if the subrange is `|-128..127|'.
+
+The present implementation tries to accommodate as many variations as possible,
+so it makes few assumptions. If integers having the subrange
+`|min_quarterword..max_quarterword|' can be packed into a quarterword,
+and if integers having the subrange `|min_halfword..max_halfword|'
+can be packed into a halfword, everything should work satisfactorily.
+
+It is usually most efficient to have |min_quarterword=min_halfword=0|,
+so one should try to achieve this unless it causes a severe problem.
+The values defined here are recommended for most 32-bit computers.
+
+We cannot use the full range of 32 bits in a halfword, because we have
+to allow negative values for potential backend tricks like web2c's
+dynamic allocation, and parshapes pointers have to be able to store at
+least twice the value |max_halfword| (see below). Therefore,
+|max_halfword| is $2^{30}-1$
+
+@d min_quarterword=0 {smallest allowable value in a |quarterword|}
+@d max_quarterword=65535 {largest allowable value in a |quarterword|}
+@d min_halfword==-@"3FFFFFFF {smallest allowable value in a |halfword|}
+@d max_halfword==@"3FFFFFFF {largest allowable value in a |halfword|}
+
+@ Here are the inequalities that the quarterword and halfword values
+must satisfy (or rather, the inequalities that they mustn't satisfy):
+
+@<Check the ``constant''...@>=
+if (min_quarterword>0)or(max_quarterword<@"7FFF) then bad:=11;
+if (min_halfword>0)or(max_halfword<@"3FFFFFFF) then bad:=12;
+if (min_quarterword<min_halfword)or@|
+ (max_quarterword>max_halfword) then bad:=13;
+if font_base<min_quarterword then bad:=15;
+if (save_size>max_halfword)or(max_strings>max_halfword) then bad:=17;
+if buf_size>max_halfword then bad:=18;
+if max_quarterword-min_quarterword<@"FFFF then bad:=19;
+
+@ The operation of adding or subtracting |min_quarterword| occurs quite
+frequently in \TeX, so it is convenient to abbreviate this operation
+by using the macros |qi| and |qo| for input and output to and from
+quarterword format.
+
+The inner loop of \TeX\ will run faster with respect to compilers
+that don't optimize expressions like `|x+0|' and `|x-0|', if these
+macros are simplified in the obvious way when |min_quarterword=0|.
+@^inner loop@>@^system dependencies@>
+
+@d qi(#)==#+min_quarterword
+ {to put an |eight_bits| item into a quarterword}
+@d qo(#)==#-min_quarterword
+ {to take an |eight_bits| item out of a quarterword}
+@d hi(#)==#+min_halfword
+ {to put a sixteen-bit item into a halfword}
+@d ho(#)==#-min_halfword
+ {to take a sixteen-bit item from a halfword}
+
+@ The reader should study the following definitions closely:
+@^system dependencies@>
+
+@d sc==int {|scaled| data is equivalent to |integer|}
+
+@<Types...@>=
+@!quarterword = min_quarterword..max_quarterword; {1/4 of a word}
+@!halfword=min_halfword..max_halfword; {1/2 of a word}
+@!two_choices = 1..2; {used when there are two variants in a record}
+@!four_choices = 1..4; {used when there are four variants in a record}
+@!two_halves = packed record@;@/
+ @!rh:halfword;
+ case two_choices of
+ 1: (@!lh:halfword);
+ 2: (@!b0:quarterword; @!b1:quarterword);
+ end;
+@!four_quarters = packed record@;@/
+ @!b0:quarterword;
+ @!b1:quarterword;
+ @!b2:quarterword;
+ @!b3:quarterword;
+ end;
+@!memory_word = record@;@/
+ case four_choices of
+ 1: (@!int:integer);
+ 2: (@!gr:glue_ratio);
+ 3: (@!hh:two_halves);
+ 4: (@!qqqq:four_quarters);
+ end;
+@!word_file = file of memory_word;
+
+@ When debugging, we may want to print a |memory_word| without knowing
+what type it is; so we print it in all modes.
+@^dirty \PASCAL@>@^debugging@>
+
+@p @!debug procedure print_word(@!w:memory_word);
+ {prints |w| in all ways}
+begin print_int(w.int); print_char(" ");@/
+print_scaled(w.sc); print_char(" ");@/
+print_scaled(round(unity*float(w.gr))); print_ln;@/
+@^real multiplication@>
+print_int(w.hh.lh); print_char("="); print_int(w.hh.b0); print_char(":");
+print_int(w.hh.b1); print_char(";"); print_int(w.hh.rh); print_char(" ");@/
+print_int(w.qqqq.b0); print_char(":"); print_int(w.qqqq.b1); print_char(":");
+print_int(w.qqqq.b2); print_char(":"); print_int(w.qqqq.b3);
+end;
+gubed
+
+@* \[9] Dynamic memory allocation.
+The \TeX\ system does nearly all of its own memory allocation, so that it
+can readily be transported into environments that do not have automatic
+facilities for strings, garbage collection, etc., and so that it can be in
+control of what error messages the user receives. The dynamic storage
+requirements of \TeX\ are handled by providing two large arrays called
+|fixmem| and |varmem| in which consecutive blocks of words are used as
+nodes by the \TeX\ routines.
+
+Pointer variables are indices into this array, or into another array
+called |eqtb| that will be explained later. A pointer variable might
+also be a special flag that lies outside the bounds of |mem|, so we
+allow pointers to assume any |halfword| value. The minimum halfword
+value represents a null pointer. \TeX\ does not assume that |mem[null]| exists.
+
+@d pointer==halfword {a flag or a location in |mem| or |eqtb|}
+@d null==0 {the null pointer}
+
+@<Glob...@>=
+@!temp_ptr:pointer; {a pointer variable for occasional emergency use}
+
+@ @<Types...@>=
+@!smemory_word = packed record@;@/
+ @!hhrh:halfword;
+ @!hhlh:halfword;
+ end;
+
+
+@ The |mem| array is divided into two items that are allocated separately;
+they grow until finding their ``natural'' size in a particular job.
+Locations in |varmem| are used for storing variable-length records
+consisting of two or more words each. This region
+is maintained using an algorithm similar to the one described in exercise
+2.5--19 of {\sl The Art of Computer Programming}. However, no size field
+appears in the allocated nodes; the program is responsible for knowing the
+relevant size when a node is freed. Locations in |fixmem| are used for storing
+one-word records; a conventional \.{AVAIL} stack is used for allocation
+in this array.
+
+Empirical tests show that the present implementation of \TeX\ tends to
+spend about 9\pct! of its running time allocating nodes, and about 6\pct!
+deallocating them after their use.
+
+@d fix_mem_init==10000
+
+@<Glob...@>=
+@!fixmem : ^smemory_word; {the big dynamic storage area}
+@!fix_mem_min : pointer; {the smallest location of one-word memory in use}
+@!fix_mem_max : pointer; {the largest location of one-word memory in use}
+
+@ In order to study the memory requirements of particular applications, it
+is possible to prepare a version of \TeX\ that keeps track of current and
+maximum memory usage. When code between the delimiters |@!stat| $\ldots$
+|tats| is not ``commented out,'' \TeX\ will run a bit slower but it will
+report these statistics when |tracing_stats| is sufficiently large.
+
+@<Glob...@>=
+@!var_used, @!dyn_used : integer; {how much memory is in use}
+
+@ Let's consider the one-word memory region first, since it's the
+simplest. The pointer variable |fix_mem_end| holds the highest-numbered location
+of |mem| that has ever been used. The free locations of |mem| that
+occur between |hi_mem_min| and |fix_mem_end|, inclusive, are of type
+|two_halves|, and we write |info(p)| and |link(p)| for the |lh|
+and |rh| fields of |mem[p]| when it is of this type. The single-word
+free locations form a linked list
+$$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
+terminated by |null|.
+
+@d mem(#) == fixmem[#]
+@d link(#) == mem(#).hhrh {the |link| field of a memory word}
+@d info(#) == mem(#).hhlh {the |info| field of a memory word}
+
+@<Glob...@>=
+@!avail : pointer; {head of the list of available one-word nodes}
+@!fix_mem_end : pointer; {the last one-word node used in |mem|}
+
+@ If memory is exhausted, it might mean that the user has forgotten
+a right brace. We will define some procedures later that try to help
+pinpoint the trouble.
+
+@p @<Declare the procedure called |show_token_list|@>@/
+@<Declare the procedure called |runaway|@>
+
+@ The function |get_avail| returns a pointer to a new one-word node whose
+|link| field is null. However, \TeX\ will halt if there is no more room left.
+@^inner loop@>
+
+If the available-space list is empty, i.e., if |avail=null|,
+we try first to increase |fix_mem_end|. If that cannot be done, i.e., if
+|fix_mem_end=fix_mem_max|, we try to reallocate array |fixmem|.
+If, that doesn't work, we have to quit.
+
+@p function get_avail : pointer; {single-word node allocation}
+var p:pointer; {the new node being got}
+t:integer;
+begin p:=avail; {get top location in the |avail| stack}
+if p<>null then avail:=link(avail) {and pop it off}
+else if fix_mem_end<fix_mem_max then {or go into virgin territory}
+ begin incr(fix_mem_end); p:=fix_mem_end;
+ end
+else begin
+ t:=(fix_mem_max/5);
+ fixmem := fixmemcast(realloc(fixmem,sizeof(smemory_word)*(fix_mem_max+t+1)));
+ if fixmem=NULL then
+ begin runaway; {if memory is exhausted, display possible runaway text}
+ overflow("token memory size",fix_mem_max);
+ {quit; all one-word nodes are busy}
+@:TeX capacity exceeded main memory size}{\quad main memory size@>
+ end;
+ memset (voidcast(fixmem+fix_mem_max+1),0,t*sizeof(smemory_word));
+ fix_mem_max:=fix_mem_max+t; incr(fix_mem_end); p:=fix_mem_end;
+ end;
+link(p):=null; {provide an oft-desired initialization of the new node}
+@!stat incr(dyn_used);@+tats@;{maintain statistics}
+get_avail:=p;
+end;
+
+@ Conversely, a one-word node is recycled by calling |free_avail|.
+This routine is part of \TeX's ``inner loop,'' so we want it to be fast.
+@^inner loop@>
+
+@d free_avail(#)== {single-word node liberation}
+ begin link(#):=avail; avail:=#;
+ @!stat decr(dyn_used);@+tats@/
+ end
+
+@ There's also a |fast_get_avail| routine, which saves the procedure-call
+overhead at the expense of extra programming. This routine is used in
+the places that would otherwise account for the most calls of |get_avail|.
+@^inner loop@>
+
+@d fast_get_avail(#)==@t@>@;@/
+ begin #:=avail; {avoid |get_avail| if possible, to save time}
+ if #=null then #:=get_avail
+ else begin avail:=link(#); link(#):=null;
+ @!stat incr(dyn_used);@+tats@/
+ end;
+ end
+
+@ The procedure |flush_list(p)| frees an entire linked list of
+one-word nodes that starts at position |p|.
+@^inner loop@>
+
+@p procedure flush_list(@!p:pointer); {makes list of single-word nodes available}
+var @!q,@!r:pointer; {list traversers}
+begin if p<>null then
+ begin r:=p;
+ repeat q:=r; r:=link(r); @!stat decr(dyn_used);@+tats@/
+ until r=null; {now |q| is the last node on the list}
+ link(q):=avail; avail:=p;
+ end;
+end;
+
+@ The available-space list that keeps track of the variable-size portion
+of |mem| is a nonempty, doubly-linked circular list of empty nodes,
+pointed to by the roving pointer |rover|.
+
+@d temp_node==46
+@d temp_node_size==2
+@d vmem(#) == varmem[#]
+@d vlink(#) == vmem(#).hh.rh {the |link| field of a memory word}
+@d vinfo(#) == vmem(#).hh.lh {the |info| field of a memory word}
+@d alink(#) == vlink(#+1) {backlink in doubly-linked list of empty nodes}
+
+@* \[10] Data structures for boxes and their friends.
+From the computer's standpoint, \TeX's chief mission is to create
+horizontal and vertical lists. We shall now investigate how the elements
+of these lists are represented internally as nodes in the dynamic memory.
+
+A horizontal or vertical list is linked together by |link| fields in
+the first word of each node. Individual nodes represent boxes, glue,
+penalties, or special things like discretionary hyphens; because of this
+variety, some nodes are longer than others, and we must distinguish different
+kinds of nodes. We do this by putting a `|type|' field in the first word,
+together with the link and an optional `|subtype|'.
+
+@d type(#) == vmem(#).hh.b0 {identifies what kind of node this is}
+@d subtype(#) == vmem(#).hh.b1 {secondary identification in some cases}
+
+@ TH: This module section is superceded.
+
+A |@!char_node|, which represents a single character, is the most important
+kind of node because it accounts for the vast majority of all boxes.
+Special precautions are therefore taken to ensure that a |char_node| does
+not take up much memory space. Every such node is one word long, and in fact
+it is identifiable by this property, since other kinds of nodes have at least
+two words, and they appear in |mem| locations less than |hi_mem_min|.
+This makes it possible to omit the |type| field in a |char_node|, leaving
+us room for two bytes that identify a |font| and a |character| within
+that font.
+
+Note that the format of a |char_node| allows for up to 256 different
+fonts and up to 256 characters per font; but most implementations will
+probably limit the total number of fonts to fewer than 75 per job,
+and most fonts will stick to characters whose codes are
+less than 128 (since higher codes
+are more difficult to access on most keyboards).
+
+Extensions of \TeX\ intended for oriental languages will need even more
+than $256\times256$ possible characters, when we consider different sizes
+@^oriental characters@>@^Chinese characters@>@^Japanese characters@>
+and styles of type. It is suggested that Chinese and Japanese fonts be
+handled by representing such characters in two consecutive |char_node|
+entries: The first of these has |font=font_base|, and its |link| points
+to the second;
+the second identifies the font and the character dimensions.
+The saving feature about oriental characters is that most of them have
+the same box dimensions. The |character| field of the first |char_node|
+is a ``\\{charext}'' that distinguishes between graphic symbols whose
+dimensions are identical for typesetting purposes. (See the \MF\ manual.)
+Such an extension of \TeX\ would not be difficult; further details are
+left to the reader.
+
+In order to make sure that the |character| code fits in a quarterword,
+\TeX\ adds the quantity |min_quarterword| to the actual code.
+
+Character nodes appear only in horizontal lists, never in vertical lists.
+
+@ Attribute lists need two extra globals to increase processing efficiency.
+|max_used_attr| limits the test loop that checks for set attributes, and
+|attr_list_cache| contains a pointer to an already created attribute list. It is
+set to the special value |cache_disabled| when the current value can no longer be
+trusted: after an assignment to an attribute register, and after a group has
+ended.
+
+@d cache_disabled==max_halfword
+
+@<Glob...@>=
+max_used_attr:integer; { maximum assigned attribute id }
+attr_list_cache:pointer;
+
+@ @<Set init...@>=
+max_used_attr:=-1; attr_list_cache:=cache_disabled;
+
+@ Attribute lists are maintained in C, but they need access to the current
+attributes in eqtb.
+
+@p function get_attribute(i:halfword):halfword;
+begin
+ get_attribute := attribute(i);
+end;
+
+
+@ An |hlist_node| stands for a box that was made from a horizontal list.
+Each |hlist_node| is seven words long, and contains the following fields
+(in addition to the mandatory |type| and |link|, which we shall not
+mention explicitly when discussing the other node types): The |height| and
+|width| and |depth| are scaled integers denoting the dimensions of the
+box. There is also a |shift_amount| field, a scaled integer indicating
+how much this box should be lowered (if it appears in a horizontal list),
+or how much it should be moved to the right (if it appears in a vertical
+list). There is a |list_ptr| field, which points to the beginning of the
+list from which this box was fabricated; if |list_ptr| is |null|, the box
+is empty. Finally, there are three fields that represent the setting of
+the glue: |glue_set(p)| is a word of type |glue_ratio| that represents
+the proportionality constant for glue setting; |glue_sign(p)| is
+|stretching| or |shrinking| or |normal| depending on whether or not the
+glue should stretch or shrink or remain rigid; and |glue_order(p)|
+specifies the order of infinity to which glue setting applies (|normal|,
+|sfi|, |fil|, |fill|, or |filll|). The |subtype| field is not used.
+
+@d hlist_node=0 {|type| of hlist nodes}
+@d box_node_size=8 {number of words to allocate for a box node}
+@d width_offset=2 {position of |width| field in a box node}
+@d depth_offset=3 {position of |depth| field in a box node}
+@d height_offset=4 {position of |height| field in a box node}
+@d width(#) == vmem(#+width_offset).sc {width of the box, in sp}
+@d depth(#) == vmem(#+depth_offset).sc {depth of the box, in sp}
+@d height(#) == vmem(#+height_offset).sc {height of the box, in sp}
+@d shift_amount(#) == vlink(#+5) {repositioning distance, in sp}
+@d box_dir(#) == vinfo(#+5) {position of |box_dir| in a box node}
+@d list_offset=6 {position of |list_ptr| field in a box node}
+@d list_ptr(#) == vlink(#+list_offset) {beginning of the list inside the box}
+@d glue_order(#) == subtype(#+list_offset) {applicable order of infinity}
+@d glue_sign(#) == type(#+list_offset) {stretching or shrinking}
+@d normal=0 {the most common case when several cases are named}
+@d stretching = 1 {glue setting applies to the stretch components}
+@d shrinking = 2 {glue setting applies to the shrink components}
+@d glue_offset = 7 {position of |glue_set| in a box node}
+@d glue_set(#) == vmem(#+glue_offset).gr
+ {a word of type |glue_ratio| for glue setting}
+
+@ The |new_null_box| function returns a pointer to an |hlist_node| in
+which all subfields have the values corresponding to `\.{\\hbox\{\}}'.
+The |subtype| field is set to |min_quarterword|, since that's the desired
+|span_count| value if this |hlist_node| is changed to an |unset_node|.
+
+@p function new_null_box:pointer; {creates a new box node}
+var p:pointer; {the new node}
+begin p:=new_node(hlist_node,min_quarterword);
+box_dir(p):=text_direction;
+new_null_box:=p;
+end;
+
+@ A |vlist_node| is like an |hlist_node| in all respects except that it
+contains a vertical list.
+
+@d vlist_node=1 {|type| of vlist nodes}
+
+@ A |rule_node| stands for a solid black rectangle; it has |width|,
+|depth|, and |height| fields just as in an |hlist_node|. However, if
+any of these dimensions is $-2^{30}$, the actual value will be determined
+by running the rule up to the boundary of the innermost enclosing box.
+This is called a ``running dimension.'' The |width| is never running in
+an hlist; the |height| and |depth| are never running in a~vlist.
+
+@d rule_node=2 {|type| of rule nodes}
+@d rule_node_size=6 {number of words to allocate for a rule node}
+@d null_flag==-@'10000000000 {$-2^{30}$, signifies a missing item}
+@d is_running(#) == (#=null_flag) {tests for a running dimension}
+@d rule_dir(#)==vlink(#+5)
+
+@ A new rule node is delivered by the |new_rule| function. It
+makes all the dimensions ``running,'' so you have to change the
+ones that are not allowed to run.
+
+@p
+function new_rule:pointer;
+var p:pointer; {the new node}
+begin p:=new_node(rule_node,0); {the |subtype| is not used}
+new_rule:=p;
+end;
+
+
+@ Insertions are represented by |ins_node| records, where the |subtype|
+indicates the corresponding box number. For example, `\.{\\insert 250}'
+leads to an |ins_node| whose |subtype| is |250+min_quarterword|.
+The |height| field of an |ins_node| is slightly misnamed; it actually holds
+the natural height plus depth of the vertical list being inserted.
+The |depth| field holds the |split_max_depth| to be used in case this
+insertion is split, and the |split_top_ptr| points to the corresponding
+|split_top_skip|. The |float_cost| field holds the |floating_penalty| that
+will be used if this insertion floats to a subsequent page after a
+split insertion of the same class. There is one more field, the
+|ins_ptr|, which points to the beginning of the vlist for the insertion.
+
+@d ins_node=3 {|type| of insertion nodes}
+@d ins_node_size=6 {number of words to allocate for an insertion}
+@d float_cost(#)==vmem(#+2).int {the |floating_penalty| to be used}
+@d ins_ptr(#)==vinfo(#+5) {the vertical list to be inserted}
+@d split_top_ptr(#)==vlink(#+5) {the |split_top_skip| to be used}
+
+@ A |mark_node| has a |mark_ptr| field that points to the reference count
+of a token list that contains the user's \.{\\mark} text.
+In addition there is a |mark_class| field that contains the mark class.
+
+@d mark_node=4 {|type| of a mark node}
+@d mark_node_size=3 {number of words to allocate for a mark node}
+@d mark_ptr(#)==vlink(#+2) {head of the token list for a mark}
+@d mark_class(#)==vinfo(#+2) {the mark class}
+
+@ An |adjust_node|, which occurs only in horizontal lists,
+specifies material that will be moved out into the surrounding
+vertical list; i.e., it is used to implement \TeX's `\.{\\vadjust}'
+operation. The |adjust_ptr| field points to the vlist containing this
+material.
+
+@d adjust_node=5 {|type| of an adjust node}
+@d adjust_node_size=3
+@d adjust_pre == subtype {pre-adjustment?}
+@d adjust_ptr(#)==vlink(#+2) {vertical list to be moved out of horizontal list}
+@#{|append_list| is used to append a list to |tail|}
+@d append_list(#) == begin vlink(tail) := vlink(#); append_list_end
+@d append_list_end(#) == tail := #; end
+
+@ A |glyph_node|, which occurs only in horizontal lists, specifies a
+glyph in a particular font, along with its attribute list. Older
+versions of \TeX\ could use token memory for characters, because the
+font,char combination would fit in a single word (both values were
+required to be strictly less than $2^{16}$). In \LuaTeX, room is
+needed for characters that are larger than that, as well as a pointer
+to a potential attribute list, and the two displacement values.
+
+In turn, that made the node so large that it made sense to merge
+ligature glyphs as well, as that requires only one extra pointer. A
+few extra classes of glyph nodes will be introduced later. The
+unification of all those types makes it easier to manipulate lists of
+glyphs. The subtype differentiates various glyph kinds.
+
+First, here is a function that returns a pointer to a glyph node for a given
+glyph in a given font. If that glyph doesn't exist, |null| is returned
+instead. Nodes of this subtype are directly created only for accents
+and their base (through |make_accent|), and math nucleus items (in the
+conversion from |mlist| to |hlist|).
+
+
+@d glyph_node_size=5
+@d glyph_node=33 {|type| of a glyph node}
+@d is_char_node(#) == ((#<>null)and(type(#)=glyph_node))
+@d font(#)==vlink(#+2) {the font code in a |glyph_node|}
+@d character(#)==vinfo(#+2) {the character code in a |glyph_node|}
+@d lig_ptr(#)==vlink(#+3) {the list of characters for ligature replacements }
+@d lang_data(#)==vinfo(#+3) {language information }
+@d x_displace(#)==vinfo(#+4) { horizontal displacement }
+@d y_displace(#)==vlink(#+4) { vertical displacement }
+
+@p function new_glyph(@!f,@!c:integer):pointer;
+var p:pointer; {the new node}
+begin p:=null;
+if (f=0) or (char_exists(f,c)) then begin
+ p:=new_glyph_node;
+ set_to_glyph(p); font(p):=f; character(p):=c;
+ end;
+new_glyph:=p;
+end;
+
+
+@ A subset of the glyphs nodes represent ligatures: characters
+fabricated from the interaction of two or more actual characters. The
+characters that generated the ligature have not been forgotten, since
+they are needed for diagnostic messages; the |lig_ptr| field points to
+a linked list of character nodes for all original characters that have
+been deleted. (This list might be empty if the characters that
+generated the ligature were retained in other nodes.)
+
+The |subtype| field of these |glyph_node|s is 1, plus 2 and/or 1 if
+the original source of the ligature included implicit left and/or
+right boundaries. These nodes are created by the C function |new_ligkern|.
+
+@ A third general type of glyphs could be called a character, as it
+only appears in lists that are not yet processed by the ligaturing and
+kerning steps of the program.
+
+|main_control| inserts these, and they are later converted to
+|subtype_normal| by |new_ligkern|.
+
+@p function norm_min(@!h:integer):quarterword;
+begin if h<=0 then norm_min:=1@+else if h>=255 then norm_min:=255@+
+else norm_min:=h;
+end;
+@#
+function new_char(@!f,@!c:integer):pointer;
+var p:pointer; {the new node}
+begin p:=new_glyph_node;
+set_to_character(p); font(p):=f; character(p):=c;
+lang_data(p):=make_lang_data(uc_hyph,cur_lang,left_hyphen_min,right_hyphen_min);
+new_char:=p;
+end;
+
+@ Left and right ghost glyph nodes are the result of \.{\\leftghost}
+and \.{\\rightghost}, respectively. They are going to be removed by
+|new_ligkern|, at the end of which they are no longer needed.
+
+@ Here are a few handy helpers used by the list output routines.
+
+@p
+function glyph_width(@!p:halfword):pointer;
+var w:integer;
+begin
+ w := char_width(font(p),character(p)); { |+ x_displace(p);| }
+ glyph_width := w;
+end;
+@#
+function glyph_height(@!p:halfword):pointer;
+var w:integer;
+begin
+ w := char_height(font(p),character(p)) + y_displace(p);
+ if w<0 then w:=0;
+ glyph_height := w;
+end;
+@#
+function glyph_depth(@!p:halfword):pointer;
+var w:integer;
+begin
+ w := char_depth(font(p),character(p));
+ if y_displace(p)>0 then w := w - y_displace(p);
+ if w<0 then w:=0;
+ glyph_depth := w;
+end;
+
+
+@ A |disc_node|, which occurs only in horizontal lists, specifies a
+``dis\-cretion\-ary'' line break. If such a break occurs at node |p|, the text
+that starts at |pre_break(p)| will precede the break, the text that starts at
+|post_break(p)| will follow the break, and text that appears in
+|no_break(p)| nodes will be ignored. For example, an ordinary
+discretionary hyphen, indicated by `\.{\\-}', yields a |disc_node| with
+|pre_break| pointing to a |char_node| containing a hyphen, |post_break=null|,
+and |no_break=null|.
+
+{TODO: Knuth said: All three of the discretionary texts must be lists
+that consist entirely of character, kern, box and rule nodes.}
+
+If |subtype(p)=automatic_disc|, the |ex_hyphen_penalty| will be charged for this
+break. Otherwise the |hyphen_penalty| will be charged. The texts will
+actually be substituted into the list by the line-breaking algorithm if it
+decides to make the break, and the discretionary node will disappear at
+that time; thus, the output routine sees only discretionaries that were
+not chosen.
+
+@d disc_node=7 {|type| of a discretionary node}
+@d disc_node_size=10
+@d automatic_disc=2
+@d syllable_disc=3
+@d disc_type==subtype {the kind of discretionary}
+@d pre_break(#)==vinfo(#+2) {text that precedes a discretionary break}
+@d post_break(#)==vlink(#+2) {text that follows a discretionary break}
+@d no_break(#)==vlink(#+3) {text this discretionary break replaces}
+@d pre_break_head(#)==(#+4)
+@d post_break_head(#)==(#+6)
+@d no_break_head(#)==(#+8)
+@d tlink(#)==vinfo(#+1)
+
+@p function new_disc:pointer; {creates an empty |disc_node|}
+var p:pointer; {the new node}
+begin p:=new_node(disc_node,0);
+new_disc:=p;
+end;
+
+@ A |whatsit_node| is a wild card reserved for extensions to \TeX. The
+|subtype| field in its first word says what `\\{whatsit}' it is, and
+implicitly determines the node size (which must be 2 or more) and the
+format of the remaining words. When a |whatsit_node| is encountered
+in a list, special actions are invoked; knowledgeable people who are
+careful not to mess up the rest of \TeX\ are able to make \TeX\ do new
+things by adding code at the end of the program. For example, there
+might be a `\TeX nicolor' extension to specify different colors of ink,
+@^extensions to \TeX@>
+and the whatsit node might contain the desired parameters.
+
+The present implementation of \TeX\ treats the features associated with
+`\.{\\write}' and `\.{\\special}' as if they were extensions, in order to
+illustrate how such routines might be coded. We shall defer further
+discussion of extensions until the end of this program.
+
+@d whatsit_node=8 {|type| of special extension nodes}
+
+@ A |math_node|, which occurs only in horizontal lists, appears before and
+after mathematical formulas. The |subtype| field is |before| before the
+formula and |after| after it. There is a |surround| field, which represents
+the amount of surrounding space inserted by \.{\\mathsurround}.
+
+@d math_node=9 {|type| of a math node}
+@d math_node_size=3
+@d surround(#)==vlink(#+2)
+@d before=0 {|subtype| for math node that introduces a formula}
+@d after=1 {|subtype| for math node that winds up a formula}
+
+@p function new_math(@!w:scaled;@!s:small_number):pointer;
+var p:pointer; {the new node}
+begin p:=new_node(math_node,s);
+surround(p):=w; new_math:=p;
+end;
+
+@ \TeX\ makes use of the fact that |hlist_node|, |vlist_node|,
+|rule_node|, |ins_node|, |mark_node|, |adjust_node|,
+|disc_node|, |whatsit_node|, and |math_node| are at the low end of the
+type codes, by permitting a break at glue in a list if and only if the
+|type| of the previous node is less than |math_node|. Furthermore, a
+node is discarded after a break if its type is |math_node| or~more.
+
+@d precedes_break(#)==(type(#)<math_node)
+@d non_discardable(#)==(type(#)<math_node)
+
+@ A |glue_node| represents glue in a list. However, it is really only
+a pointer to a separate glue specification, since \TeX\ makes use of the
+fact that many essentially identical nodes of glue are usually present.
+If |p| points to a |glue_node|, |glue_ptr(p)| points to
+another packet of words that specify the stretch and shrink components, etc.
+
+Glue nodes also serve to represent leaders; the |subtype| is used to
+distinguish between ordinary glue (which is called |normal|) and the three
+kinds of leaders (which are called |a_leaders|, |c_leaders|, and |x_leaders|).
+The |leader_ptr| field points to a rule node or to a box node containing the
+leaders; it is set to |null| in ordinary glue nodes.
+
+Many kinds of glue are computed from \TeX's ``skip'' parameters, and
+it is helpful to know which parameter has led to a particular glue node.
+Therefore the |subtype| is set to indicate the source of glue, whenever
+it originated as a parameter. We will be defining symbolic names for the
+parameter numbers later (e.g., |line_skip_code=0|, |baseline_skip_code=1|,
+etc.); it suffices for now to say that the |subtype| of parametric glue
+will be the same as the parameter number, plus~one.
+
+In math formulas there are two more possibilities for the |subtype| in a
+glue node: |mu_glue| denotes an \.{\\mskip} (where the units are scaled \.{mu}
+instead of scaled \.{pt}); and |cond_math_glue| denotes the `\.{\\nonscript}'
+feature that cancels the glue node immediately following if it appears
+in a subscript.
+
+@d glue_node=10 {|type| of node that points to a glue specification}
+@d glue_node_size=3
+@d cond_math_glue=98 {special |subtype| to suppress glue in the next node}
+@d mu_glue=99 {|subtype| for math glue}
+@d a_leaders=100 {|subtype| for aligned leaders}
+@d c_leaders=101 {|subtype| for centered leaders}
+@d x_leaders=102 {|subtype| for expanded leaders}
+@d glue_ptr(#)==vinfo(#+2) {pointer to a glue specification}
+@d leader_ptr(#)==vlink(#+2) {pointer to box or rule node for leaders}
+
+@ A glue specification has a halfword reference count in its first word,
+@^reference counts@>
+representing |null| plus the number of glue nodes that point to it (less one).
+Note that the reference count appears in the same position as
+the |link| field in list nodes; this is the field that is initialized
+to |null| when a node is allocated, and it is also the field that is flagged
+by |empty_flag| in empty nodes.
+
+Glue specifications also contain three |scaled| fields, for the |width|,
+|stretch|, and |shrink| dimensions. Finally, there are two one-byte
+fields called |stretch_order| and |shrink_order|; these contain the
+orders of infinity (|normal|, |sfi|, |fil|, |fill|, or |filll|)
+corresponding to the stretch and shrink values.
+
+@d glue_spec_size=4 {number of words to allocate for a glue specification}
+@d glue_spec_node=43
+@d glue_ref_count(#) == vlink(#+3) {reference count of a glue specification}
+@d stretch(#) == vlink(#+1) {the stretchability of this glob of glue}
+@d shrink(#) == vinfo(#+1) {the shrinkability of this glob of glue}
+@d stretch_order(#) == type(#+3) {order of infinity for stretching}
+@d shrink_order(#) == subtype(#+3) {order of infinity for shrinking}
+@d sfi=1 {first-order infinity}
+@d fil=2 {second-order infinity}
+@d fill=3 {third-order infinity}
+@d filll=4 {fourth-order infinity}
+
+@<Types...@>=
+@!glue_ord=normal..filll; {infinity to the 0, 1, 2, 3, or 4 power}
+
+@ Here is a function that returns a pointer to a copy of a glue spec.
+The reference count in the copy is |null|, because there is assumed
+to be exactly one reference to the new specification.
+
+@p function new_spec(@!p:pointer):pointer; {duplicates a glue specification}
+var q:pointer; {the new spec}
+begin q:=copy_node(p);
+glue_ref_count(q):=null;
+new_spec:=q;
+end;
+
+@ And here's a function that creates a glue node for a given parameter
+identified by its code number; for example,
+|new_param_glue(line_skip_code)| returns a pointer to a glue node for the
+current \.{\\lineskip}.
+
+@p function new_param_glue(@!n:small_number):pointer;
+var p:pointer; {the new node}
+@!q:pointer; {the glue specification}
+begin p:=new_node(glue_node,n+1);
+q:=@<Current |mem| equivalent of glue parameter number |n|@>@t@>;
+glue_ptr(p):=q; incr(glue_ref_count(q));
+new_param_glue:=p;
+end;
+
+@ Glue nodes that are more or less anonymous are created by |new_glue|,
+whose argument points to a glue specification.
+
+@p function new_glue(@!q:pointer):pointer;
+var p:pointer; {the new node}
+begin p:=new_node(glue_node,normal);
+glue_ptr(p):=q; incr(glue_ref_count(q));
+new_glue:=p;
+end;
+
+@ Still another subroutine is needed: this one is sort of a combination
+of |new_param_glue| and |new_glue|. It creates a glue node for one of
+the current glue parameters, but it makes a fresh copy of the glue
+specification, since that specification will probably be subject to change,
+while the parameter will stay put. The global variable |temp_ptr| is
+set to the address of the new spec.
+
+@p function new_skip_param(@!n:small_number):pointer;
+var p:pointer; {the new node}
+begin temp_ptr:=new_spec(@<Current |mem| equivalent of glue parameter...@>);
+p:=new_glue(temp_ptr); glue_ref_count(temp_ptr):=null; subtype(p):=n+1;
+new_skip_param:=p;
+end;
+
+@ A |kern_node| has a |width| field to specify a (normally negative)
+amount of spacing. This spacing correction appears in horizontal lists
+between letters like A and V when the font designer said that it looks
+better to move them closer together or further apart. A kern node can
+also appear in a vertical list, when its `|width|' denotes additional
+spacing in the vertical direction. The |subtype| is either |normal| (for
+kerns inserted from font information or math mode calculations) or |explicit|
+(for kerns inserted from \.{\\kern} and \.{\\/} commands) or |acc_kern|
+(for kerns inserted from non-math accents) or |mu_glue| (for kerns
+inserted from \.{\\mkern} specifications in math formulas).
+
+@d kern_node=11 {|type| of a kern node}
+@d kern_node_size=3
+@d explicit=1 {|subtype| of kern nodes from \.{\\kern} and \.{\\/}}
+@d acc_kern=2 {|subtype| of kern nodes from accents}
+
+@# {memory structure for marginal kerns}
+@d margin_kern_node = 32
+@d margin_kern_node_size = 4
+@d margin_char(#) == vlink(#+3)
+
+@# {|subtype| of marginal kerns}
+@d left_side == 0
+@d right_side == 1
+
+@# {base for lp/rp/ef codes starts from 2:
+ 0 for |hyphen_char|,
+ 1 for |skew_char|}
+@d lp_code_base == 2
+@d rp_code_base == 3
+@d ef_code_base == 4
+@d tag_code == 5
+
+@d auto_kern == explicit
+@d no_lig_code == 6
+
+@ The |new_kern| function creates a kern node having a given width.
+
+@p function new_kern(@!w:scaled):pointer;
+var p:pointer; {the new node}
+begin p:=new_node(kern_node,normal);
+width(p):=w;
+new_kern:=p;
+end;
+
+@ A |penalty_node| specifies the penalty associated with line or page
+breaking, in its |penalty| field. This field is a fullword integer, but
+the full range of integer values is not used: Any penalty |>=10000| is
+treated as infinity, and no break will be allowed for such high values.
+Similarly, any penalty |<=-10000| is treated as negative infinity, and a
+break will be forced.
+
+@d penalty_node=12 {|type| of a penalty node}
+@d penalty_node_size=3 {has to be the same as |glue_node_size|}
+@d inf_penalty=inf_bad {``infinite'' penalty value}
+@d eject_penalty=-inf_penalty {``negatively infinite'' penalty value}
+@d penalty(#) == vlink(#+2) {the added cost of breaking a list here}
+
+@ Anyone who has been reading the last few sections of the program will
+be able to guess what comes next.
+
+@p function new_penalty(@!m:integer):pointer;
+var p:pointer; {the new node}
+begin p:=new_node(penalty_node,0); {the |subtype| is not used}
+penalty(p):=m; new_penalty:=p;
+end;
+
+@ You might think that we have introduced enough node types by now. Well,
+almost, but there is one more: An |unset_node| has nearly the same format
+as an |hlist_node| or |vlist_node|; it is used for entries in \.{\\halign}
+or \.{\\valign} that are not yet in their final form, since the box
+dimensions are their ``natural'' sizes before any glue adjustment has been
+made. The |glue_set| word is not present; instead, we have a |glue_stretch|
+field, which contains the total stretch of order |glue_order| that is
+present in the hlist or vlist being boxed.
+Similarly, the |shift_amount| field is replaced by a |glue_shrink| field,
+containing the total shrink of order |glue_sign| that is present.
+The |subtype| field is called |span_count|; an unset box typically
+contains the data for |qo(span_count)+1| columns.
+Unset nodes will be changed to box nodes when alignment is completed.
+
+@d unset_node=13 {|type| for an unset node}
+@d glue_stretch(#)==vmem(#+glue_offset).sc {total stretch in an unset node}
+@d glue_shrink==shift_amount {total shrink in an unset node}
+@d span_count==subtype {indicates the number of spanned columns}
+
+@ In fact, there are still more types coming. When we get to math formula
+processing we will see that a |style_node| has |type=14|; and a number
+of larger type codes will also be defined, for use in math mode only.
+
+@ Warning: If any changes are made to these data structure layouts, such as
+changing any of the node sizes or even reordering the words of nodes,
+the |copy_node_list| procedure and the memory initialization code
+below may have to be changed. Such potentially dangerous parts of the
+program are listed in the index under `data structure assumptions'.
+@!@^data structure assumptions@>
+However, other references to the nodes are made symbolically in terms of
+the \.{WEB} macro definitions above, so that format changes will leave
+\TeX's other algorithms intact.
+@^system dependencies@>
+
+@* \[11] Memory layout.
+Some areas of |mem| are dedicated to fixed usage, since static allocation is
+more efficient than dynamic allocation when we can get away with it. For
+example, |zero_glue| used for glue that is `\.{0pt plus 0pt minus 0pt}'. The
+following macro definitions accomplish the static allocation by giving
+symbolic names to the fixed positions.
+
+@d zero_glue==0 {specification for \.{0pt plus 0pt minus 0pt}}
+@d sfi_glue==zero_glue+glue_spec_size {\.{0pt plus 1fi minus 0pt}}
+@d fil_glue==sfi_glue+glue_spec_size {\.{0pt plus 1fil minus 0pt}}
+@d fill_glue==fil_glue+glue_spec_size {\.{0pt plus 1fill minus 0pt}}
+@d ss_glue==fill_glue+glue_spec_size {\.{0pt plus 1fil minus 1fil}}
+@d fil_neg_glue==ss_glue+glue_spec_size {\.{0pt plus -1fil minus 0pt}}
+@d page_ins_head==fil_neg_glue+glue_spec_size {list of insertion data for current page}
+@d contrib_head==page_ins_head+temp_node_size {list of items not yet on current page}
+@d page_head==contrib_head+temp_node_size {list for current page}
+@d temp_head==page_head+temp_node_size {head of a temporary list of some kind}
+@d hold_head==temp_head+temp_node_size {head of a temporary list of another kind}
+@d adjust_head==hold_head+temp_node_size {head of adjustment list returned by |hpack|}
+@d pre_adjust_head==adjust_head+temp_node_size {head of pre-adjustment list returned by |hpack|}
+@d active==pre_adjust_head+temp_node_size {head of active list in |line_break|}
+@d align_head==active+active_node_size {head of preamble list for alignments}
+@d end_span==align_head+temp_node_size {tail of spanned-width lists}
+@d begin_point==end_span+span_node_size {left-side dot for words in hyphenation}
+@d end_point==begin_point+glyph_node_size {right-side dot for words in hyphenation}
+@d var_mem_stat_max==(end_point+glyph_node_size-1) {largest statically allocated word in the variable-size |mem|}
+
+@<Glob...@>=
+garbage:pointer; {head of a junk list, write only}
+temp_token_head:pointer; {head of a temporary list of some kind}
+hold_token_head:pointer; {head of a temporary list of another kind}
+omit_template:pointer; {a constant token list}
+null_list:pointer; {permanently empty list}
+backup_head:pointer; {head of token list built by |scan_keyword|}
+
+@ The following code gets |mem| off to a good start, when \TeX\ is
+initializing itself the slow~way.
+
+@<Local variables for init...@>=
+@!k:integer; {index into |mem|, |eqtb|, etc.}
+
+@ @<Initialize table entries...@>=
+procedure init_link_heads;forward;
+init_node_mem(var_mem_stat_max,500);
+glue_ref_count(zero_glue):=null+1; width(zero_glue):=0;
+type(zero_glue):=glue_spec_node; vlink(zero_glue):=null;
+stretch(zero_glue):=0; stretch_order(zero_glue):=normal;@/
+shrink(zero_glue):=0; shrink_order(zero_glue):=normal;@/
+glue_ref_count(sfi_glue):=null+1; width(sfi_glue):=0;
+type(sfi_glue):=glue_spec_node; vlink(sfi_glue):=null;
+stretch(sfi_glue):=0; stretch_order(sfi_glue):=sfi;@/
+shrink(sfi_glue):=0; shrink_order(sfi_glue):=normal;@/
+glue_ref_count(fil_glue):=null+1; width(fil_glue):=0;
+type(fil_glue):=glue_spec_node; vlink(fil_glue):=null;
+stretch(fil_glue):=unity; stretch_order(fil_glue):=fil;@/
+shrink(fil_glue):=0; shrink_order(fil_glue):=normal;@/
+glue_ref_count(fill_glue):=null+1; width(fill_glue):=0;
+type(fill_glue):=glue_spec_node; vlink(fill_glue):=null;
+stretch(fill_glue):=unity; stretch_order(fill_glue):=fill;@/
+shrink(fill_glue):=0; shrink_order(fill_glue):=normal;@/
+glue_ref_count(ss_glue):=null+1; width(ss_glue):=0;
+type(ss_glue):=glue_spec_node; vlink(ss_glue):=null;
+stretch(ss_glue):=unity; stretch_order(ss_glue):=fil;@/
+shrink(ss_glue):=unity; shrink_order(ss_glue):=fil;@/
+glue_ref_count(fil_neg_glue):=null+1; width(fil_neg_glue):=0;
+type(fil_neg_glue):=glue_spec_node; vlink(fil_neg_glue):=null;
+stretch(fil_neg_glue):=-unity; stretch_order(fil_neg_glue):=fil;@/
+shrink(fil_neg_glue):=0; shrink_order(fil_neg_glue):=normal;@/
+{initialize node list heads}
+vinfo(page_ins_head):=0; vlink(page_ins_head):=null; alink(page_ins_head):=null;
+vinfo(contrib_head):=0; vlink(contrib_head):=null; alink(contrib_head):=null;
+vinfo(page_head):=0; vlink(page_head):=null; alink(page_head):=null;
+vinfo(temp_head):=0; vlink(temp_head):=null; alink(temp_head):=null;
+vinfo(hold_head):=0; vlink(hold_head):=null; alink(hold_head):=null;
+vinfo(adjust_head):=0; vlink(adjust_head):=null; alink(adjust_head):=null;
+vinfo(pre_adjust_head):=0; vlink(pre_adjust_head):=null; alink(pre_adjust_head):=null;
+vinfo(active):=0; vlink(active):=null; alink(active):=null;
+vinfo(align_head):=0; vlink(align_head):=null; alink(align_head):=null;
+vinfo(end_span):=0; vlink(end_span):=null; alink(end_span):=null;
+type(begin_point):=glyph_node; subtype(begin_point):=0; vlink(begin_point):=null;
+vinfo(begin_point+1):=null; alink(begin_point):=null;
+font(begin_point):=0; character(begin_point):='.';
+vinfo(begin_point+3):=0; vlink(begin_point+3):=0;
+vinfo(begin_point+4):=0; vlink(begin_point+4):=0;
+type(end_point):=glyph_node; subtype(end_point):=0; vlink(end_point):=null;
+vinfo(end_point+1):=null; alink(end_point):=null;
+font(end_point):=0; character(end_point):='.';
+vinfo(end_point+3):=0; vlink(end_point+3):=0;
+vinfo(end_point+4):=0; vlink(end_point+4):=0;
+avail:=null; fix_mem_end:=0;
+init_list_heads;
+@<Initialize the special list heads and constant nodes@>;
+initialize_active;
+dyn_used:=0; {initialize statistics}
+
+@ @p procedure init_list_heads; {initialize token list heads}
+var p:halfword;
+begin
+p:=get_avail; temp_token_head:=p; info(temp_token_head):=0;
+p:=get_avail; hold_token_head:=p; info(hold_token_head):=0;
+p:=get_avail; omit_template:=p; info(omit_template):=0;
+p:=get_avail; null_list:=p; info(null_list):=0;
+p:=get_avail; backup_head:=p; info(backup_head):=0;
+p:=get_avail; garbage:=p; info(garbage):=0;
+end;
+
+@ @p
+@<Declare procedures that need to be declared forward for \pdfTeX@>
+
+@* \[12] Displaying boxes.
+We can reinforce our knowledge of the data structures just introduced
+by considering two procedures that display a list in symbolic form.
+The first of these, called |short_display|, is used in ``overfull box''
+messages to give the top-level description of a list. The other one,
+called |show_node_list|, prints a detailed description of exactly what
+is in the data structure.
+
+The philosophy of |short_display| is to ignore the fine points about exactly
+what is inside boxes, except that ligatures and discretionary breaks are
+expanded. As a result, |short_display| is a recursive procedure, but the
+recursion is never more than one level deep.
+@^recursion@>
+
+A global variable |font_in_short_display| keeps track of the font code that
+is assumed to be present when |short_display| begins; deviations from this
+font will be printed.
+
+@<Glob...@>=
+@!font_in_short_display:integer; {an internal font number}
+
+@ Boxes, rules, inserts, whatsits, marks, and things in general that are
+sort of ``complicated'' are indicated only by printing `\.{[]}'.
+
+@p
+procedure print_font_identifier(f: internal_font_number);
+begin
+ if pdf_font_blink(f) = null_font then
+ print_esc(font_id_text(f))
+ else
+ print_esc(font_id_text(pdf_font_blink(f)));
+ if pdf_tracing_fonts > 0 then begin
+ print(" (");
+ print_font_name(f);
+ if font_size(f) <> font_dsize(f) then begin
+ print("@@");
+ print_scaled(font_size(f));
+ print("pt");
+ end;
+ print(")");
+ end else
+ if pdf_font_expand_ratio(f) <> 0 then begin
+ print(" (");
+ if pdf_font_expand_ratio(f) > 0 then
+ print("+");
+ print_int(pdf_font_expand_ratio(f));
+ print(")");
+ end;
+end;
+
+procedure short_display(@!p:integer); {prints highlights of list |p|}
+begin while p<>null do
+ begin if is_char_node(p) then
+ begin if lig_ptr(p)<>null then
+ short_display(lig_ptr(p))
+ else begin
+ if font(p)<>font_in_short_display then
+ begin if not is_valid_font(font(p)) then
+ print_char("*")
+@.*\relax@>
+ else print_font_identifier(font(p));
+ print_char(" "); font_in_short_display:=font(p);
+ end;
+ print(qo(character(p)));
+ end;
+ end
+ else @<Print a short indication of the contents of node |p|@>;
+ p:=vlink(p);
+ end;
+end;
+
+@ @<Print a short indication of the contents of node |p|@>=
+case type(p) of
+hlist_node,vlist_node,ins_node,whatsit_node,mark_node,adjust_node,
+ unset_node: print("[]");
+rule_node: print_char("|");
+glue_node: if glue_ptr(p)<>zero_glue then print_char(" ");
+math_node: print_char("$");
+disc_node: begin short_display(vlink(pre_break(p)));
+ short_display(vlink(post_break(p)));@/
+ end;
+othercases do_nothing
+endcases
+
+@ The |show_node_list| routine requires some auxiliary subroutines: one to
+print a font-and-character combination, one to print a token list without
+its reference count, and one to print a rule dimension.
+
+@p procedure print_font_and_char(@!p:integer); {prints |char_node| data}
+begin if not is_valid_font(font(p)) then print_char("*")
+@.*\relax@>
+ else print_font_identifier(font(p));
+ print_char(" "); print(character(p));
+end;
+@#
+procedure print_mark(@!p:integer); {prints token list data in braces}
+begin print_char("{");
+if (p<fix_mem_min)or(p>fix_mem_end) then print_esc("CLOBBERED.")
+else show_token_list(link(p),null,max_print_line-10);
+print_char("}");
+end;
+@#
+procedure print_rule_dimen(@!d:scaled); {prints dimension in rule node}
+begin if is_running(d) then print_char("*") else print_scaled(d);
+@.*\relax@>
+end;
+@#
+procedure print_dir(d:integer);
+begin
+print(dir_names[dir_primary[d]]);
+print(dir_names[dir_secondary[d]]);
+print(dir_names[dir_tertiary[d]]);
+end;
+
+
+@ Then there is a subroutine that prints glue stretch and shrink, possibly
+followed by the name of finite units:
+
+@p procedure print_glue(@!d:scaled;@!order:integer;@!s:str_number);
+ {prints a glue component}
+begin print_scaled(d);
+if (order<normal)or(order>filll) then print("foul")
+else if order>normal then
+ begin print("fi");
+ while order>sfi do
+ begin print_char("l"); decr(order);
+ end;
+ end
+else if s<>0 then print(s);
+end;
+
+@ The next subroutine prints a whole glue specification.
+
+@p procedure print_spec(@!p:integer;@!s:str_number);
+ {prints a glue specification}
+begin if p<0 then print_char("*")
+@.*\relax@>
+else begin print_scaled(width(p));
+ if s<>0 then print(s);
+ if stretch(p)<>0 then
+ begin print(" plus "); print_glue(stretch(p),stretch_order(p),s);
+ end;
+ if shrink(p)<>0 then
+ begin print(" minus "); print_glue(shrink(p),shrink_order(p),s);
+ end;
+ end;
+end;
+
+@ We also need to declare some procedures that appear later in this
+documentation.
+
+@p @<Declare procedures needed for displaying the elements of mlists@>@;
+@<Declare the procedure called |print_skip_param|@>
+
+@ Since boxes can be inside of boxes, |show_node_list| is inherently recursive,
+@^recursion@>
+up to a given maximum number of levels. The history of nesting is indicated
+by the current string, which will be printed at the beginning of each line;
+the length of this string, namely |cur_length|, is the depth of nesting.
+
+Recursive calls on |show_node_list| therefore use the following pattern:
+
+@d node_list_display(#)==
+ begin append_char("."); show_node_list(#); flush_char;
+ end {|str_room| need not be checked; see |show_box| below}
+
+@ A global variable called |depth_threshold| is used to record the maximum
+depth of nesting for which |show_node_list| will show information. If we
+have |depth_threshold=0|, for example, only the top level information will
+be given and no sublists will be traversed. Another global variable, called
+|breadth_max|, tells the maximum number of items to show at each level;
+|breadth_max| had better be positive, or you won't see anything.
+
+@<Glob...@>=
+@!depth_threshold : integer; {maximum nesting depth in box displays}
+@!breadth_max : integer; {maximum number of items shown at the same list level}
+
+@ Now we are ready for |show_node_list| itself. This procedure has been
+written to be ``extra robust'' in the sense that it should not crash or get
+into a loop even if the data structures have been messed up by bugs in
+the rest of the program. You can safely call its parent routine
+|show_box(p)| for arbitrary values of |p| when you are debugging \TeX.
+However, in the presence of bad data, the procedure may
+@^dirty \PASCAL@>@^debugging@>
+fetch a |memory_word| whose variant is different from the way it was stored;
+for example, it might try to read |mem[p].hh| when |mem[p]|
+contains a scaled integer, if |p| is a pointer that has been
+clobbered or chosen at random.
+
+@p procedure show_node_list(@!p:integer); {prints a node list symbolically}
+label exit;
+var n:integer; {the number of items already printed at this level}
+@!g:real; {a glue ratio, as a floating point number}
+begin if cur_length>depth_threshold then
+ begin if p>null then print(" []");
+ {indicate that there's been some truncation}
+ return;
+ end;
+n:=0;
+while p<>null do
+ begin print_ln; print_current_string; {display the nesting history}
+ if tracing_online<-2 then print_int(p);
+ incr(n); if n>breadth_max then {time to stop}
+ begin print("etc."); return;
+@.etc@>
+ end;
+ @<Display node |p|@>;
+ p:=vlink(p);
+ end;
+exit:
+end;
+
+@ @<Display node |p|@>=
+if is_char_node(p) then begin
+ print_font_and_char(p);
+ if is_ligature(p) then @<Display ligature |p|@>;
+ end
+else case type(p) of
+ hlist_node,vlist_node,unset_node: @<Display box |p|@>;
+ rule_node: @<Display rule |p|@>;
+ ins_node: @<Display insertion |p|@>;
+ whatsit_node: @<Display the whatsit node |p|@>;
+ glue_node: @<Display glue |p|@>;
+ margin_kern_node: begin
+ print_esc("kern");
+ print_scaled(width(p));
+ if subtype(p) = left_side then
+ print(" (left margin)")
+ else
+ print(" (right margin)");
+ end;
+ kern_node: @<Display kern |p|@>;
+ math_node: @<Display math node |p|@>;
+ penalty_node: @<Display penalty |p|@>;
+ disc_node: @<Display discretionary |p|@>;
+ mark_node: @<Display mark |p|@>;
+ adjust_node: @<Display adjustment |p|@>;
+ @t\4@>@<Cases of |show_node_list| that arise in mlists only@>@;
+ othercases print("Unknown node type!")
+ endcases
+
+@ @<Display box |p|@>=
+begin if type(p)=hlist_node then print_esc("h")
+else if type(p)=vlist_node then print_esc("v")
+else print_esc("unset");
+print("box("); print_scaled(height(p)); print_char("+");
+print_scaled(depth(p)); print(")x"); print_scaled(width(p));
+if type(p)=unset_node then
+ @<Display special fields of the unset node |p|@>
+else begin @<Display the value of |glue_set(p)|@>;
+ if shift_amount(p)<>0 then
+ begin print(", shifted "); print_scaled(shift_amount(p));
+ end;
+ print(", direction "); print_dir(box_dir(p));
+ end;
+{|pdfassert(list_ptr(p)<>0);|}
+node_list_display(list_ptr(p)); {recursive call}
+end
+
+@ @<Display special fields of the unset node |p|@>=
+begin if span_count(p)<>min_quarterword then
+ begin print(" ("); print_int(qo(span_count(p))+1);
+ print(" columns)");
+ end;
+if glue_stretch(p)<>0 then
+ begin print(", stretch "); print_glue(glue_stretch(p),glue_order(p),0);
+ end;
+if glue_shrink(p)<>0 then
+ begin print(", shrink "); print_glue(glue_shrink(p),glue_sign(p),0);
+ end;
+end
+
+@ The code will have to change in this place if |glue_ratio| is
+a structured type instead of an ordinary |real|. Note that this routine
+should avoid arithmetic errors even if the |glue_set| field holds an
+arbitrary random value. The following code assumes that a properly
+formed nonzero |real| number has absolute value $2^{20}$ or more when
+it is regarded as an integer; this precaution was adequate to prevent
+floating point underflow on the author's computer.
+@^system dependencies@>
+@^dirty \PASCAL@>
+
+@<Display the value of |glue_set(p)|@>=
+g:=float(glue_set(p));
+if (g<>float_constant(0))and(glue_sign(p)<>normal) then
+ begin print(", glue set ");
+ if glue_sign(p)=shrinking then print("- ");
+ if abs(vmem(p+glue_offset).int)<@'4000000 then print("?.?")
+ else if abs(g)>float_constant(20000) then
+ begin if g>float_constant(0) then print_char(">")
+ else print("< -");
+ print_glue(20000*unity,glue_order(p),0);
+ end
+ else print_glue(round(unity*g),glue_order(p),0);
+@^real multiplication@>
+ end
+
+@ @<Display rule |p|@>=
+begin print_esc("rule("); print_rule_dimen(height(p)); print_char("+");
+print_rule_dimen(depth(p)); print(")x"); print_rule_dimen(width(p));
+end
+
+@ @<Display insertion |p|@>=
+begin print_esc("insert"); print_int(qo(subtype(p)));
+print(", natural size "); print_scaled(height(p));
+print("; split("); print_spec(split_top_ptr(p),0);
+print_char(","); print_scaled(depth(p));
+print("); float cost "); print_int(float_cost(p));
+node_list_display(ins_ptr(p)); {recursive call}
+end
+
+@ @<Display glue |p|@>=
+if subtype(p)>=a_leaders then @<Display leaders |p|@>
+else begin print_esc("glue");
+ if subtype(p)<>normal then
+ begin print_char("(");
+ if subtype(p)<cond_math_glue then
+ print_skip_param(subtype(p)-1)
+ else if subtype(p)=cond_math_glue then print_esc("nonscript")
+ else print_esc("mskip");
+ print_char(")");
+ end;
+ if subtype(p)<>cond_math_glue then
+ begin print_char(" ");
+ if subtype(p)<cond_math_glue then print_spec(glue_ptr(p),0)
+ else print_spec(glue_ptr(p),"mu");
+ end;
+ end
+
+@ @<Display leaders |p|@>=
+begin print_esc("");
+if subtype(p)=c_leaders then print_char("c")
+else if subtype(p)=x_leaders then print_char("x");
+print("leaders "); print_spec(glue_ptr(p),0);
+node_list_display(leader_ptr(p)); {recursive call}
+end
+
+@ An ``explicit'' kern value is indicated implicitly by an explicit space.
+
+@<Display kern |p|@>=
+if subtype(p)<>mu_glue then
+ begin print_esc("kern");
+ if subtype(p)<>normal then print_char(" ");
+ print_scaled(width(p));
+ if subtype(p)=acc_kern then print(" (for accent)");
+@.for accent@>
+ end
+else begin print_esc("mkern"); print_scaled(width(p)); print("mu");
+ end
+
+@ @<Display math node |p|@>=
+begin print_esc("math");
+if subtype(p)=before then print("on")
+else print("off");
+if width(p)<>0 then
+ begin print(", surrounded "); print_scaled(width(p));
+ end;
+end
+
+@ @<Display ligature |p|@>=
+begin print(" (ligature ");
+if is_leftboundary(p) then print_char("|");
+font_in_short_display:=font(p); short_display(lig_ptr(p));
+if is_rightboundary(p) then print_char("|");
+print_char(")");
+end
+
+@ @<Display penalty |p|@>=
+begin print_esc("penalty "); print_int(penalty(p));
+end
+
+@ The |post_break| list of a discretionary node is indicated by a prefixed
+`\.{\char'174}' instead of the `\..' before the |pre_break| list.
+
+@<Display discretionary |p|@>=
+begin print_esc("discretionary");
+if vlink(no_break(p))<>null then
+ begin print(" replacing "); node_list_display(vlink(no_break(p)));
+ end;
+node_list_display(vlink(pre_break(p))); {recursive call}
+append_char("|"); show_node_list(vlink(post_break(p))); flush_char; {recursive call}
+end
+
+@ @<Display mark |p|@>=
+begin print_esc("mark");
+if mark_class(p)<>0 then
+ begin print_char("s"); print_int(mark_class(p));
+ end;
+print_mark(mark_ptr(p));
+end
+
+@ @<Display adjustment |p|@>=
+begin print_esc("vadjust"); if adjust_pre(p) <> 0 then print(" pre ");
+node_list_display(adjust_ptr(p)); {recursive call}
+end
+
+@ The recursive machinery is started by calling |show_box|.
+@^recursion@>
+
+@p procedure show_box(@!p:pointer);
+begin @<Assign the values |depth_threshold:=show_box_depth| and
+ |breadth_max:=show_box_breadth|@>;
+if breadth_max<=0 then breadth_max:=5;
+if pool_ptr+depth_threshold>=pool_size then
+ depth_threshold:=pool_size-pool_ptr-1;
+ {now there's enough room for prefix string}
+show_node_list(p); {the show starts at |p|}
+print_ln;
+end;
+
+@* \[13] Destroying boxes.
+When we are done with a node list, we are obliged to return it to free
+storage, including all of its sublists. The recursive procedure
+|flush_node_list| does this for us.
+
+@ First, however, we shall consider two non-recursive procedures that do
+simpler tasks. The first of these, |delete_token_ref|, is called when
+a pointer to a token list's reference count is being removed. This means
+that the token list should disappear if the reference count was |null|,
+otherwise the count should be decreased by one.
+@^reference counts@>
+
+@d token_ref_count(#) == info(#) {reference count preceding a token list}
+
+@p procedure delete_token_ref(@!p:pointer); {|p| points to the reference count
+ of a token list that is losing one reference}
+begin pdfassert(token_ref_count(p)>=0);
+if token_ref_count(p)=0 then flush_list(p)
+else decr(token_ref_count(p));
+end;
+
+@ Similarly, |delete_glue_ref| is called when a pointer to a glue
+specification is being withdrawn.
+@^reference counts@>
+@d fast_delete_glue_ref(#)==@t@>@;@/
+ begin if glue_ref_count(#)=null then begin
+ flush_node(#);
+ end
+ else decr(glue_ref_count(#));
+ end
+
+@p procedure delete_glue_ref(@!p:pointer); {|p| points to a glue specification}
+begin
+ pdfassert(type(p)=glue_spec_node);
+ fast_delete_glue_ref(p);
+end;
+
+@ Now we are ready to delete any node list, recursively.
+In practice, the nodes deleted are usually charnodes (about 2/3 of the time),
+and they are glue nodes in about half of the remaining cases.
+@^recursion@>
+
+
+@* \[14] Copying boxes.
+Another recursive operation that acts on boxes is sometimes needed: The
+procedure |copy_node_list| returns a pointer to another node list that has
+the same structure and meaning as the original. Note that since glue
+specifications and token lists have reference counts, we need not make
+copies of them. Reference counts can never get too large to fit in a
+halfword, since each pointer to a node is in a different memory address,
+and the total number of memory addresses fits in a halfword.
+@^recursion@>
+@^reference counts@>
+
+(Well, there actually are also references from outside |mem|; if the
+|save_stack| is made arbitrarily large, it would theoretically be possible
+to break \TeX\ by overflowing a reference count. But who would want to do that?)
+
+@d add_token_ref(#)==incr(token_ref_count(#)) {new reference to a token list}
+@d add_glue_ref(#)==incr(glue_ref_count(#)) {new reference to a glue spec}
+
+@p function tail_of_list (@!p:pointer):pointer;
+var q:pointer;
+begin
+ q:=p;
+ while vlink(q)<>null do q:=vlink(q);
+ tail_of_list:=q;
+end;
+
+@* \[15] The command codes.
+Before we can go any further, we need to define symbolic names for the internal
+code numbers that represent the various commands obeyed by \TeX. These codes
+are somewhat arbitrary, but not completely so. For example, the command
+codes for character types are fixed by the language, since a user says,
+e.g., `\.{\\catcode \`\\\${} = 3}' to make \.{\char'44} a math delimiter,
+and the command code |math_shift| is equal to~3. Some other codes have
+been made adjacent so that |case| statements in the program need not consider
+cases that are widely spaced, or so that |case| statements can be replaced
+by |if| statements.
+
+At any rate, here is the list, for future reference. First come the
+``catcode'' commands, several of which share their numeric codes with
+ordinary commands when the catcode cannot emerge from \TeX's scanning routine.
+
+@d escape=0 {escape delimiter (called \.\\ in {\sl The \TeX book\/})}
+@:TeXbook}{\sl The \TeX book@>
+@d relax=0 {do nothing ( \.{\\relax} )}
+@d left_brace=1 {beginning of a group ( \.\{ )}
+@d right_brace=2 {ending of a group ( \.\} )}
+@d math_shift=3 {mathematics shift character ( \.\$ )}
+@d tab_mark=4 {alignment delimiter ( \.\&, \.{\\span} )}
+@d car_ret=5 {end of line ( |carriage_return|, \.{\\cr}, \.{\\crcr} )}
+@d out_param=5 {output a macro parameter}
+@d mac_param=6 {macro parameter symbol ( \.\# )}
+@d sup_mark=7 {superscript ( \.{\char'136} )}
+@d sub_mark=8 {subscript ( \.{\char'137} )}
+@d ignore=9 {characters to ignore ( \.{\^\^@@} )}
+@d endv=9 {end of \<v_j> list in alignment template}
+@d spacer=10 {characters equivalent to blank space ( \.{\ } )}
+@d letter=11 {characters regarded as letters ( \.{A..Z}, \.{a..z} )}
+@d other_char=12 {none of the special character types}
+@d active_char=13 {characters that invoke macros ( \.{\char`\~} )}
+@d par_end=13 {end of paragraph ( \.{\\par} )}
+@d match=13 {match a macro parameter}
+@d comment=14 {characters that introduce comments ( \.\% )}
+@d end_match=14 {end of parameters to macro}
+@d stop=14 {end of job ( \.{\\end}, \.{\\dump} )}
+@d invalid_char=15 {characters that shouldn't appear ( \.{\^\^?} )}
+@d delim_num=15 {specify delimiter numerically ( \.{\\delimiter} )}
+@d max_char_code=15 {largest catcode for individual characters}
+
+@ Next are the ordinary run-of-the-mill command codes. Codes that are
+|min_internal| or more represent internal quantities that might be
+expanded by `\.{\\the}'.
+
+@d char_num=16 {character specified numerically ( \.{\\char} )}
+@d math_char_num=17 {explicit math code ( \.{\\mathchar} )}
+@d mark=18 {mark definition ( \.{\\mark} )}
+@d xray=19 {peek inside of \TeX\ ( \.{\\show}, \.{\\showbox}, etc.~)}
+@d make_box=20 {make a box ( \.{\\box}, \.{\\copy}, \.{\\hbox}, etc.~)}
+@d hmove=21 {horizontal motion ( \.{\\moveleft}, \.{\\moveright} )}
+@d vmove=22 {vertical motion ( \.{\\raise}, \.{\\lower} )}
+@d un_hbox=23 {unglue a box ( \.{\\unhbox}, \.{\\unhcopy} )}
+@d un_vbox=24 {unglue a box ( \.{\\unvbox}, \.{\\unvcopy} )}
+ {( or \.{\\pagediscards}, \.{\\splitdiscards} )}
+@d remove_item=25 {nullify last item ( \.{\\unpenalty},
+ \.{\\unkern}, \.{\\unskip} )}
+@d hskip=26 {horizontal glue ( \.{\\hskip}, \.{\\hfil}, etc.~)}
+@d vskip=27 {vertical glue ( \.{\\vskip}, \.{\\vfil}, etc.~)}
+@d mskip=28 {math glue ( \.{\\mskip} )}
+@d kern=29 {fixed space ( \.{\\kern})}
+@d mkern=30 {math kern ( \.{\\mkern} )}
+@d leader_ship=31 {use a box ( \.{\\shipout}, \.{\\leaders}, etc.~)}
+@d halign=32 {horizontal table alignment ( \.{\\halign} )}
+@d valign=33 {vertical table alignment ( \.{\\valign} )}
+@d no_align=34 {temporary escape from alignment ( \.{\\noalign} )}
+@d vrule=35 {vertical rule ( \.{\\vrule} )}
+@d hrule=36 {horizontal rule ( \.{\\hrule} )}
+@d insert=37 {vlist inserted in box ( \.{\\insert} )}
+@d vadjust=38 {vlist inserted in enclosing paragraph ( \.{\\vadjust} )}
+@d ignore_spaces=39 {gobble |spacer| tokens ( \.{\\ignorespaces} )}
+@d after_assignment=40 {save till assignment is done ( \.{\\afterassignment} )}
+@d after_group=41 {save till group is done ( \.{\\aftergroup} )}
+@d break_penalty=42 {additional badness ( \.{\\penalty} )}
+@d start_par=43 {begin paragraph ( \.{\\indent}, \.{\\noindent} )}
+@d ital_corr=44 {italic correction ( \.{\\/} )}
+@d accent=45 {attach accent in text ( \.{\\accent} )}
+@d math_accent=46 {attach accent in math ( \.{\\mathaccent} )}
+@d discretionary=47 {discretionary texts ( \.{\\-}, \.{\\discretionary} )}
+@d eq_no=48 {equation number ( \.{\\eqno}, \.{\\leqno} )}
+@d left_right=49 {variable delimiter ( \.{\\left}, \.{\\right} )}
+ {( or \.{\\middle} )}
+@d math_comp=50 {component of formula ( \.{\\mathbin}, etc.~)}
+@d limit_switch=51 {diddle limit conventions ( \.{\\displaylimits}, etc.~)}
+@d above=52 {generalized fraction ( \.{\\above}, \.{\\atop}, etc.~)}
+@d math_style=53 {style specification ( \.{\\displaystyle}, etc.~)}
+@d math_choice=54 {choice specification ( \.{\\mathchoice} )}
+@d non_script=55 {conditional math glue ( \.{\\nonscript} )}
+@d vcenter=56 {vertically center a vbox ( \.{\\vcenter} )}
+@d case_shift=57 {force specific case ( \.{\\lowercase}, \.{\\uppercase}~)}
+@d message=58 {send to user ( \.{\\message}, \.{\\errmessage} )}
+@d extension=59 {extensions to \TeX\ ( \.{\\write}, \.{\\special}, etc.~)}
+@d in_stream=60 {files for reading ( \.{\\openin}, \.{\\closein} )}
+@d begin_group=61 {begin local grouping ( \.{\\begingroup} )}
+@d end_group=62 {end local grouping ( \.{\\endgroup} )}
+@d omit=63 {omit alignment template ( \.{\\omit} )}
+@d ex_space=64 {explicit space ( \.{\\\ } )}
+@d no_boundary=65 {suppress boundary ligatures ( \.{\\noboundary} )}
+@d radical=66 {square root and similar signs ( \.{\\radical} )}
+@d end_cs_name=67 {end control sequence ( \.{\\endcsname} )}
+@d char_ghost=end_cs_name+1
+ {\.{\\ghostleft}, \.{\\ghostright} character for kerning}
+@d assign_local_box=char_ghost+1
+ {box for guillemets \.{\\localleftbox} or \.{\\localrightbox}}
+@d min_internal=assign_local_box+1 {the smallest code that can follow \.{\\the}}
+@d char_given=min_internal {character code defined by \.{\\chardef}}
+@d math_given=char_given+1 {math code defined by \.{\\mathchardef}}
+@d omath_given=math_given+1 {math code defined by \.{\\omathchardef}}
+@d last_item=omath_given+1 {most recent item ( \.{\\lastpenalty},
+ \.{\\lastkern}, \.{\\lastskip} )}
+@d max_non_prefixed_command=last_item
+ {largest command code that can't be \.{\\global}}
+
+@ The next codes are special; they all relate to mode-independent
+assignment of values to \TeX's internal registers or tables.
+Codes that are |max_internal| or less represent internal quantities
+that might be expanded by `\.{\\the}'.
+
+There is no matching primitive to go with |assign_attr|, but even if
+there was no \.{\\attributedef}, a reserved number would still be
+needed because there is an implied correspondence between the
+|assign_xxx| commands and |xxx_val| expression values. That would
+break down otherwise.
+
+@d toks_register=max_non_prefixed_command+1
+ {token list register ( \.{\\toks} )}
+@d assign_toks=toks_register+1
+ {special token list ( \.{\\output}, \.{\\everypar}, etc.~)}
+@d assign_int=assign_toks+1
+ {user-defined integer ( \.{\\tolerance}, \.{\\day}, etc.~)}
+@d assign_attr=assign_int+1 { user-defined attributes }
+@d assign_dimen=assign_attr+1
+ {user-defined length ( \.{\\hsize}, etc.~)}
+@d assign_glue=assign_dimen+1
+ {user-defined glue ( \.{\\baselineskip}, etc.~)}
+@d assign_mu_glue=assign_glue+1
+ {user-defined muglue ( \.{\\thinmuskip}, etc.~)}
+@d assign_font_dimen=assign_mu_glue+1
+ {user-defined font dimension ( \.{\\fontdimen} )}
+@d assign_font_int=assign_font_dimen+1
+ {user-defined font integer ( \.{\\hyphenchar}, \.{\\skewchar} )}
+@d set_aux=assign_font_int+1
+ {specify state info ( \.{\\spacefactor}, \.{\\prevdepth} )}
+@d set_prev_graf=set_aux+1
+ {specify state info ( \.{\\prevgraf} )}
+@d set_page_dimen=set_prev_graf+1
+ {specify state info ( \.{\\pagegoal}, etc.~)}
+@d set_page_int=set_page_dimen+1
+ {specify state info ( \.{\\deadcycles},
+ \.{\\insertpenalties} )}
+@d set_box_dimen=set_page_int+1
+ {change dimension of box ( \.{\\wd}, \.{\\ht}, \.{\\dp} )}
+@d set_shape=set_box_dimen+1
+ {specify fancy paragraph shape ( \.{\\parshape} )}
+@d def_code=set_shape+1
+ {define a character code ( \.{\\catcode}, etc.~)}
+@d extdef_code=def_code+1
+ {define an extended character code ( \.{\\omathcode}, etc.~)}
+@d def_family=extdef_code+1
+ {declare math fonts ( \.{\\textfont}, etc.~)}
+@d set_font=def_family+1
+ {set current font ( font identifiers )}
+@d def_font=set_font+1
+ {define a font file ( \.{\\font} )}
+@d register=def_font+1
+ {internal register ( \.{\\count}, \.{\\dimen}, etc.~)}
+@d assign_box_dir=register+1 {(\.{\\boxdir})}
+@d assign_dir=register+2 {(\.{\\pagedir}, \.{\\textdir})}
+@d max_internal=assign_dir
+ {the largest code that can follow \.{\\the}}
+@d advance=max_internal+1
+ {advance a register or parameter ( \.{\\advance} )}
+@d multiply=advance+1
+ {multiply a register or parameter ( \.{\\multiply} )}
+@d divide=multiply+1
+ {divide a register or parameter ( \.{\\divide} )}
+@d prefix=divide+1
+ {qualify a definition ( \.{\\global}, \.{\\long}, \.{\\outer} )}
+@d let=prefix+1
+ {assign a command code ( \.{\\let}, \.{\\futurelet} )}
+@d shorthand_def=let+1
+ {code definition ( \.{\\chardef}, \.{\\countdef}, etc.~)}
+@d read_to_cs=shorthand_def+1
+ {read into a control sequence ( \.{\\read} )}
+@d def=read_to_cs+1
+ {macro definition ( \.{\\def}, \.{\\gdef}, \.{\\xdef}, \.{\\edef} )}
+@d set_box=def+1
+ {set a box ( \.{\\setbox} )}
+@d hyph_data=set_box+1
+ {hyphenation data ( \.{\\hyphenation}, \.{\\patterns} )}
+@d set_interaction=hyph_data+1
+ {define level of interaction ( \.{\\batchmode}, etc.~)}
+@d letterspace_font=set_interaction+1
+ {letterspace a font ( \.{\\letterspacefont} )}
+@d set_ocp=letterspace_font+1
+ {Place a translation process in the stream}
+@d def_ocp=set_ocp+1
+ {Define and load a translation process}
+@d set_ocp_list=def_ocp+1
+ {Place a list of OCPs in the stream}
+@d def_ocp_list=set_ocp_list+1
+ {Define a list of OCPs}
+@d clear_ocp_lists=def_ocp_list+1
+ {Remove all active OCP lists}
+@d push_ocp_list=clear_ocp_lists+1
+ {Add to the sequence of active OCP lists}
+@d pop_ocp_list=push_ocp_list+1
+ {Remove from the sequence of active OCP lists}
+@d ocp_list_op=pop_ocp_list+1
+ {Operations for building a list of OCPs}
+@d ocp_trace_level=ocp_list_op+1
+ {Tracing of active OCPs, either 0 or 1}
+@d max_command=ocp_trace_level
+ {the largest command code seen at |big_switch|}
+
+@ The remaining command codes are extra special, since they cannot get through
+\TeX's scanner to the main control routine. They have been given values higher
+than |max_command| so that their special nature is easily discernible.
+The ``expandable'' commands come first.
+
+@d undefined_cs=max_command+1 {initial state of most |eq_type| fields}
+@d expand_after=max_command+2 {special expansion ( \.{\\expandafter} )}
+@d no_expand=max_command+3 {special nonexpansion ( \.{\\noexpand} )}
+@d input=max_command+4 {input a source file ( \.{\\input}, \.{\\endinput} )}
+ {( or \.{\\scantokens} or \.{\\scantextokens} )}
+@d if_test=max_command+5 {conditional text ( \.{\\if}, \.{\\ifcase}, etc.~)}
+@d fi_or_else=max_command+6 {delimiters for conditionals ( \.{\\else}, etc.~)}
+@d cs_name=max_command+7 {make a control sequence from tokens ( \.{\\csname} )}
+@d convert=max_command+8 {convert to text ( \.{\\number}, \.{\\string}, etc.~)}
+@d the=max_command+9 {expand an internal quantity ( \.{\\the} )}
+ {( or \.{\\unexpanded}, \.{\\detokenize} )}
+@d top_bot_mark=max_command+10 {inserted mark ( \.{\\topmark}, etc.~)}
+@d call=max_command+11 {non-long, non-outer control sequence}
+@d long_call=max_command+12 {long, non-outer control sequence}
+@d outer_call=max_command+13 {non-long, outer control sequence}
+@d long_outer_call=max_command+14 {long, outer control sequence}
+@d end_template=max_command+15 {end of an alignment template}
+@d dont_expand=max_command+16 {the following token was marked by \.{\\noexpand}}
+@d glue_ref=max_command+17 {the equivalent points to a glue specification}
+@d shape_ref=max_command+18 {the equivalent points to a parshape specification}
+@d box_ref=max_command+19 {the equivalent points to a box node, or is |null|}
+@d data=max_command+20 {the equivalent is simply a halfword number}
+
+@* \[16] The semantic nest.
+\TeX\ is typically in the midst of building many lists at once. For example,
+when a math formula is being processed, \TeX\ is in math mode and
+working on an mlist; this formula has temporarily interrupted \TeX\ from
+being in horizontal mode and building the hlist of a paragraph; and this
+paragraph has temporarily interrupted \TeX\ from being in vertical mode
+and building the vlist for the next page of a document. Similarly, when a
+\.{\\vbox} occurs inside of an \.{\\hbox}, \TeX\ is temporarily
+interrupted from working in restricted horizontal mode, and it enters
+internal vertical mode. The ``semantic nest'' is a stack that
+keeps track of what lists and modes are currently suspended.
+
+At each level of processing we are in one of six modes:
+
+\yskip\hang|vmode| stands for vertical mode (the page builder);
+
+\hang|hmode| stands for horizontal mode (the paragraph builder);
+
+\hang|mmode| stands for displayed formula mode;
+
+\hang|-vmode| stands for internal vertical mode (e.g., in a \.{\\vbox});
+
+\hang|-hmode| stands for restricted horizontal mode (e.g., in an \.{\\hbox});
+
+\hang|-mmode| stands for math formula mode (not displayed).
+
+\yskip\noindent The mode is temporarily set to zero while processing \.{\\write}
+texts in the |ship_out| routine.
+
+Numeric values are assigned to |vmode|, |hmode|, and |mmode| so that
+\TeX's ``big semantic switch'' can select the appropriate thing to
+do by computing the value |abs(mode)+cur_cmd|, where |mode| is the current
+mode and |cur_cmd| is the current command code.
+
+@d vmode=1 {vertical mode}
+@d hmode=vmode+max_command+1 {horizontal mode}
+@d mmode=hmode+max_command+1 {math mode}
+
+@p procedure print_mode(@!m:integer); {prints the mode represented by |m|}
+begin if m>0 then
+ case m div (max_command+1) of
+ 0:print("vertical");
+ 1:print("horizontal");
+ 2:print("display math");
+ end
+else if m=0 then print("no")
+else case (-m) div (max_command+1) of
+ 0:print("internal vertical");
+ 1:print("restricted horizontal");
+ 2:print("math");
+ end;
+print(" mode");
+end;
+function get_mode_id:integer; {returns the mode represented by |m|}
+var m:integer ;
+begin
+ m := mode;
+ if m>0 then
+ case m div (max_command+1) of
+ 0:get_mode_id := "v";
+ 1:get_mode_id := "h";
+ 2:get_mode_id := "m";
+ othercases get_mode_id := "";
+ end
+else if m=0 then get_mode_id := "n"
+else case (-m) div (max_command+1) of
+ 0:get_mode_id := "V";
+ 1:get_mode_id := "H";
+ 2:get_mode_id := "M";
+ othercases get_mode_id := "";
+ end;
+end;
+
+@ The state of affairs at any semantic level can be represented by
+five values:
+
+\yskip\hang|mode| is the number representing the semantic mode, as
+just explained.
+
+\yskip\hang|head| is a |pointer| to a list head for the list being built;
+|link(head)| therefore points to the first element of the list, or
+to |null| if the list is empty.
+
+\yskip\hang|tail| is a |pointer| to the final node of the list being
+built; thus, |tail=head| if and only if the list is empty.
+
+\yskip\hang|prev_graf| is the number of lines of the current paragraph that
+have already been put into the present vertical list.
+
+\yskip\hang|aux| is an auxiliary |memory_word| that gives further information
+that is needed to characterize the situation.
+
+\yskip\noindent
+In vertical mode, |aux| is also known as |prev_depth|; it is the scaled
+value representing the depth of the previous box, for use in baseline
+calculations, or it is |<=-1000|pt if the next box on the vertical list is to
+be exempt from baseline calculations. In horizontal mode, |aux| is also
+known as |space_factor|; it holds the current space factor used in
+spacing calculations. In math mode, |aux| is also known as |incompleat_noad|;
+if not |null|, it points to a record that represents the numerator of a
+generalized fraction for which the denominator is currently being formed
+in the current list.
+
+There is also a sixth quantity, |mode_line|, which correlates
+the semantic nest with the user's input; |mode_line| contains the source
+line number at which the current level of nesting was entered. The negative
+of this line number is the |mode_line| at the level of the
+user's output routine.
+
+A seventh quantity, |eTeX_aux|, is used by the extended features \eTeX.
+In math mode it is known as |delim_ptr| and points to the most
+recent |left_noad| or |middle_noad| of a |math_left_group|.
+
+In horizontal mode, the |prev_graf| field is used for initial language data.
+
+The semantic nest is an array called |nest| that holds the |mode|, |head|,
+|tail|, |prev_graf|, |aux|, and |mode_line| values for all semantic levels
+below the currently active one. Information about the currently active
+level is kept in the global quantities |mode|, |head|, |tail|, |prev_graf|,
+|aux|, and |mode_line|, which live in a \PASCAL\ record that is ready to
+be pushed onto |nest| if necessary.
+
+@d ignore_depth==-65536000 {|prev_depth| value that is ignored}
+
+@<Types...@>=
+@!list_state_record=record@!mode_field:-mmode..mmode;@+
+ @!head_field,@!tail_field: pointer;
+ @!eTeX_aux_field: pointer;
+ @!pg_field,@!ml_field: integer;@+
+ @!aux_field: memory_word;
+ @!dirs_field: halfword;
+ @!math_field: integer;
+ @!local_par_field: pointer;
+ @!local_par_bool_field: boolean;
+ end;
+
+@ @d mode==cur_list.mode_field {current mode}
+@d head==cur_list.head_field {header node of current list}
+@d tail==cur_list.tail_field {final node on current list}
+@d eTeX_aux==cur_list.eTeX_aux_field {auxiliary data for \eTeX}
+@d delim_ptr==eTeX_aux {most recent left or right noad of a math left group}
+@d prev_graf==cur_list.pg_field {number of paragraph lines accumulated}
+@d aux==cur_list.aux_field {auxiliary data about the current list}
+@d prev_depth==aux.sc {the name of |aux| in vertical mode}
+@d space_factor==aux.hh.lh {part of |aux| in horizontal mode}
+@d incompleat_noad==aux.int {the name of |aux| in math mode}
+@d mode_line==cur_list.ml_field {source file line number at beginning of list}
+@d dir_save==cur_list.dirs_field {dir stack when a paragraph is interrupted}
+@d dir_math_save==cur_list.math_field
+ {should begin/end dir nodes be placed around mathematics?}
+@d local_par==cur_list.local_par_field
+ {pointer to whatsit for local stuff}
+@d local_par_bool==cur_list.local_par_bool_field
+ {has local stuff been changed in this group?}
+
+@<Glob...@>=
+@!nest:array[0..nest_size] of list_state_record;
+@!nest_ptr:0..nest_size; {first unused location of |nest|}
+@!max_nest_stack:0..nest_size; {maximum of |nest_ptr| when pushing}
+@!cur_list:list_state_record; {the ``top'' semantic state}
+@!shown_mode:-mmode..mmode; {most recent mode shown by \.{\\tracingcommands}}
+@!save_tail: pointer; {save |tail| so we can examine whether we have an auto
+ kern before a glue}
+
+@ Here is a common way to make the current list grow:
+
+@p
+procedure tail_append(p:pointer);
+begin
+vlink(tail):=p; tail:=vlink(tail);
+end;
+@#
+procedure new_tail_append(p:pointer);
+begin
+couple_nodes(tail,p); tail:=vlink(tail);
+end;
+@#
+function pop_tail:pointer;
+label exit;
+var n,r:pointer;
+begin
+ if tail<>head then begin
+ r:=tail;
+ if vlink(alink(tail))=tail then
+ n:=alink(tail)
+ else begin
+ n:=head;
+ while vlink(n)<>tail do n:=vlink(n);
+ end;
+ flush_node(tail);
+ tail:=n;
+ vlink(n):=null;
+ pop_tail:=r;
+ end
+ else
+ pop_tail:=null;
+exit:end;
+
+
+@ We will see later that the vertical list at the bottom semantic level is split
+into two parts; the ``current page'' runs from |page_head| to |page_tail|,
+and the ``contribution list'' runs from |contrib_head| to |tail| of
+semantic level zero. The idea is that contributions are first formed in
+vertical mode, then ``contributed'' to the current page (during which time
+the page-breaking decisions are made). For now, we don't need to know
+any more details about the page-building process.
+
+@<Set init...@>=
+nest_ptr:=0; max_nest_stack:=0;
+mode:=vmode; head:=contrib_head; tail:=contrib_head;
+eTeX_aux:=null;
+prev_depth:=ignore_depth; mode_line:=0;
+prev_graf:=0; shown_mode:=0;
+dir_save:=null; dir_math_save:=false;
+local_par:=null; local_par_bool:=false;
+@<Start a new current page@>;
+
+@ @p @<LOCAL: Declare |make_local_par_node|@>;
+
+@ @p @<DIR: Declare |new_dir|@>;
+
+@ When \TeX's work on one level is interrupted, the state is saved by
+calling |push_nest|. This routine changes |head| and |tail| so that
+a new (empty) list is begun; it does not change |mode| or |aux|.
+
+@p procedure push_nest; {enter a new semantic level, save the old}
+begin if nest_ptr>max_nest_stack then
+ begin max_nest_stack:=nest_ptr;
+ if nest_ptr=nest_size then overflow("semantic nest size",nest_size);
+@:TeX capacity exceeded semantic nest size}{\quad semantic nest size@>
+ end;
+nest[nest_ptr]:=cur_list; {stack the record}
+incr(nest_ptr); head:=new_node(temp_node,0); tail:=head; prev_graf:=0; mode_line:=line;
+dir_save:=null; dir_math_save:=false;
+local_par:=make_local_par_node; local_par_bool:=false;
+eTeX_aux:=null;
+end;
+
+@ Conversely, when \TeX\ is finished on the current level, the former
+state is restored by calling |pop_nest|. This routine will never be
+called at the lowest semantic level, nor will it be called unless |head|
+is a node that should be returned to free memory.
+
+@p procedure pop_nest; {leave a semantic level, re-enter the old}
+begin
+if local_par<>null then begin
+ if local_par_bool then begin end {|tail_append(local_par)|}
+ else flush_node(local_par);
+ end;
+flush_node(head); decr(nest_ptr); cur_list:=nest[nest_ptr];
+end;
+
+@ Here is a procedure that displays what \TeX\ is working on, at all levels.
+
+@p procedure@?print_totals; forward;@t\2@>
+procedure show_activities;
+var p:0..nest_size; {index into |nest|}
+@!m:-mmode..mmode; {mode}
+@!a:memory_word; {auxiliary}
+@!q,@!r:pointer; {for showing the current page}
+@!t:integer; {ditto}
+begin nest[nest_ptr]:=cur_list; {put the top level into the array}
+print_nl(""); print_ln;
+for p:=nest_ptr downto 0 do
+ begin m:=nest[p].mode_field; a:=nest[p].aux_field;
+ print_nl("### "); print_mode(m);
+ print(" entered at line "); print_int(abs(nest[p].ml_field));
+ if m=hmode then if nest[p].pg_field <> @'40600000 then
+ begin print(" (language"); print_int(nest[p].pg_field mod @'200000);
+ print(":hyphenmin"); print_int(nest[p].pg_field div @'20000000);
+ print_char(","); print_int((nest[p].pg_field div @'200000) mod @'100);
+ print_char(")");
+ end;
+ if nest[p].ml_field<0 then print(" (\output routine)");
+ if p=0 then
+ begin @<Show the status of the current page@>;
+ if vlink(contrib_head)<>null then
+ print_nl("### recent contributions:");
+ end;
+ show_box(vlink(nest[p].head_field));
+ @<Show the auxiliary field, |a|@>;
+ end;
+end;
+
+@ @<Show the auxiliary...@>=
+case abs(m) div (max_command+1) of
+0: begin print_nl("prevdepth ");
+ if a.sc<=ignore_depth then print("ignored")
+ else print_scaled(a.sc);
+ if nest[p].pg_field<>0 then
+ begin print(", prevgraf ");
+ print_int(nest[p].pg_field); print(" line");
+ if nest[p].pg_field<>1 then print_char("s");
+ end;
+ end;
+1: begin print_nl("spacefactor "); print_int(a.hh.lh);
+ if m>0 then@+ if a.hh.rh>0 then
+ begin print(", current language "); print_int(a.hh.rh);@+
+ end;
+ end;
+2: if a.int<>null then
+ begin print("this will be denominator of:"); show_box(a.int);@+
+ end;
+end {there are no other cases}
+
+@* \[17] The table of equivalents.
+Now that we have studied the data structures for \TeX's semantic routines,
+we ought to consider the data structures used by its syntactic routines. In
+other words, our next concern will be
+the tables that \TeX\ looks at when it is scanning
+what the user has written.
+
+The biggest and most important such table is called |eqtb|. It holds the
+current ``equivalents'' of things; i.e., it explains what things mean
+or what their current values are, for all quantities that are subject to
+the nesting structure provided by \TeX's grouping mechanism. There are six
+parts to |eqtb|:
+
+\yskip\hangg 1) |eqtb[active_base..(hash_base-1)]| holds the current
+equivalents of single-character control sequences.
+
+\yskip\hangg 2) |eqtb[hash_base..(glue_base-1)]| holds the current
+equivalents of multiletter control sequences.
+
+\yskip\hangg 3) |eqtb[glue_base..(local_base-1)]| holds the current
+equivalents of glue parameters like the current baselineskip.
+
+\yskip\hangg 4) |eqtb[local_base..(int_base-1)]| holds the current
+equivalents of local halfword quantities like the current box registers,
+the current ``catcodes,'' the current font, and a pointer to the current
+paragraph shape.
+
+\yskip\hangg 5) |eqtb[int_base..(dimen_base-1)]| holds the current
+equivalents of fullword integer parameters like the current hyphenation
+penalty.
+
+\yskip\hangg 6) |eqtb[dimen_base..eqtb_size]| holds the current equivalents
+of fullword dimension parameters like the current hsize or amount of
+hanging indentation.
+
+\yskip\noindent Note that, for example, the current amount of
+baselineskip glue is determined by the setting of a particular location
+in region~3 of |eqtb|, while the current meaning of the control sequence
+`\.{\\baselineskip}' (which might have been changed by \.{\\def} or
+\.{\\let}) appears in region~2.
+
+@ Each entry in |eqtb| is a |memory_word|. Most of these words are of type
+|two_halves|, and subdivided into three fields:
+
+\yskip\hangg 1) The |eq_level| (a quarterword) is the level of grouping at
+which this equivalent was defined. If the level is |level_zero|, the
+equivalent has never been defined; |level_one| refers to the outer level
+(outside of all groups), and this level is also used for global
+definitions that never go away. Higher levels are for equivalents that
+will disappear at the end of their group. @^global definitions@>
+
+\yskip\hangg 2) The |eq_type| (another quarterword) specifies what kind of
+entry this is. There are many types, since each \TeX\ primitive like
+\.{\\hbox}, \.{\\def}, etc., has its own special code. The list of
+command codes above includes all possible settings of the |eq_type| field.
+
+\yskip\hangg 3) The |equiv| (a halfword) is the current equivalent value.
+This may be a font number, a pointer into |mem|, or a variety of other
+things.
+
+@d eq_level_field(#)==#.hh.b1
+@d eq_type_field(#)==#.hh.b0
+@d equiv_field(#)==#.hh.rh
+@d eq_level(#)==eq_level_field(eqtb[#]) {level of definition}
+@d eq_type(#)==eq_type_field(eqtb[#]) {command code for equivalent}
+@d equiv(#)==equiv_field(eqtb[#]) {equivalent value}
+@d level_zero=min_quarterword {level for undefined quantities}
+@d level_one=level_zero+1 {outermost level for defined quantities}
+
+@ Many locations in |eqtb| have symbolic names. The purpose of the next
+paragraphs is to define these names, and to set up the initial values of the
+equivalents.
+
+In the first region we have |number_active_chars| equivalents for ``active
+characters'' that act as control sequences.
+
+Then comes region~2, which corresponds to the hash table that we will
+define later. The maximum address in this region is used for a dummy
+control sequence that is perpetually undefined. There also are several
+locations for control sequences that are perpetually defined
+(since they are used in error recovery).
+
+@d active_base=1 {beginning of region 1, for active character equivalents}
+@d null_cs=active_base+number_active_chars {equivalent of \.{\\csname\\endcsname}}
+@d hash_base=null_cs+1 {beginning of region 2, for the hash table}
+@d frozen_control_sequence=hash_base+hash_size {for error recovery}
+@d frozen_protection=frozen_control_sequence {inaccessible but definable}
+@d frozen_cr=frozen_control_sequence+1 {permanent `\.{\\cr}'}
+@d frozen_end_group=frozen_control_sequence+2 {permanent `\.{\\endgroup}'}
+@d frozen_right=frozen_control_sequence+3 {permanent `\.{\\right}'}
+@d frozen_fi=frozen_control_sequence+4 {permanent `\.{\\fi}'}
+@d frozen_end_template=frozen_control_sequence+5 {permanent `\.{\\endtemplate}'}
+@d frozen_endv=frozen_control_sequence+6 {second permanent `\.{\\endtemplate}'}
+@d frozen_relax=frozen_control_sequence+7 {permanent `\.{\\relax}'}
+@d end_write=frozen_control_sequence+8 {permanent `\.{\\endwrite}'}
+@d frozen_dont_expand=frozen_control_sequence+9
+ {permanent `\.{\\notexpanded:}'}
+@d frozen_primitive=frozen_control_sequence+11
+ {permanent `\.{\\pdfprimitive}'}
+@d frozen_null_font=frozen_control_sequence+12
+ {permanent `\.{\\nullfont}'}
+@d font_id_base=frozen_null_font-font_base
+ {begins table of |number_fonts| permanent font identifiers}
+@d frozen_null_ocp=frozen_null_font+number_fonts
+ {permanent `\.{\\nullocp}'}
+@d ocp_id_base=frozen_null_ocp-ocp_base
+ {begins table of |number_ocps| permanent ocp identifiers}
+@d frozen_null_ocp_list=frozen_null_ocp+number_ocps
+ {permanent `\.{\\nullocplist}'}
+@d ocp_list_id_base=frozen_null_ocp_list-ocp_list_base
+ {begins table of |number_ocp_lists| permanent ocp list identifiers}
+@d undefined_control_sequence=frozen_null_ocp_list+number_ocp_lists
+@d glue_base=undefined_control_sequence+1 {beginning of region 3}
+
+@<Initialize table entries...@>=
+eq_type(undefined_control_sequence):=undefined_cs;
+equiv(undefined_control_sequence):=null;
+eq_level(undefined_control_sequence):=level_zero;
+for k:=active_base to undefined_control_sequence-1 do
+ eqtb[k]:=eqtb[undefined_control_sequence];
+
+@ Here is a routine that displays the current meaning of an |eqtb| entry
+in region 1 or~2. (Similar routines for the other regions will appear
+below.)
+
+@<Show equivalent |n|, in region 1 or 2@>=
+begin sprint_cs(n); print_char("="); print_cmd_chr(eq_type(n),equiv(n));
+if eq_type(n)>=call then
+ begin print_char(":"); show_token_list(link(equiv(n)),null,32);
+ end;
+end
+
+@ Region 3 of |eqtb| contains the |number_regs| \.{\\skip} registers, as well as the
+glue parameters defined here. It is important that the ``muskip''
+parameters have larger numbers than the others.
+
+@d line_skip_code=0 {interline glue if |baseline_skip| is infeasible}
+@d baseline_skip_code=1 {desired glue between baselines}
+@d par_skip_code=2 {extra glue just above a paragraph}
+@d above_display_skip_code=3 {extra glue just above displayed math}
+@d below_display_skip_code=4 {extra glue just below displayed math}
+@d above_display_short_skip_code=5
+ {glue above displayed math following short lines}
+@d below_display_short_skip_code=6
+ {glue below displayed math following short lines}
+@d left_skip_code=7 {glue at left of justified lines}
+@d right_skip_code=8 {glue at right of justified lines}
+@d top_skip_code=9 {glue at top of main pages}
+@d split_top_skip_code=10 {glue at top of split pages}
+@d tab_skip_code=11 {glue between aligned entries}
+@d space_skip_code=12 {glue between words (if not |zero_glue|)}
+@d xspace_skip_code=13 {glue after sentences (if not |zero_glue|)}
+@d par_fill_skip_code=14 {glue on last line of paragraph}
+@d thin_mu_skip_code=15 {thin space in math formula}
+@d med_mu_skip_code=16 {medium space in math formula}
+@d thick_mu_skip_code=17 {thick space in math formula}
+@d glue_pars=18 {total number of glue parameters}
+@d skip_base=glue_base+glue_pars {table of |number_regs| ``skip'' registers}
+@d mu_skip_base=skip_base+number_regs {table of |number_regs| ``muskip'' registers}
+@d local_base=mu_skip_base+number_regs {beginning of region 4}
+@#
+@d skip(#)==equiv(skip_base+#) {|mem| location of glue specification}
+@d mu_skip(#)==equiv(mu_skip_base+#) {|mem| location of math glue spec}
+@d glue_par(#)==equiv(glue_base+#) {|mem| location of glue specification}
+@d line_skip==glue_par(line_skip_code)
+@d baseline_skip==glue_par(baseline_skip_code)
+@d par_skip==glue_par(par_skip_code)
+@d above_display_skip==glue_par(above_display_skip_code)
+@d below_display_skip==glue_par(below_display_skip_code)
+@d above_display_short_skip==glue_par(above_display_short_skip_code)
+@d below_display_short_skip==glue_par(below_display_short_skip_code)
+@d left_skip==glue_par(left_skip_code)
+@d right_skip==glue_par(right_skip_code)
+@d top_skip==glue_par(top_skip_code)
+@d split_top_skip==glue_par(split_top_skip_code)
+@d tab_skip==glue_par(tab_skip_code)
+@d space_skip==glue_par(space_skip_code)
+@d xspace_skip==glue_par(xspace_skip_code)
+@d par_fill_skip==glue_par(par_fill_skip_code)
+@d thin_mu_skip==glue_par(thin_mu_skip_code)
+@d med_mu_skip==glue_par(med_mu_skip_code)
+@d thick_mu_skip==glue_par(thick_mu_skip_code)
+
+@<Current |mem| equivalent of glue parameter number |n|@>=glue_par(n)
+
+@ Sometimes we need to convert \TeX's internal code numbers into symbolic
+form. The |print_skip_param| routine gives the symbolic name of a glue
+parameter.
+
+@<Declare the procedure called |print_skip_param|@>=
+procedure print_skip_param(@!n:integer);
+begin case n of
+line_skip_code: print_esc("lineskip");
+baseline_skip_code: print_esc("baselineskip");
+par_skip_code: print_esc("parskip");
+above_display_skip_code: print_esc("abovedisplayskip");
+below_display_skip_code: print_esc("belowdisplayskip");
+above_display_short_skip_code: print_esc("abovedisplayshortskip");
+below_display_short_skip_code: print_esc("belowdisplayshortskip");
+left_skip_code: print_esc("leftskip");
+right_skip_code: print_esc("rightskip");
+top_skip_code: print_esc("topskip");
+split_top_skip_code: print_esc("splittopskip");
+tab_skip_code: print_esc("tabskip");
+space_skip_code: print_esc("spaceskip");
+xspace_skip_code: print_esc("xspaceskip");
+par_fill_skip_code: print_esc("parfillskip");
+thin_mu_skip_code: print_esc("thinmuskip");
+med_mu_skip_code: print_esc("medmuskip");
+thick_mu_skip_code: print_esc("thickmuskip");
+othercases print("[unknown glue parameter!]")
+endcases;
+end;
+
+@ The symbolic names for glue parameters are put into \TeX's hash table
+by using the routine called |primitive|, defined below. Let us enter them
+now, so that we don't have to list all those parameter names anywhere else.
+
+@<Put each of \TeX's primitives into the hash table@>=
+primitive("lineskip",assign_glue,glue_base+line_skip_code);@/
+@!@:line_skip_}{\.{\\lineskip} primitive@>
+primitive("baselineskip",assign_glue,glue_base+baseline_skip_code);@/
+@!@:baseline_skip_}{\.{\\baselineskip} primitive@>
+primitive("parskip",assign_glue,glue_base+par_skip_code);@/
+@!@:par_skip_}{\.{\\parskip} primitive@>
+primitive("abovedisplayskip",assign_glue,glue_base+above_display_skip_code);@/
+@!@:above_display_skip_}{\.{\\abovedisplayskip} primitive@>
+primitive("belowdisplayskip",assign_glue,glue_base+below_display_skip_code);@/
+@!@:below_display_skip_}{\.{\\belowdisplayskip} primitive@>
+primitive("abovedisplayshortskip",
+ assign_glue,glue_base+above_display_short_skip_code);@/
+@!@:above_display_short_skip_}{\.{\\abovedisplayshortskip} primitive@>
+primitive("belowdisplayshortskip",
+ assign_glue,glue_base+below_display_short_skip_code);@/
+@!@:below_display_short_skip_}{\.{\\belowdisplayshortskip} primitive@>
+primitive("leftskip",assign_glue,glue_base+left_skip_code);@/
+@!@:left_skip_}{\.{\\leftskip} primitive@>
+primitive("rightskip",assign_glue,glue_base+right_skip_code);@/
+@!@:right_skip_}{\.{\\rightskip} primitive@>
+primitive("topskip",assign_glue,glue_base+top_skip_code);@/
+@!@:top_skip_}{\.{\\topskip} primitive@>
+primitive("splittopskip",assign_glue,glue_base+split_top_skip_code);@/
+@!@:split_top_skip_}{\.{\\splittopskip} primitive@>
+primitive("tabskip",assign_glue,glue_base+tab_skip_code);@/
+@!@:tab_skip_}{\.{\\tabskip} primitive@>
+primitive("spaceskip",assign_glue,glue_base+space_skip_code);@/
+@!@:space_skip_}{\.{\\spaceskip} primitive@>
+primitive("xspaceskip",assign_glue,glue_base+xspace_skip_code);@/
+@!@:xspace_skip_}{\.{\\xspaceskip} primitive@>
+primitive("parfillskip",assign_glue,glue_base+par_fill_skip_code);@/
+@!@:par_fill_skip_}{\.{\\parfillskip} primitive@>
+primitive("thinmuskip",assign_mu_glue,glue_base+thin_mu_skip_code);@/
+@!@:thin_mu_skip_}{\.{\\thinmuskip} primitive@>
+primitive("medmuskip",assign_mu_glue,glue_base+med_mu_skip_code);@/
+@!@:med_mu_skip_}{\.{\\medmuskip} primitive@>
+primitive("thickmuskip",assign_mu_glue,glue_base+thick_mu_skip_code);@/
+@!@:thick_mu_skip_}{\.{\\thickmuskip} primitive@>
+
+@ @<Cases of |print_cmd_chr| for symbolic printing of primitives@>=
+assign_glue,assign_mu_glue: if chr_code<skip_base then
+ print_skip_param(chr_code-glue_base)
+ else if chr_code<mu_skip_base then
+ begin print_esc("skip"); print_int(chr_code-skip_base);
+ end
+ else begin print_esc("muskip"); print_int(chr_code-mu_skip_base);
+ end;
+
+@ All glue parameters and registers are initially `\.{0pt plus0pt minus0pt}'.
+
+@<Initialize table entries...@>=
+equiv(glue_base):=zero_glue; eq_level(glue_base):=level_one;
+eq_type(glue_base):=glue_ref;
+for k:=glue_base+1 to local_base-1 do eqtb[k]:=eqtb[glue_base];
+glue_ref_count(zero_glue):=glue_ref_count(zero_glue)+local_base-glue_base;
+
+@ @<Show equivalent |n|, in region 3@>=
+if n<skip_base then
+ begin print_skip_param(n-glue_base); print_char("=");
+ if n<glue_base+thin_mu_skip_code then print_spec(equiv(n),"pt")
+ else print_spec(equiv(n),"mu");
+ end
+else if n<mu_skip_base then
+ begin print_esc("skip"); print_int(n-skip_base); print_char("=");
+ print_spec(equiv(n),"pt");
+ end
+else begin print_esc("muskip"); print_int(n-mu_skip_base); print_char("=");
+ print_spec(equiv(n),"mu");
+ end
+
+@ Region 4 of |eqtb| contains the local quantities defined here. The
+bulk of this region is taken up by five tables that are indexed by eight-bit
+characters; these tables are important to both the syntactic and semantic
+portions of \TeX. There are also a bunch of special things like font and
+token parameters, as well as the tables of \.{\\toks} and \.{\\box}
+registers.
+
+@d par_shape_loc=local_base {specifies paragraph shape}
+@d output_routine_loc=local_base+1 {points to token list for \.{\\output}}
+@d every_par_loc=local_base+2 {points to token list for \.{\\everypar}}
+@d every_math_loc=local_base+3 {points to token list for \.{\\everymath}}
+@d every_display_loc=local_base+4 {points to token list for \.{\\everydisplay}}
+@d every_hbox_loc=local_base+5 {points to token list for \.{\\everyhbox}}
+@d every_vbox_loc=local_base+6 {points to token list for \.{\\everyvbox}}
+@d every_job_loc=local_base+7 {points to token list for \.{\\everyjob}}
+@d every_cr_loc=local_base+8 {points to token list for \.{\\everycr}}
+@d err_help_loc=local_base+9 {points to token list for \.{\\errhelp}}
+@d tex_toks=local_base+10 {end of \TeX's token list parameters}
+@#
+@d pdftex_first_loc = tex_toks {base for \pdfTeX's token list parameters}
+@d pdf_pages_attr_loc = pdftex_first_loc + 0 {points to token list for \.{\\pdfpagesattr}}
+@d pdf_page_attr_loc = pdftex_first_loc + 1 {points to token list for \.{\\pdfpageattr}}
+@d pdf_page_resources_loc = pdftex_first_loc + 2 {points to token list for \.{\\pdfpageresources}}
+@d pdf_pk_mode_loc = pdftex_first_loc + 3 {points to token list for \.{\\pdfpkmode}}
+@d pdf_toks=pdftex_first_loc+4 {end of \pdfTeX's token list parameters}
+@#
+@d etex_toks_base=pdf_toks {base for \eTeX's token list parameters}
+@d every_eof_loc=etex_toks_base {points to token list for \.{\\everyeof}}
+@d etex_toks=etex_toks_base+1 {end of \eTeX's token list parameters}
+@#
+@d ocp_trace_level_base=etex_toks
+@d ocp_active_number_base=ocp_trace_level_base+1
+@d ocp_active_min_ptr_base = ocp_active_number_base+1
+@d ocp_active_max_ptr_base = ocp_active_min_ptr_base+1
+@d ocp_active_base = ocp_active_max_ptr_base+1
+@d toks_base = ocp_active_base+max_active_ocp_lists
+ {table of |number_regs| token list registers}
+@#
+@d etex_pen_base=toks_base+number_regs {start of table of \eTeX's penalties}
+@d inter_line_penalties_loc=etex_pen_base {additional penalties between lines}
+@d club_penalties_loc=etex_pen_base+1 {penalties for creating club lines}
+@d widow_penalties_loc=etex_pen_base+2 {penalties for creating widow lines}
+@d display_widow_penalties_loc=etex_pen_base+3 {ditto, just before a display}
+@d etex_pens=etex_pen_base+4 {end of table of \eTeX's penalties}
+@#
+@d local_left_box_base=etex_pens
+@d local_right_box_base=local_left_box_base+1
+@d box_base=local_right_box_base+1 {table of |number_regs| box registers}
+@d cur_font_loc=box_base+number_regs {internal font number outside math mode}
+@d math_font_base=cur_font_loc+1
+ {table of |number_math_fonts| math font numbers}
+@d cat_code_base=math_font_base+number_math_fonts
+ {table of |number_chars| command codes (the ``catcodes'')}
+@d lc_code_base=cat_code_base+1 {table of |number_chars| lowercase mappings}
+@d uc_code_base=lc_code_base+1 {table of |number_chars| uppercase mappings}
+@d sf_code_base=uc_code_base+1 {table of |number_chars| spacefactor mappings}
+@d math_code_base=sf_code_base+1 {table of |number_chars| math mode mappings}
+@d int_base=math_code_base+1 {beginning of region 5}
+@#
+@d par_shape_ptr==equiv(par_shape_loc)
+@d output_routine==equiv(output_routine_loc)
+@d every_par==equiv(every_par_loc)
+@d every_math==equiv(every_math_loc)
+@d every_display==equiv(every_display_loc)
+@d every_hbox==equiv(every_hbox_loc)
+@d every_vbox==equiv(every_vbox_loc)
+@d every_job==equiv(every_job_loc)
+@d every_cr==equiv(every_cr_loc)
+@d err_help==equiv(err_help_loc)
+@d pdf_pages_attr==equiv(pdf_pages_attr_loc)
+@d pdf_page_attr==equiv(pdf_page_attr_loc)
+@d pdf_page_resources==equiv(pdf_page_resources_loc)
+@d pdf_pk_mode==equiv(pdf_pk_mode_loc)
+@d toks(#)==equiv(toks_base+#)
+@d local_left_box==equiv(local_left_box_base)
+@d local_right_box==equiv(local_right_box_base)
+@d box(#)==equiv(box_base+#)
+@d cur_font==equiv(cur_font_loc)
+@d fam_fnt(#)==equiv(math_font_base+#)
+
+@<Put each...@>=
+primitive("output",assign_toks,output_routine_loc);
+@!@:output_}{\.{\\output} primitive@>
+primitive("everypar",assign_toks,every_par_loc);
+@!@:every_par_}{\.{\\everypar} primitive@>
+primitive("everymath",assign_toks,every_math_loc);
+@!@:every_math_}{\.{\\everymath} primitive@>
+primitive("everydisplay",assign_toks,every_display_loc);
+@!@:every_display_}{\.{\\everydisplay} primitive@>
+primitive("everyhbox",assign_toks,every_hbox_loc);
+@!@:every_hbox_}{\.{\\everyhbox} primitive@>
+primitive("everyvbox",assign_toks,every_vbox_loc);
+@!@:every_vbox_}{\.{\\everyvbox} primitive@>
+primitive("everyjob",assign_toks,every_job_loc);
+@!@:every_job_}{\.{\\everyjob} primitive@>
+primitive("everycr",assign_toks,every_cr_loc);
+@!@:every_cr_}{\.{\\everycr} primitive@>
+primitive("errhelp",assign_toks,err_help_loc);
+@!@:err_help_}{\.{\\errhelp} primitive@>
+primitive("pdfpagesattr",assign_toks,pdf_pages_attr_loc);
+@!@:pdf_pages_attr_}{\.{\\pdfpagesattr} primitive@>
+primitive("pdfpageattr",assign_toks,pdf_page_attr_loc);
+@!@:pdf_page_attr_}{\.{\\pdfpageattr} primitive@>
+primitive("pdfpageresources",assign_toks,pdf_page_resources_loc);
+@!@:pdf_page_resources_}{\.{\\pdfpageresources} primitive@>
+primitive("pdfpkmode",assign_toks,pdf_pk_mode_loc);
+@!@:pdf_pk_mode_}{\.{\\pdfpkmode} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+assign_toks: if chr_code>=toks_base then
+ begin print_esc("toks"); print_int(chr_code-toks_base);
+ end
+else case chr_code of
+ output_routine_loc: print_esc("output");
+ every_par_loc: print_esc("everypar");
+ every_math_loc: print_esc("everymath");
+ every_display_loc: print_esc("everydisplay");
+ every_hbox_loc: print_esc("everyhbox");
+ every_vbox_loc: print_esc("everyvbox");
+ every_job_loc: print_esc("everyjob");
+ every_cr_loc: print_esc("everycr");
+ @/@<Cases of |assign_toks| for |print_cmd_chr|@>@/
+ pdf_pages_attr_loc: print_esc("pdfpagesattr");
+ pdf_page_attr_loc: print_esc("pdfpageattr");
+ pdf_page_resources_loc: print_esc("pdfpageresources");
+ pdf_pk_mode_loc: print_esc("pdfpkmode");
+ othercases print_esc("errhelp")
+ endcases;
+
+@ We initialize most things to null or undefined values. An undefined font
+is represented by the internal code |font_base|.
+
+However, the character code tables are given initial values based on the
+conventional interpretation of ASCII code. These initial values should
+not be changed when \TeX\ is adapted for use with non-English languages;
+all changes to the initialization conventions should be made in format
+packages, not in \TeX\ itself, so that global interchange of formats is
+possible.
+
+@d null_font==font_base
+@d null_ocp==ocp_base
+@d null_ocp_list==ocp_list_base
+@d var_code==@"7000000 {math code meaning ``use the current family''}
+
+@<Initialize table entries...@>=
+par_shape_ptr:=null; eq_type(par_shape_loc):=shape_ref;
+eq_level(par_shape_loc):=level_one;@/
+for k:=etex_pen_base to etex_pens-1 do
+ eqtb[k]:=eqtb[par_shape_loc];
+for k:=output_routine_loc to toks_base+biggest_reg do
+ eqtb[k]:=eqtb[undefined_control_sequence];
+box(0):=null; eq_type(box_base):=box_ref; eq_level(box_base):=level_one;
+for k:=box_base+1 to box_base+biggest_reg do eqtb[k]:=eqtb[box_base];
+cur_font:=null_font; eq_type(cur_font_loc):=data;
+eq_level(cur_font_loc):=level_one;@/
+for k:=math_font_base to math_font_base+47 do eqtb[k]:=eqtb[cur_font_loc];
+equiv(cat_code_base):=0; eq_type(cat_code_base):=data;
+eq_level(cat_code_base):=level_one;@/
+eqtb[lc_code_base] :=eqtb[cat_code_base];
+eqtb[uc_code_base] :=eqtb[cat_code_base];
+eqtb[sf_code_base] :=eqtb[cat_code_base];
+eqtb[math_code_base]:=eqtb[cat_code_base];@/
+cat_code_table:=0;
+initex_cat_codes(0);
+for k:="0" to "9" do set_math_code(k,(hi(k+var_code)),level_one);@/
+for k:="A" to "Z" do begin
+ set_math_code(k,(hi(k+var_code+@"10000)),level_one);
+ set_math_code(k+32,(hi(k+32+var_code+@"10000)),level_one);@/
+ set_lc_code(k,k+32,level_one); set_lc_code(k+32,k+32,level_one);@/
+ set_uc_code(k,k,level_one); set_uc_code(k+32,k,level_one);@/
+ set_sf_code(k,999,level_one);
+ end;
+
+@ @<Set init...@>=
+static_int_base:=int_base;
+initialize_math_codes;
+initialize_text_codes;
+
+@ @<Show equivalent |n|, in region 4@>=
+if (n=par_shape_loc) or ((n>=etex_pen_base) and (n<etex_pens)) then
+ begin print_cmd_chr(set_shape,n); print_char("=");
+ if equiv(n)=null then print_char("0")
+ else if n>par_shape_loc then
+ begin print_int(penalty(equiv(n))); print_char(" ");
+ print_int(penalty(equiv(n)+1));
+ if penalty(equiv(n))>1 then print_esc("ETC.");
+ end
+ else print_int(vinfo(par_shape_ptr));
+ end
+else if n<toks_base then
+ {TH TODO make extra cases for ocps here! }
+ begin print_cmd_chr(assign_toks,n); print_char("=");
+ if equiv(n)<>null then show_token_list(link(equiv(n)),null,32);
+ end
+else if n<box_base then
+ begin print_esc("toks"); print_int(n-toks_base); print_char("=");
+ if equiv(n)<>null then show_token_list(link(equiv(n)),null,32);
+ end
+else if n<cur_font_loc then
+ begin print_esc("box"); print_int(n-box_base); print_char("=");
+ if equiv(n)=null then print("void")
+ else begin depth_threshold:=0; breadth_max:=1; show_node_list(equiv(n));
+ end;
+ end
+else if n<cat_code_base then @<Show the font identifier in |eqtb[n]|@>
+else @<Show the halfword code in |eqtb[n]|@>
+
+@ @<Show the font identifier in |eqtb[n]|@>=
+begin if n=cur_font_loc then print("current font")
+else if n<math_font_base+script_size then
+ begin print_esc("textfont"); print_int(n-math_font_base);
+ end
+else if n<math_font_base+script_script_size then
+ begin print_esc("scriptfont"); print_int(n-math_font_base-script_size);
+ end
+else begin print_esc("scriptscriptfont"); print_int(n-math_font_base-script_script_size);
+ end;
+print_char("=");@/
+print_esc(hash[font_id_base+equiv(n)].rh);
+ {that's |font_id_text(equiv(n))|}
+end
+
+@
+@d is_omath(#)== ((((#) mod @"1000000) div @"10000)>15) or
+ (((#) mod @"10000)>255)
+
+@<Show the halfword code in |eqtb[n]|@>=
+if n<math_code_base then
+ begin if n<lc_code_base then
+ begin print_esc("catcode"); print_int(n-cat_code_base);
+ end
+ else if n<uc_code_base then
+ begin print_esc("lccode"); print_int(n-lc_code_base);
+ end
+ else if n<sf_code_base then
+ begin print_esc("uccode"); print_int(n-uc_code_base);
+ end
+ else begin print_esc("sfcode"); print_int(n-sf_code_base);
+ end;
+ print_char("="); print_int(equiv(n));
+ end
+else begin
+ if is_omath(get_math_code(n-math_code_base)) then
+ print_esc("omathcode")
+ else
+ print_esc("mathcode");
+ print_int(n-math_code_base);
+ print_char("="); print_int(get_math_code(n-math_code_base));
+ end
+
+@ Region 5 of |eqtb| contains the integer parameters and registers defined
+here, as well as the |del_code| table. The latter table differs from the
+|cat_code..math_code| tables that precede it, since delimiter codes are
+fullword integers while the other kinds of codes occupy at most a
+halfword. This is what makes region~5 different from region~4. We will
+store the |eq_level| information in an auxiliary array of quarterwords
+that will be defined later.
+
+@d pretolerance_code=0 {badness tolerance before hyphenation}
+@d tolerance_code=1 {badness tolerance after hyphenation}
+@d line_penalty_code=2 {added to the badness of every line}
+@d hyphen_penalty_code=3 {penalty for break after discretionary hyphen}
+@d ex_hyphen_penalty_code=4 {penalty for break after explicit hyphen}
+@d club_penalty_code=5 {penalty for creating a club line}
+@d widow_penalty_code=6 {penalty for creating a widow line}
+@d display_widow_penalty_code=7 {ditto, just before a display}
+@d broken_penalty_code=8 {penalty for breaking a page at a broken line}
+@d bin_op_penalty_code=9 {penalty for breaking after a binary operation}
+@d rel_penalty_code=10 {penalty for breaking after a relation}
+@d pre_display_penalty_code=11
+ {penalty for breaking just before a displayed formula}
+@d post_display_penalty_code=12
+ {penalty for breaking just after a displayed formula}
+@d inter_line_penalty_code=13 {additional penalty between lines}
+@d double_hyphen_demerits_code=14 {demerits for double hyphen break}
+@d final_hyphen_demerits_code=15 {demerits for final hyphen break}
+@d adj_demerits_code=16 {demerits for adjacent incompatible lines}
+@d mag_code=17 {magnification ratio}
+@d delimiter_factor_code=18 {ratio for variable-size delimiters}
+@d looseness_code=19 {change in number of lines for a paragraph}
+@d time_code=20 {current time of day}
+@d day_code=21 {current day of the month}
+@d month_code=22 {current month of the year}
+@d year_code=23 {current year of our Lord}
+@d show_box_breadth_code=24 {nodes per level in |show_box|}
+@d show_box_depth_code=25 {maximum level in |show_box|}
+@d hbadness_code=26 {hboxes exceeding this badness will be shown by |hpack|}
+@d vbadness_code=27 {vboxes exceeding this badness will be shown by |vpack|}
+@d pausing_code=28 {pause after each line is read from a file}
+@d tracing_online_code=29 {show diagnostic output on terminal}
+@d tracing_macros_code=30 {show macros as they are being expanded}
+@d tracing_stats_code=31 {show memory usage if \TeX\ knows it}
+@d tracing_paragraphs_code=32 {show line-break calculations}
+@d tracing_pages_code=33 {show page-break calculations}
+@d tracing_output_code=34 {show boxes when they are shipped out}
+@d tracing_lost_chars_code=35 {show characters that aren't in the font}
+@d tracing_commands_code=36 {show command codes at |big_switch|}
+@d tracing_restores_code=37 {show equivalents when they are restored}
+@d uc_hyph_code=38 {hyphenate words beginning with a capital letter}
+@d output_penalty_code=39 {penalty found at current page break}
+@d max_dead_cycles_code=40 {bound on consecutive dead cycles of output}
+@d hang_after_code=41 {hanging indentation changes after this many lines}
+@d floating_penalty_code=42 {penalty for insertions heldover after a split}
+@d global_defs_code=43 {override \.{\\global} specifications}
+@d cur_fam_code=44 {current family}
+@d escape_char_code=45 {escape character for token output}
+@d default_hyphen_char_code=46 {value of \.{\\hyphenchar} when a font is loaded}
+@d default_skew_char_code=47 {value of \.{\\skewchar} when a font is loaded}
+@d end_line_char_code=48 {character placed at the right end of the buffer}
+@d new_line_char_code=49 {character that prints as |print_ln|}
+@d language_code=50 {current hyphenation table}
+@d left_hyphen_min_code=51 {minimum left hyphenation fragment size}
+@d right_hyphen_min_code=52 {minimum right hyphenation fragment size}
+@d holding_inserts_code=53 {do not remove insertion nodes from \.{\\box255}}
+@d error_context_lines_code=54 {maximum intermediate line pairs shown}
+@d local_inter_line_penalty_code=55 {local \.{\\interlinepenalty}}
+@d local_broken_penalty_code=56 {local \.{\\brokenpenalty}}
+@d no_local_whatsits_code=57 {counts local whatsits}
+@d no_local_dirs_code=58
+@d level_local_dir_code=59
+@d luastartup_id_code=60
+@d disable_lig_code=61
+@d disable_kern_code=62
+@d cat_code_table_code=63
+@d cur_lang_code=64 {current language id}
+@d ex_hyphen_char_code=65
+@d tex_int_pars=66 {total number of \.{\\TeX} + Aleph integer parameters}
+@#
+@d dir_base=int_base+tex_int_pars
+@d page_direction_code=0
+@d body_direction_code=1
+@d par_direction_code=2
+@d text_direction_code=3
+@d math_direction_code=4
+@d dir_pars=5
+@#
+@d pdftex_first_integer_code = dir_base+dir_pars {base for \pdfTeX's integer parameters}
+@d pdf_output_code = pdftex_first_integer_code + 0 {switch on PDF output if positive}
+@d pdf_compress_level_code = pdftex_first_integer_code + 1 {compress level of streams}
+@d pdf_decimal_digits_code = pdftex_first_integer_code + 2 {digits after the decimal point of numbers}
+@d pdf_move_chars_code = pdftex_first_integer_code + 3 {move chars 0..31 to higher area if possible}
+@d pdf_image_resolution_code = pdftex_first_integer_code + 4 {default image resolution}
+@d pdf_pk_resolution_code = pdftex_first_integer_code + 5 {default resolution of PK font}
+@d pdf_unique_resname_code = pdftex_first_integer_code + 6 {generate unique names for resouces}
+@d pdf_option_always_use_pdfpagebox_code = pdftex_first_integer_code + 7 {if the PDF inclusion should always use a specific PDF page box}
+@d pdf_option_pdf_inclusion_errorlevel_code = pdftex_first_integer_code + 8 {if the PDF inclusion should treat pdfs newer than |pdf_minor_version| as an error}
+@d pdf_minor_version_code = pdftex_first_integer_code + 9 {fractional part of the PDF version produced}
+@d pdf_force_pagebox_code = pdftex_first_integer_code + 10 {if the PDF inclusion should always use a specific PDF page box}
+@d pdf_pagebox_code = pdftex_first_integer_code + 11 {default pagebox to use for PDF inclusion}
+@d pdf_inclusion_errorlevel_code = pdftex_first_integer_code + 12 {if the PDF inclusion should treat pdfs newer than |pdf_minor_version| as an error}
+@d pdf_gamma_code = pdftex_first_integer_code + 13
+@d pdf_image_gamma_code = pdftex_first_integer_code + 14
+@d pdf_image_hicolor_code = pdftex_first_integer_code + 15
+@d pdf_image_apply_gamma_code = pdftex_first_integer_code + 16
+@d pdf_adjust_spacing_code = pdftex_first_integer_code + 17 {level of spacing adjusting}
+@d pdf_protrude_chars_code = pdftex_first_integer_code + 18 {protrude chars at left/right edge of paragraphs}
+@d pdf_tracing_fonts_code = pdftex_first_integer_code + 19 {level of font detail in log}
+@d pdf_objcompresslevel_code = pdftex_first_integer_code + 20 {activate object streams}
+@d pdf_gen_tounicode_code = pdftex_first_integer_code + 24 {generate ToUnicode for fonts?}
+@d pdf_draftmode_code = pdftex_first_integer_code + 25 {switch on draftmode if positive}
+@d pdf_replace_font_code = pdftex_first_integer_code + 26 {generate ToUnicode for fonts?}
+@d pdf_int_pars=pdftex_first_integer_code + 27 {total number of \pdfTeX's integer parameters}
+@#
+@d etex_int_base=pdf_int_pars {base for \eTeX's integer parameters}
+@d tracing_assigns_code=etex_int_base {show assignments}
+@d tracing_groups_code=etex_int_base+1 {show save/restore groups}
+@d tracing_ifs_code=etex_int_base+2 {show conditionals}
+@d tracing_scan_tokens_code=etex_int_base+3 {show pseudo file open and close}
+@d tracing_nesting_code=etex_int_base+4 {show incomplete groups and ifs within files}
+@d pre_display_direction_code=etex_int_base+5 {text direction preceding a display}
+@d last_line_fit_code=etex_int_base+6 {adjustment for last line of paragraph}
+@d saving_vdiscards_code=etex_int_base+7 {save items discarded from vlists}
+@d saving_hyph_codes_code=etex_int_base+8 {save hyphenation codes for languages}
+@d suppress_fontnotfound_error_code=etex_int_base+9 {surpress errors for missing fonts}
+@d etex_int_pars=etex_int_base+10 {total number of \eTeX's integer parameters}
+@#
+@d int_pars=etex_int_pars {total number of integer parameters}
+@d count_base=int_base+int_pars {|number_regs| user \.{\\count} registers}
+@d attribute_base=count_base+number_regs {|number_attrs| user \.{\\attribute} registers}
+@d del_code_base=attribute_base+number_attrs {|number_chars| delimiter code mappings}
+@d dimen_base=del_code_base+1 {beginning of region 6}
+@#
+@d count(#)==eqtb[count_base+#].int
+@d attribute(#)==eqtb[attribute_base+#].int
+@d int_par(#)==eqtb[int_base+#].int {an integer parameter}
+@d pretolerance==int_par(pretolerance_code)
+@d tolerance==int_par(tolerance_code)
+@d line_penalty==int_par(line_penalty_code)
+@d hyphen_penalty==int_par(hyphen_penalty_code)
+@d ex_hyphen_penalty==int_par(ex_hyphen_penalty_code)
+@d club_penalty==int_par(club_penalty_code)
+@d widow_penalty==int_par(widow_penalty_code)
+@d display_widow_penalty==int_par(display_widow_penalty_code)
+@d broken_penalty==int_par(broken_penalty_code)
+@d bin_op_penalty==int_par(bin_op_penalty_code)
+@d rel_penalty==int_par(rel_penalty_code)
+@d pre_display_penalty==int_par(pre_display_penalty_code)
+@d post_display_penalty==int_par(post_display_penalty_code)
+@d inter_line_penalty==int_par(inter_line_penalty_code)
+@d double_hyphen_demerits==int_par(double_hyphen_demerits_code)
+@d final_hyphen_demerits==int_par(final_hyphen_demerits_code)
+@d adj_demerits==int_par(adj_demerits_code)
+@d mag==int_par(mag_code)
+@d delimiter_factor==int_par(delimiter_factor_code)
+@d looseness==int_par(looseness_code)
+@d time==int_par(time_code)
+@d day==int_par(day_code)
+@d month==int_par(month_code)
+@d year==int_par(year_code)
+@d show_box_breadth==int_par(show_box_breadth_code)
+@d show_box_depth==int_par(show_box_depth_code)
+@d hbadness==int_par(hbadness_code)
+@d vbadness==int_par(vbadness_code)
+@d pausing==int_par(pausing_code)
+@d tracing_online==int_par(tracing_online_code)
+@d tracing_macros==int_par(tracing_macros_code)
+@d tracing_stats==int_par(tracing_stats_code)
+@d tracing_paragraphs==int_par(tracing_paragraphs_code)
+@d tracing_pages==int_par(tracing_pages_code)
+@d tracing_output==int_par(tracing_output_code)
+@d tracing_lost_chars==int_par(tracing_lost_chars_code)
+@d tracing_commands==int_par(tracing_commands_code)
+@d tracing_restores==int_par(tracing_restores_code)
+@d uc_hyph==int_par(uc_hyph_code)
+@d output_penalty==int_par(output_penalty_code)
+@d max_dead_cycles==int_par(max_dead_cycles_code)
+@d hang_after==int_par(hang_after_code)
+@d floating_penalty==int_par(floating_penalty_code)
+@d global_defs==int_par(global_defs_code)
+@d cur_fam==int_par(cur_fam_code)
+@d escape_char==int_par(escape_char_code)
+@d default_hyphen_char==int_par(default_hyphen_char_code)
+@d default_skew_char==int_par(default_skew_char_code)
+@d end_line_char==int_par(end_line_char_code)
+@d new_line_char==int_par(new_line_char_code)
+@d local_inter_line_penalty==int_par(local_inter_line_penalty_code)
+@d local_broken_penalty==int_par(local_broken_penalty_code)
+@d no_local_whatsits==int_par(no_local_whatsits_code)
+@d no_local_dirs==int_par(no_local_dirs_code)
+@d level_local_dir==int_par(level_local_dir_code)
+@d dir_par(#)==eqtb[dir_base+#].int {a direction parameter}
+@d page_direction==dir_par(page_direction_code)
+@d body_direction==dir_par(body_direction_code)
+@d par_direction==dir_par(par_direction_code)
+@d text_direction==dir_par(text_direction_code)
+@d math_direction==dir_par(math_direction_code)
+@d language==int_par(language_code)
+@d cur_lang==int_par(cur_lang_code)
+@d ex_hyphen_char==int_par(ex_hyphen_char_code)
+@d left_hyphen_min==int_par(left_hyphen_min_code)
+@d right_hyphen_min==int_par(right_hyphen_min_code)
+@d holding_inserts==int_par(holding_inserts_code)
+@d error_context_lines==int_par(error_context_lines_code)
+@d luastartup_id==int_par(luastartup_id_code)
+@d disable_lig==int_par(disable_lig_code)
+@d disable_kern==int_par(disable_kern_code)
+@d cat_code_table==int_par(cat_code_table_code)
+@#
+@d pdf_adjust_spacing == int_par(pdf_adjust_spacing_code)
+@d pdf_protrude_chars == int_par(pdf_protrude_chars_code)
+@d pdf_tracing_fonts == int_par(pdf_tracing_fonts_code)
+@d pdf_gen_tounicode == int_par(pdf_gen_tounicode_code)
+@d pdf_output == int_par(pdf_output_code)
+@d pdf_compress_level == int_par(pdf_compress_level_code)
+@d pdf_objcompresslevel == int_par(pdf_objcompresslevel_code)
+@d pdf_decimal_digits == int_par(pdf_decimal_digits_code)
+@d pdf_move_chars == int_par(pdf_move_chars_code)
+@d pdf_image_resolution == int_par(pdf_image_resolution_code)
+@d pdf_pk_resolution == int_par(pdf_pk_resolution_code)
+@d pdf_unique_resname == int_par(pdf_unique_resname_code)
+@d pdf_option_always_use_pdfpagebox == int_par(pdf_option_always_use_pdfpagebox_code)
+@d pdf_option_pdf_inclusion_errorlevel == int_par(pdf_option_pdf_inclusion_errorlevel_code)
+@d pdf_minor_version == int_par(pdf_minor_version_code)
+@d pdf_force_pagebox == int_par(pdf_force_pagebox_code)
+@d pdf_pagebox == int_par(pdf_pagebox_code)
+@d pdf_inclusion_errorlevel == int_par(pdf_inclusion_errorlevel_code)
+@d pdf_gamma == int_par(pdf_gamma_code)
+@d pdf_image_gamma == int_par(pdf_image_gamma_code)
+@d pdf_image_hicolor == int_par(pdf_image_hicolor_code)
+@d pdf_image_apply_gamma == int_par(pdf_image_apply_gamma_code)
+@d pdf_draftmode == int_par(pdf_draftmode_code)
+@d pdf_replace_font == int_par(pdf_replace_font_code)
+@#
+@d tracing_assigns==int_par(tracing_assigns_code)
+@d tracing_groups==int_par(tracing_groups_code)
+@d tracing_ifs==int_par(tracing_ifs_code)
+@d tracing_scan_tokens==int_par(tracing_scan_tokens_code)
+@d tracing_nesting==int_par(tracing_nesting_code)
+@d pre_display_direction==int_par(pre_display_direction_code)
+@d last_line_fit==int_par(last_line_fit_code)
+@d saving_vdiscards==int_par(saving_vdiscards_code)
+@d saving_hyph_codes==int_par(saving_hyph_codes_code)
+@d suppress_fontnotfound_error==int_par(suppress_fontnotfound_error_code)
+
+@<Assign the values |depth_threshold:=show_box_depth|...@>=
+depth_threshold:=show_box_depth;
+breadth_max:=show_box_breadth
+
+@ We can print the symbolic name of an integer parameter as follows.
+
+@p procedure print_param(@!n:integer);
+begin case n of
+pretolerance_code:print_esc("pretolerance");
+tolerance_code:print_esc("tolerance");
+line_penalty_code:print_esc("linepenalty");
+hyphen_penalty_code:print_esc("hyphenpenalty");
+ex_hyphen_penalty_code:print_esc("exhyphenpenalty");
+club_penalty_code:print_esc("clubpenalty");
+widow_penalty_code:print_esc("widowpenalty");
+display_widow_penalty_code:print_esc("displaywidowpenalty");
+broken_penalty_code:print_esc("brokenpenalty");
+bin_op_penalty_code:print_esc("binoppenalty");
+rel_penalty_code:print_esc("relpenalty");
+pre_display_penalty_code:print_esc("predisplaypenalty");
+post_display_penalty_code:print_esc("postdisplaypenalty");
+inter_line_penalty_code:print_esc("interlinepenalty");
+double_hyphen_demerits_code:print_esc("doublehyphendemerits");
+final_hyphen_demerits_code:print_esc("finalhyphendemerits");
+adj_demerits_code:print_esc("adjdemerits");
+mag_code:print_esc("mag");
+delimiter_factor_code:print_esc("delimiterfactor");
+looseness_code:print_esc("looseness");
+time_code:print_esc("time");
+day_code:print_esc("day");
+month_code:print_esc("month");
+year_code:print_esc("year");
+show_box_breadth_code:print_esc("showboxbreadth");
+show_box_depth_code:print_esc("showboxdepth");
+hbadness_code:print_esc("hbadness");
+vbadness_code:print_esc("vbadness");
+pausing_code:print_esc("pausing");
+tracing_online_code:print_esc("tracingonline");
+tracing_macros_code:print_esc("tracingmacros");
+tracing_stats_code:print_esc("tracingstats");
+tracing_paragraphs_code:print_esc("tracingparagraphs");
+tracing_pages_code:print_esc("tracingpages");
+tracing_output_code:print_esc("tracingoutput");
+tracing_lost_chars_code:print_esc("tracinglostchars");
+tracing_commands_code:print_esc("tracingcommands");
+tracing_restores_code:print_esc("tracingrestores");
+uc_hyph_code:print_esc("uchyph");
+output_penalty_code:print_esc("outputpenalty");
+max_dead_cycles_code:print_esc("maxdeadcycles");
+hang_after_code:print_esc("hangafter");
+floating_penalty_code:print_esc("floatingpenalty");
+global_defs_code:print_esc("globaldefs");
+cur_fam_code:print_esc("fam");
+escape_char_code:print_esc("escapechar");
+default_hyphen_char_code:print_esc("defaulthyphenchar");
+default_skew_char_code:print_esc("defaultskewchar");
+end_line_char_code:print_esc("endlinechar");
+new_line_char_code:print_esc("newlinechar");
+language_code:print_esc("language");
+cur_lang_code:print_esc("setlanguage");
+ex_hyphen_char_code:print_esc("exhyphenchar");
+left_hyphen_min_code:print_esc("lefthyphenmin");
+right_hyphen_min_code:print_esc("righthyphenmin");
+holding_inserts_code:print_esc("holdinginserts");
+error_context_lines_code:print_esc("errorcontextlines");
+luastartup_id_code:print_esc("luastartup");
+disable_lig_code:print_esc("noligs");
+disable_kern_code:print_esc("nokerns");
+cat_code_table_code:print_esc("catcodetable");
+@#
+local_inter_line_penalty_code: print_esc("localinterlinepenalty");
+local_broken_penalty_code: print_esc("localbrokenpenalty");
+{the next three do not have a matching primitive}
+no_local_whatsits_code: print("[no_local_whatsits]");
+no_local_dirs_code: print("[no_local_dirs]");
+level_local_dir_code: print("[level_local_dir]");
+@#
+pdf_output_code: print_esc("pdfoutput");
+pdf_compress_level_code: print_esc("pdfcompresslevel");
+pdf_objcompresslevel_code: print_esc("pdfobjcompresslevel");
+pdf_decimal_digits_code: print_esc("pdfdecimaldigits");
+pdf_move_chars_code: print_esc("pdfmovechars");
+pdf_image_resolution_code: print_esc("pdfimageresolution");
+pdf_pk_resolution_code: print_esc("pdfpkresolution");
+pdf_unique_resname_code: print_esc("pdfuniqueresname");
+pdf_option_always_use_pdfpagebox_code: print_esc("pdfoptionalwaysusepdfpagebox");
+pdf_option_pdf_inclusion_errorlevel_code: print_esc("pdfoptionpdfinclusionerrorlevel");
+pdf_minor_version_code: print_esc("pdfminorversion");
+pdf_force_pagebox_code: print_esc("pdfforcepagebox");
+pdf_pagebox_code: print_esc("pdfpagebox");
+pdf_inclusion_errorlevel_code: print_esc("pdfinclusionerrorlevel");
+pdf_gamma_code: print_esc("pdfgamma");
+pdf_image_gamma_code: print_esc("pdfimagegamma");
+pdf_image_hicolor_code: print_esc("pdfimagehicolor");
+pdf_image_apply_gamma_code: print_esc("pdfimageapplygamma");
+pdf_adjust_spacing_code: print_esc("pdfadjustspacing");
+pdf_protrude_chars_code: print_esc("pdfprotrudechars");
+pdf_tracing_fonts_code: print_esc("pdftracingfonts");
+pdf_gen_tounicode_code: print_esc("pdfgentounicode");
+pdf_draftmode_code: print_esc("pdfdraftmode");
+pdf_replace_font_code: print_esc("pdfreplacefont");
+@/@<Cases for |print_param|@>@/
+othercases begin print("[unknown integer parameter!]"); end
+endcases;
+end;
+
+@ The integer parameter names must be entered into the hash table.
+
+@<Put each...@>=
+primitive("pretolerance",assign_int,int_base+pretolerance_code);@/
+@!@:pretolerance_}{\.{\\pretolerance} primitive@>
+primitive("tolerance",assign_int,int_base+tolerance_code);@/
+@!@:tolerance_}{\.{\\tolerance} primitive@>
+primitive("linepenalty",assign_int,int_base+line_penalty_code);@/
+@!@:line_penalty_}{\.{\\linepenalty} primitive@>
+primitive("hyphenpenalty",assign_int,int_base+hyphen_penalty_code);@/
+@!@:hyphen_penalty_}{\.{\\hyphenpenalty} primitive@>
+primitive("exhyphenpenalty",assign_int,int_base+ex_hyphen_penalty_code);@/
+@!@:ex_hyphen_penalty_}{\.{\\exhyphenpenalty} primitive@>
+primitive("clubpenalty",assign_int,int_base+club_penalty_code);@/
+@!@:club_penalty_}{\.{\\clubpenalty} primitive@>
+primitive("widowpenalty",assign_int,int_base+widow_penalty_code);@/
+@!@:widow_penalty_}{\.{\\widowpenalty} primitive@>
+primitive("displaywidowpenalty",
+ assign_int,int_base+display_widow_penalty_code);@/
+@!@:display_widow_penalty_}{\.{\\displaywidowpenalty} primitive@>
+primitive("brokenpenalty",assign_int,int_base+broken_penalty_code);@/
+@!@:broken_penalty_}{\.{\\brokenpenalty} primitive@>
+primitive("binoppenalty",assign_int,int_base+bin_op_penalty_code);@/
+@!@:bin_op_penalty_}{\.{\\binoppenalty} primitive@>
+primitive("relpenalty",assign_int,int_base+rel_penalty_code);@/
+@!@:rel_penalty_}{\.{\\relpenalty} primitive@>
+primitive("predisplaypenalty",assign_int,int_base+pre_display_penalty_code);@/
+@!@:pre_display_penalty_}{\.{\\predisplaypenalty} primitive@>
+primitive("postdisplaypenalty",assign_int,int_base+post_display_penalty_code);@/
+@!@:post_display_penalty_}{\.{\\postdisplaypenalty} primitive@>
+primitive("interlinepenalty",assign_int,int_base+inter_line_penalty_code);@/
+@!@:inter_line_penalty_}{\.{\\interlinepenalty} primitive@>
+primitive("doublehyphendemerits",
+ assign_int,int_base+double_hyphen_demerits_code);@/
+@!@:double_hyphen_demerits_}{\.{\\doublehyphendemerits} primitive@>
+primitive("finalhyphendemerits",
+ assign_int,int_base+final_hyphen_demerits_code);@/
+@!@:final_hyphen_demerits_}{\.{\\finalhyphendemerits} primitive@>
+primitive("adjdemerits",assign_int,int_base+adj_demerits_code);@/
+@!@:adj_demerits_}{\.{\\adjdemerits} primitive@>
+primitive("mag",assign_int,int_base+mag_code);@/
+@!@:mag_}{\.{\\mag} primitive@>
+primitive("delimiterfactor",assign_int,int_base+delimiter_factor_code);@/
+@!@:delimiter_factor_}{\.{\\delimiterfactor} primitive@>
+primitive("looseness",assign_int,int_base+looseness_code);@/
+@!@:looseness_}{\.{\\looseness} primitive@>
+primitive("time",assign_int,int_base+time_code);@/
+@!@:time_}{\.{\\time} primitive@>
+primitive("day",assign_int,int_base+day_code);@/
+@!@:day_}{\.{\\day} primitive@>
+primitive("month",assign_int,int_base+month_code);@/
+@!@:month_}{\.{\\month} primitive@>
+primitive("year",assign_int,int_base+year_code);@/
+@!@:year_}{\.{\\year} primitive@>
+primitive("showboxbreadth",assign_int,int_base+show_box_breadth_code);@/
+@!@:show_box_breadth_}{\.{\\showboxbreadth} primitive@>
+primitive("showboxdepth",assign_int,int_base+show_box_depth_code);@/
+@!@:show_box_depth_}{\.{\\showboxdepth} primitive@>
+primitive("hbadness",assign_int,int_base+hbadness_code);@/
+@!@:hbadness_}{\.{\\hbadness} primitive@>
+primitive("vbadness",assign_int,int_base+vbadness_code);@/
+@!@:vbadness_}{\.{\\vbadness} primitive@>
+primitive("pausing",assign_int,int_base+pausing_code);@/
+@!@:pausing_}{\.{\\pausing} primitive@>
+primitive("tracingonline",assign_int,int_base+tracing_online_code);@/
+@!@:tracing_online_}{\.{\\tracingonline} primitive@>
+primitive("tracingmacros",assign_int,int_base+tracing_macros_code);@/
+@!@:tracing_macros_}{\.{\\tracingmacros} primitive@>
+primitive("tracingstats",assign_int,int_base+tracing_stats_code);@/
+@!@:tracing_stats_}{\.{\\tracingstats} primitive@>
+primitive("tracingparagraphs",assign_int,int_base+tracing_paragraphs_code);@/
+@!@:tracing_paragraphs_}{\.{\\tracingparagraphs} primitive@>
+primitive("tracingpages",assign_int,int_base+tracing_pages_code);@/
+@!@:tracing_pages_}{\.{\\tracingpages} primitive@>
+primitive("tracingoutput",assign_int,int_base+tracing_output_code);@/
+@!@:tracing_output_}{\.{\\tracingoutput} primitive@>
+primitive("tracinglostchars",assign_int,int_base+tracing_lost_chars_code);@/
+@!@:tracing_lost_chars_}{\.{\\tracinglostchars} primitive@>
+primitive("tracingcommands",assign_int,int_base+tracing_commands_code);@/
+@!@:tracing_commands_}{\.{\\tracingcommands} primitive@>
+primitive("tracingrestores",assign_int,int_base+tracing_restores_code);@/
+@!@:tracing_restores_}{\.{\\tracingrestores} primitive@>
+primitive("uchyph",assign_int,int_base+uc_hyph_code);@/
+@!@:uc_hyph_}{\.{\\uchyph} primitive@>
+primitive("outputpenalty",assign_int,int_base+output_penalty_code);@/
+@!@:output_penalty_}{\.{\\outputpenalty} primitive@>
+primitive("maxdeadcycles",assign_int,int_base+max_dead_cycles_code);@/
+@!@:max_dead_cycles_}{\.{\\maxdeadcycles} primitive@>
+primitive("hangafter",assign_int,int_base+hang_after_code);@/
+@!@:hang_after_}{\.{\\hangafter} primitive@>
+primitive("floatingpenalty",assign_int,int_base+floating_penalty_code);@/
+@!@:floating_penalty_}{\.{\\floatingpenalty} primitive@>
+primitive("globaldefs",assign_int,int_base+global_defs_code);@/
+@!@:global_defs_}{\.{\\globaldefs} primitive@>
+primitive("fam",assign_int,int_base+cur_fam_code);@/
+@!@:fam_}{\.{\\fam} primitive@>
+primitive("escapechar",assign_int,int_base+escape_char_code);@/
+@!@:escape_char_}{\.{\\escapechar} primitive@>
+primitive("defaulthyphenchar",assign_int,int_base+default_hyphen_char_code);@/
+@!@:default_hyphen_char_}{\.{\\defaulthyphenchar} primitive@>
+primitive("defaultskewchar",assign_int,int_base+default_skew_char_code);@/
+@!@:default_skew_char_}{\.{\\defaultskewchar} primitive@>
+primitive("endlinechar",assign_int,int_base+end_line_char_code);@/
+@!@:end_line_char_}{\.{\\endlinechar} primitive@>
+primitive("newlinechar",assign_int,int_base+new_line_char_code);@/
+@!@:new_line_char_}{\.{\\newlinechar} primitive@>
+primitive("language",assign_int,int_base+language_code);@/
+@!@:language_}{\.{\\language} primitive@>
+primitive("setlanguage",assign_int,int_base+cur_lang_code);@/
+@!@:cur_lang_}{\.{\\setlanguage} primitive@>
+primitive("exhyphenchar",assign_int,int_base+ex_hyphen_char_code);@/
+@!@:ex_hyphen_char_}{\.{\\exhyphenchar} primitive@>
+primitive("lefthyphenmin",assign_int,int_base+left_hyphen_min_code);@/
+@!@:left_hyphen_min_}{\.{\\lefthyphenmin} primitive@>
+primitive("righthyphenmin",assign_int,int_base+right_hyphen_min_code);@/
+@!@:right_hyphen_min_}{\.{\\righthyphenmin} primitive@>
+primitive("holdinginserts",assign_int,int_base+holding_inserts_code);@/
+@!@:holding_inserts_}{\.{\\holdinginserts} primitive@>
+primitive("errorcontextlines",assign_int,int_base+error_context_lines_code);@/
+@!@:error_context_lines_}{\.{\\errorcontextlines} primitive@>
+primitive("luastartup",assign_int,int_base+luastartup_id_code);@/
+@!@:luastartup_id_}{\.{\\luastartup} primitive@>
+primitive("nokerns",assign_int,int_base+disable_kern_code);@/
+@!@:disable_kern_}{\.{\\noligkerns} primitive@>
+primitive("noligs",assign_int,int_base+disable_lig_code);@/
+@!@:disable_lig_}{\.{\\noligs} primitive@>
+primitive("catcodetable",assign_int,int_base+cat_code_table_code);@/
+@!@:cat_code_table_}{\.{\\catcodetable} primitive@>
+primitive("pdfoutput",assign_int,int_base+pdf_output_code);@/
+@!@:pdf_output_}{\.{\\pdfoutput} primitive@>
+primitive("pdfcompresslevel",assign_int,int_base+pdf_compress_level_code);@/
+@!@:pdf_compress_level_}{\.{\\pdfcompresslevel} primitive@>
+primitive("pdfobjcompresslevel",assign_int,int_base+pdf_objcompresslevel_code);@/
+@!@:pdf_objcompresslevel_}{\.{\\pdfobjcompresslevel} primitive@>
+primitive("pdfdecimaldigits",assign_int,int_base+pdf_decimal_digits_code);@/
+@!@:pdf_decimal_digits_}{\.{\\pdfdecimaldigits} primitive@>
+primitive("pdfmovechars",assign_int,int_base+pdf_move_chars_code);@/
+@!@:pdf_move_chars_}{\.{\\pdfmovechars} primitive@>
+primitive("pdfimageresolution",assign_int,int_base+pdf_image_resolution_code);@/
+@!@:pdf_image_resolution_}{\.{\\pdfimageresolution} primitive@>
+primitive("pdfpkresolution",assign_int,int_base+pdf_pk_resolution_code);@/
+@!@:pdf_pk_resolution_}{\.{\\pdfpkresolution} primitive@>
+primitive("pdfuniqueresname",assign_int,int_base+pdf_unique_resname_code);@/
+@!@:pdf_unique_resname_}{\.{\\pdfuniqueresname} primitive@>
+primitive("pdfoptionpdfminorversion",assign_int,int_base+pdf_minor_version_code);@/
+@!@:pdf_minor_version_}{\.{\\pdfoptionpdfminorversion} primitive@>
+primitive("pdfoptionalwaysusepdfpagebox",assign_int,int_base+pdf_option_always_use_pdfpagebox_code);@/
+@!@:pdf_option_always_use_pdfpagebox_}{\.{\\pdfoptionalwaysusepdfpagebox} primitive@>
+primitive("pdfoptionpdfinclusionerrorlevel",assign_int,int_base+pdf_option_pdf_inclusion_errorlevel_code);@/
+@!@:pdf_option_pdf_inclusion_errorlevel_}{\.{\\pdfoptionpdfinclusionerrorlevel} primitive@>
+primitive("pdfminorversion",assign_int,int_base+pdf_minor_version_code);@/
+@!@:pdf_minor_version_}{\.{\\pdfminorversion} primitive@>
+primitive("pdfforcepagebox",assign_int,int_base+pdf_force_pagebox_code);@/
+@!@:pdf_force_pagebox_}{\.{\\pdfforcepagebox} primitive@>
+primitive("pdfpagebox",assign_int,int_base+pdf_pagebox_code);@/
+@!@:pdf_pagebox_}{\.{\\pdfpagebox} primitive@>
+primitive("pdfinclusionerrorlevel",assign_int,int_base+pdf_inclusion_errorlevel_code);@/
+@!@:pdf_inclusion_errorlevel_}{\.{\\pdfinclusionerrorlevel} primitive@>
+primitive("pdfgamma",assign_int,int_base+pdf_gamma_code);@/
+@!@:pdf_gamma_}{\.{\\pdfgamma} primitive@>
+primitive("pdfimagegamma",assign_int,int_base+pdf_image_gamma_code);@/
+@!@:pdf_image_gamma_}{\.{\\pdfimagegamma} primitive@>
+primitive("pdfimagehicolor",assign_int,int_base+pdf_image_hicolor_code);@/
+@!@:pdf_image_hicolor_}{\.{\\pdfimagehicolor} primitive@>
+primitive("pdfimageapplygamma",assign_int,int_base+pdf_image_apply_gamma_code);@/
+@!@:pdf_image_apply_gamma_}{\.{\\pdfimageapplygamma} primitive@>
+primitive("pdfadjustspacing",assign_int,int_base+pdf_adjust_spacing_code);@/
+@!@:pdf_adjust_spacing_}{\.{\\pdfadjustspacing} primitive@>
+primitive("pdfprotrudechars",assign_int,int_base+pdf_protrude_chars_code);@/
+@!@:pdf_protrude_chars_}{\.{\\pdfprotrudechars} primitive@>
+primitive("pdftracingfonts",assign_int,int_base+pdf_tracing_fonts_code);@/
+@!@:pdf_tracing_fonts_}{\.{\\pdftracingfonts} primitive@>
+primitive("pdfgentounicode",assign_int,int_base+pdf_gen_tounicode_code);@/
+@!@:pdf_gen_tounicode_}{\.{\\pdfgentounicode} primitive@>
+primitive("pdfdraftmode",assign_int,int_base+pdf_draftmode_code);@/
+@!@:pdf_draftmode_}{\.{\\pdfdraftmode} primitive@>
+primitive("pdfreplacefont",assign_int,int_base+pdf_replace_font_code);@/
+@!@:pdf_replace_font_}{\.{\\pdfreplacefont} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+assign_int: if chr_code<count_base then print_param(chr_code-int_base)
+ else begin print_esc("count"); print_int(chr_code-count_base);
+ end;
+assign_attr: begin print_esc("attribute"); print_int(chr_code-attribute_base);
+ end;
+
+@ The integer parameters should really be initialized by a macro package;
+the following initialization does the minimum to keep \TeX\ from
+complete failure.
+@^null delimiter@>
+
+@<Initialize table entries...@>=
+for k:=int_base to attribute_base-1 do eqtb[k].int:=0;
+for k:=attribute_base to del_code_base-1 do eqtb[k].int:=-1;
+mag:=1000; tolerance:=10000; hang_after:=1; max_dead_cycles:=25;
+escape_char:="\"; end_line_char:=carriage_return;
+eqtb[int_base+level_local_dir_code].int:=level_one;
+set_del_code(".",0,0,level_one); {this null delimiter is used in error recovery}
+ex_hyphen_char:="-";
+
+@ The following procedure, which is called just before \TeX\ initializes its
+input and output, establishes the initial values of the date and time.
+@^system dependencies@>
+Since standard \PASCAL\ cannot provide such information, something special
+is needed. The program here simply specifies July 4, 1776, at noon; but
+users probably want a better approximation to the truth.
+
+@p procedure fix_date_and_time;
+begin time:=12*60; {minutes since midnight}
+day:=4; {fourth day of the month}
+month:=7; {seventh month of the year}
+year:=1776; {Anno Domini}
+end;
+
+@ @<Show equivalent |n|, in region 5@>=
+begin if n<count_base then begin print_param(n-int_base);
+ print_char("="); print_int(eqtb[n].int);
+ end
+else if n<attribute_base then
+ begin print_esc("count"); print_int(n-count_base);
+ print_char("="); print_int(eqtb[n].int);
+ end
+else if n<del_code_base then
+ begin print_esc("attribute"); print_int(n-attribute_base);
+ print_char("="); print_int(eqtb[n].int);
+ end
+else begin
+ {TH: todo, this stuff doesnt work}
+ print_esc("delcode");
+ end;
+end
+
+@ @<Set variable |c| to the current escape character@>=c:=escape_char
+
+@ @<Character |s| is the current new-line character@>=s=new_line_char
+
+@ \TeX\ is occasionally supposed to print diagnostic information that
+goes only into the transcript file, unless |tracing_online| is positive.
+Here are two routines that adjust the destination of print commands:
+
+@p procedure begin_diagnostic; {prepare to do some tracing}
+begin global_old_setting:=selector;
+if (tracing_online<=0)and(selector=term_and_log) then
+ begin decr(selector);
+ if history=spotless then history:=warning_issued;
+ end;
+end;
+@#
+procedure end_diagnostic(@!blank_line:boolean);
+ {restore proper conditions after tracing}
+begin print_nl("");
+if blank_line then print_ln;
+selector:=global_old_setting;
+end;
+
+@ Of course we had better declare another global variable, if the previous
+routines are going to work.
+
+@<Glob...@>=
+@!global_old_setting:0..max_selector;
+
+@ The final region of |eqtb| contains the dimension parameters defined
+here, and the |number_regs| \.{\\dimen} registers.
+
+@d par_indent_code=0 {indentation of paragraphs}
+@d math_surround_code=1 {space around math in text}
+@d line_skip_limit_code=2 {threshold for |line_skip| instead of |baseline_skip|}
+@d hsize_code=3 {line width in horizontal mode}
+@d vsize_code=4 {page height in vertical mode}
+@d max_depth_code=5 {maximum depth of boxes on main pages}
+@d split_max_depth_code=6 {maximum depth of boxes on split pages}
+@d box_max_depth_code=7 {maximum depth of explicit vboxes}
+@d hfuzz_code=8 {tolerance for overfull hbox messages}
+@d vfuzz_code=9 {tolerance for overfull vbox messages}
+@d delimiter_shortfall_code=10 {maximum amount uncovered by variable delimiters}
+@d null_delimiter_space_code=11 {blank space in null delimiters}
+@d script_space_code=12 {extra space after subscript or superscript}
+@d pre_display_size_code=13 {length of text preceding a display}
+@d display_width_code=14 {length of line for displayed equation}
+@d display_indent_code=15 {indentation of line for displayed equation}
+@d overfull_rule_code=16 {width of rule that identifies overfull hboxes}
+@d hang_indent_code=17 {amount of hanging indentation}
+@d h_offset_code=18 {amount of horizontal offset when shipping pages out}
+@d v_offset_code=19 {amount of vertical offset when shipping pages out}
+@d emergency_stretch_code=20 {reduces badnesses on final pass of line-breaking}
+@d page_right_offset_code=21
+@d page_bottom_offset_code=22
+@d pdftex_first_dimen_code = 23 {first number defined in this section}
+@d pdf_h_origin_code = pdftex_first_dimen_code + 0 {horigin of the PDF output}
+@d pdf_v_origin_code = pdftex_first_dimen_code + 1 {vorigin of the PDF output}
+@d page_width_code = pdftex_first_dimen_code + 2 {page width of the PDF output}
+@d page_height_code = pdftex_first_dimen_code + 3 {page height of the PDF output}
+@d pdf_link_margin_code = pdftex_first_dimen_code + 4 {link margin in the PDF output}
+@d pdf_dest_margin_code = pdftex_first_dimen_code + 5 {dest margin in the PDF output}
+@d pdf_thread_margin_code = pdftex_first_dimen_code + 6 {thread margin in the PDF output}
+@d pdf_first_line_height_code = pdftex_first_dimen_code + 7
+@d pdf_last_line_depth_code = pdftex_first_dimen_code + 8
+@d pdf_each_line_height_code = pdftex_first_dimen_code + 9
+@d pdf_each_line_depth_code = pdftex_first_dimen_code + 10
+@d pdf_px_dimen_code = pdftex_first_dimen_code + 11
+@d pdftex_last_dimen_code = pdftex_first_dimen_code + 11 {last number defined in this section}
+@d dimen_pars = pdftex_last_dimen_code + 1 {total number of dimension parameters}
+@d scaled_base=dimen_base+dimen_pars
+ {table of |number_regs| user-defined \.{\\dimen} registers}
+@d eqtb_size=scaled_base+biggest_reg {largest subscript of |eqtb|}
+@#
+@d dimen(#)==eqtb[scaled_base+#].sc
+@d dimen_par(#)==eqtb[dimen_base+#].sc {a scaled quantity}
+@d par_indent==dimen_par(par_indent_code)
+@d math_surround==dimen_par(math_surround_code)
+@d line_skip_limit==dimen_par(line_skip_limit_code)
+@d hsize==dimen_par(hsize_code)
+@d vsize==dimen_par(vsize_code)
+@d max_depth==dimen_par(max_depth_code)
+@d split_max_depth==dimen_par(split_max_depth_code)
+@d box_max_depth==dimen_par(box_max_depth_code)
+@d hfuzz==dimen_par(hfuzz_code)
+@d vfuzz==dimen_par(vfuzz_code)
+@d delimiter_shortfall==dimen_par(delimiter_shortfall_code)
+@d null_delimiter_space==dimen_par(null_delimiter_space_code)
+@d script_space==dimen_par(script_space_code)
+@d pre_display_size==dimen_par(pre_display_size_code)
+@d display_width==dimen_par(display_width_code)
+@d display_indent==dimen_par(display_indent_code)
+@d overfull_rule==dimen_par(overfull_rule_code)
+@d hang_indent==dimen_par(hang_indent_code)
+@d h_offset==dimen_par(h_offset_code)
+@d v_offset==dimen_par(v_offset_code)
+@d emergency_stretch==dimen_par(emergency_stretch_code)
+@d page_right_offset==dimen_par(page_right_offset_code)
+@d page_bottom_offset==dimen_par(page_bottom_offset_code)
+@d pdf_h_origin == dimen_par(pdf_h_origin_code)
+@d pdf_v_origin == dimen_par(pdf_v_origin_code)
+@d page_width == dimen_par(page_width_code)
+@d page_height == dimen_par(page_height_code)
+@d pdf_link_margin == dimen_par(pdf_link_margin_code)
+@d pdf_dest_margin == dimen_par(pdf_dest_margin_code)
+@d pdf_thread_margin == dimen_par(pdf_thread_margin_code)
+@d pdf_first_line_height == dimen_par(pdf_first_line_height_code)
+@d pdf_last_line_depth == dimen_par(pdf_last_line_depth_code)
+@d pdf_each_line_height == dimen_par(pdf_each_line_height_code)
+@d pdf_each_line_depth == dimen_par(pdf_each_line_depth_code)
+@d pdf_px_dimen == dimen_par(pdf_px_dimen_code)
+
+@p procedure print_length_param(@!n:integer);
+begin case n of
+par_indent_code:print_esc("parindent");
+math_surround_code:print_esc("mathsurround");
+line_skip_limit_code:print_esc("lineskiplimit");
+hsize_code:print_esc("hsize");
+vsize_code:print_esc("vsize");
+max_depth_code:print_esc("maxdepth");
+split_max_depth_code:print_esc("splitmaxdepth");
+box_max_depth_code:print_esc("boxmaxdepth");
+hfuzz_code:print_esc("hfuzz");
+vfuzz_code:print_esc("vfuzz");
+delimiter_shortfall_code:print_esc("delimitershortfall");
+null_delimiter_space_code:print_esc("nulldelimiterspace");
+script_space_code:print_esc("scriptspace");
+pre_display_size_code:print_esc("predisplaysize");
+display_width_code:print_esc("displaywidth");
+display_indent_code:print_esc("displayindent");
+overfull_rule_code:print_esc("overfullrule");
+hang_indent_code:print_esc("hangindent");
+h_offset_code:print_esc("hoffset");
+v_offset_code:print_esc("voffset");
+emergency_stretch_code:print_esc("emergencystretch");
+page_right_offset_code:print_esc("pagerightoffset");
+page_bottom_offset_code:print_esc("pagebottomoffset");
+pdf_h_origin_code: print_esc("pdfhorigin");
+pdf_v_origin_code: print_esc("pdfvorigin");
+page_width_code: print_esc("pagewidth");
+page_height_code: print_esc("pageheight");
+pdf_link_margin_code: print_esc("pdflinkmargin");
+pdf_dest_margin_code: print_esc("pdfdestmargin");
+pdf_thread_margin_code: print_esc("pdfthreadmargin");
+pdf_first_line_height_code: print_esc("pdffirstlineheight");
+pdf_last_line_depth_code: print_esc("pdflastlinedepth");
+pdf_each_line_height_code: print_esc("pdfeachlineheight");
+pdf_each_line_depth_code: print_esc("pdfeachlinedepth");
+pdf_px_dimen_code: print_esc("pdfpxdimen");
+othercases print("[unknown dimen parameter!]")
+endcases;
+end;
+
+@ @<Put each...@>=
+primitive("parindent",assign_dimen,dimen_base+par_indent_code);@/
+@!@:par_indent_}{\.{\\parindent} primitive@>
+primitive("mathsurround",assign_dimen,dimen_base+math_surround_code);@/
+@!@:math_surround_}{\.{\\mathsurround} primitive@>
+primitive("lineskiplimit",assign_dimen,dimen_base+line_skip_limit_code);@/
+@!@:line_skip_limit_}{\.{\\lineskiplimit} primitive@>
+primitive("hsize",assign_dimen,dimen_base+hsize_code);@/
+@!@:hsize_}{\.{\\hsize} primitive@>
+primitive("vsize",assign_dimen,dimen_base+vsize_code);@/
+@!@:vsize_}{\.{\\vsize} primitive@>
+primitive("maxdepth",assign_dimen,dimen_base+max_depth_code);@/
+@!@:max_depth_}{\.{\\maxdepth} primitive@>
+primitive("splitmaxdepth",assign_dimen,dimen_base+split_max_depth_code);@/
+@!@:split_max_depth_}{\.{\\splitmaxdepth} primitive@>
+primitive("boxmaxdepth",assign_dimen,dimen_base+box_max_depth_code);@/
+@!@:box_max_depth_}{\.{\\boxmaxdepth} primitive@>
+primitive("hfuzz",assign_dimen,dimen_base+hfuzz_code);@/
+@!@:hfuzz_}{\.{\\hfuzz} primitive@>
+primitive("vfuzz",assign_dimen,dimen_base+vfuzz_code);@/
+@!@:vfuzz_}{\.{\\vfuzz} primitive@>
+primitive("delimitershortfall",
+ assign_dimen,dimen_base+delimiter_shortfall_code);@/
+@!@:delimiter_shortfall_}{\.{\\delimitershortfall} primitive@>
+primitive("nulldelimiterspace",
+ assign_dimen,dimen_base+null_delimiter_space_code);@/
+@!@:null_delimiter_space_}{\.{\\nulldelimiterspace} primitive@>
+primitive("scriptspace",assign_dimen,dimen_base+script_space_code);@/
+@!@:script_space_}{\.{\\scriptspace} primitive@>
+primitive("predisplaysize",assign_dimen,dimen_base+pre_display_size_code);@/
+@!@:pre_display_size_}{\.{\\predisplaysize} primitive@>
+primitive("displaywidth",assign_dimen,dimen_base+display_width_code);@/
+@!@:display_width_}{\.{\\displaywidth} primitive@>
+primitive("displayindent",assign_dimen,dimen_base+display_indent_code);@/
+@!@:display_indent_}{\.{\\displayindent} primitive@>
+primitive("overfullrule",assign_dimen,dimen_base+overfull_rule_code);@/
+@!@:overfull_rule_}{\.{\\overfullrule} primitive@>
+primitive("hangindent",assign_dimen,dimen_base+hang_indent_code);@/
+@!@:hang_indent_}{\.{\\hangindent} primitive@>
+primitive("hoffset",assign_dimen,dimen_base+h_offset_code);@/
+@!@:h_offset_}{\.{\\hoffset} primitive@>
+primitive("voffset",assign_dimen,dimen_base+v_offset_code);@/
+@!@:v_offset_}{\.{\\voffset} primitive@>
+primitive("emergencystretch",assign_dimen,dimen_base+emergency_stretch_code);@/
+@!@:emergency_stretch_}{\.{\\emergencystretch} primitive@>
+primitive("pdfhorigin",assign_dimen,dimen_base+pdf_h_origin_code);@/
+@!@:pdf_h_origin_}{\.{\\pdfhorigin} primitive@>
+primitive("pdfvorigin",assign_dimen,dimen_base+pdf_v_origin_code);@/
+@!@:pdf_v_origin_}{\.{\\pdfvorigin} primitive@>
+@#
+primitive("pagewidth",assign_dimen,dimen_base+page_width_code);@/
+primitive("pdfpagewidth",assign_dimen,dimen_base+page_width_code);@/
+@!@:page_width_}{\.{\\pdfpagewidth} primitive@>
+primitive("pageheight",assign_dimen,dimen_base+page_height_code);@/
+primitive("pdfpageheight",assign_dimen,dimen_base+page_height_code);@/
+@!@:page_height_}{\.{\\pdfpageheight} primitive@>
+@#
+primitive("pdflinkmargin",assign_dimen,dimen_base+pdf_link_margin_code);@/
+@!@:pdf_link_margin_}{\.{\\pdflinkmargin} primitive@>
+primitive("pdfdestmargin",assign_dimen,dimen_base+pdf_dest_margin_code);@/
+@!@:pdf_dest_margin_}{\.{\\pdfdestmargin} primitive@>
+primitive("pdfthreadmargin",assign_dimen,dimen_base+pdf_thread_margin_code);@/
+@!@:pdf_thread_margin_}{\.{\\pdfthreadmargin} primitive@>
+primitive("pdffirstlineheight",assign_dimen,dimen_base+pdf_first_line_height_code);@/
+@!@:pdf_first_line_height_}{\.{\\pdffirstlineheight} primitive@>
+primitive("pdflastlinedepth",assign_dimen,dimen_base+pdf_last_line_depth_code);@/
+@!@:pdf_last_line_depth_}{\.{\\pdflastlinedepth} primitive@>
+primitive("pdfeachlineheight",assign_dimen,dimen_base+pdf_each_line_height_code);@/
+@!@:pdf_each_line_height_}{\.{\\pdfeachlineheight} primitive@>
+primitive("pdfeachlinedepth",assign_dimen,dimen_base+pdf_each_line_depth_code);@/
+@!@:pdf_each_line_depth_}{\.{\\pdfeachlinedepth} primitive@>
+primitive("pdfpxdimen",assign_dimen,dimen_base+pdf_px_dimen_code);@/
+@!@:pdf_px_dimen_}{\.{\\pdfpxdimen} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+assign_dimen: if chr_code<scaled_base then
+ print_length_param(chr_code-dimen_base)
+ else begin print_esc("dimen"); print_int(chr_code-scaled_base);
+ end;
+
+@ @<Initialize table entries...@>=
+for k:=dimen_base to eqtb_size do eqtb[k].sc:=0;
+
+@ @<Show equivalent |n|, in region 6@>=
+begin if n<scaled_base then print_length_param(n-dimen_base)
+else begin print_esc("dimen"); print_int(n-scaled_base);
+ end;
+print_char("="); print_scaled(eqtb[n].sc); print("pt");
+end
+
+@ Here is a procedure that displays the contents of |eqtb[n]|
+symbolically.
+
+@p@t\4@>@<Declare the procedure called |print_cmd_chr|@>@;@/
+@!stat procedure show_eqtb(@!n:pointer);
+begin if n<active_base then print_char("?") {this can't happen}
+else if n<glue_base then @<Show equivalent |n|, in region 1 or 2@>
+else if n<local_base then @<Show equivalent |n|, in region 3@>
+else if n<int_base then @<Show equivalent |n|, in region 4@>
+else if n<dimen_base then @<Show equivalent |n|, in region 5@>
+else if n<=eqtb_size then @<Show equivalent |n|, in region 6@>
+else print_char("?"); {this can't happen either}
+end;
+tats
+
+@ The last two regions of |eqtb| have fullword values instead of the
+three fields |eq_level|, |eq_type|, and |equiv|. An |eq_type| is unnecessary,
+but \TeX\ needs to store the |eq_level| information in another array
+called |xeq_level|.
+
+@<Glob...@>=
+@!eqtb:array[active_base..eqtb_size] of memory_word;
+@!xeq_level:array[int_base..eqtb_size] of quarterword;
+
+@ @<Set init...@>=
+for k:=int_base to eqtb_size do xeq_level[k]:=level_one;
+
+@* \[18] The hash table.
+Control sequences are stored and retrieved by means of a fairly standard hash
+table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
+in {\sl The Art of Computer Programming\/}). Once a control sequence enters the
+table, it is never removed, because there are complicated situations
+involving \.{\\gdef} where the removal of a control sequence at the end of
+a group would be a mistake preventable only by the introduction of a
+complicated reference-count mechanism.
+
+The actual sequence of letters forming a control sequence identifier is
+stored in the |str_pool| array together with all the other strings. An
+auxiliary array |hash| consists of items with two halfword fields per
+word. The first of these, called |next(p)|, points to the next identifier
+belonging to the same coalesced list as the identifier corresponding to~|p|;
+and the other, called |text(p)|, points to the |str_start| entry for
+|p|'s identifier. If position~|p| of the hash table is empty, we have
+|text(p)=0|; if position |p| is either empty or the end of a coalesced
+hash list, we have |next(p)=0|. An auxiliary pointer variable called
+|hash_used| is maintained in such a way that all locations |p>=hash_used|
+are nonempty. The global variable |cs_count| tells how many multiletter
+control sequences have been defined, if statistics are being kept.
+
+A global boolean variable called |no_new_control_sequence| is set to
+|true| during the time that new hash table entries are forbidden.
+
+@d next(#) == hash[#].lh {link for coalesced lists}
+@d text(#) == hash[#].rh {string number for control sequence name}
+@d hash_is_full == (hash_used=hash_base) {test if all positions are occupied}
+@d font_id_text(#) == text(font_id_base+#) {a frozen font identifier's name}
+@d ocp_id_text(#) == text(ocp_id_base+#) {a frozen ocp identifier's name}
+@d ocp_list_id_text(#) == text(ocp_list_id_base+#)
+ {a frozen ocp list identifier's name}
+
+@<Glob...@>=
+@!hash: array[hash_base..undefined_control_sequence-1] of two_halves;
+ {the hash table}
+@!hash_used:pointer; {allocation pointer for |hash|}
+@!no_new_control_sequence:boolean; {are new identifiers legal?}
+@!cs_count:integer; {total number of known identifiers}
+
+@ Primitive support needs a few extra variables and definitions
+
+@d prim_size=2100 {maximum number of primitives }
+@d prim_prime=1777 {about 85\pct! of |primitive_size|}
+@d prim_base=1
+@d prim_next(#) == prim[#].lh {link for coalesced lists}
+@d prim_text(#) == prim[#].rh {string number for control sequence name}
+@d prim_is_full == (prim_used=prim_base) {test if all positions are occupied}
+@d prim_eq_level_field(#)==#.hh.b1
+@d prim_eq_type_field(#)==#.hh.b0
+@d prim_equiv_field(#)==#.hh.rh
+@d prim_eq_level(#)==prim_eq_level_field(prim_eqtb[#]) {level of definition}
+@d prim_eq_type(#)==prim_eq_type_field(prim_eqtb[#]) {command code for equivalent}
+@d prim_equiv(#)==prim_equiv_field(prim_eqtb[#]) {equivalent value}
+@d undefined_primitive=0
+
+@<Glob...@>=
+@!prim: array [0..prim_size] of two_halves; {the primitives table}
+@!prim_used:pointer; {allocation pointer for |prim|}
+@!prim_eqtb:array[0..prim_size] of memory_word;
+
+@ The extra set of functions make sure we can query the
+primitive meanings of thing s from C code
+
+@p
+function get_char_cat_code(c:integer):quarterword;
+begin
+ if local_catcode_table then
+ get_char_cat_code:=get_cat_code(line_catcode_table,c)
+ else
+ get_char_cat_code:=get_cat_code(cat_code_table,c)
+end;
+function get_prim_eq_level(p:integer):quarterword;
+begin
+ get_prim_eq_level := prim_eq_level(p);
+end;
+function get_prim_eq_type(p:integer):quarterword;
+begin
+ get_prim_eq_type := prim_eq_type(p);
+end;
+function get_prim_equiv(p:integer):halfword;
+begin
+ get_prim_equiv := prim_equiv(p);
+end;
+function get_eq_type(p:integer):quarterword;
+begin
+ get_eq_type := eq_type(p);
+end;
+function get_eq_level(p:integer):quarterword;
+begin
+ get_eq_level := eq_level(p);
+end;
+function is_undefined_cs(cs:integer):boolean;
+begin
+ is_undefined_cs := (cs=undefined_cs);
+end;
+function get_equiv(p:integer):halfword;
+begin
+ get_equiv := equiv(p);
+end;
+function get_cs_text(cs:integer):str_number;
+begin if cs<hash_base then
+ if cs<null_cs then get_cs_text := cs-active_base
+ else get_cs_text := "\csname\endcsname"
+ else if (text(cs)<0)or(text(cs)>=str_ptr) then get_cs_text := ""
+ else get_cs_text := text(cs);
+end;
+function get_max_command:integer;
+begin
+ get_max_command := max_command;
+end;
+function get_count_base:halfword;
+begin
+ get_count_base := count_base;
+end;
+function get_attribute_base:halfword;
+begin
+ get_attribute_base := attribute_base;
+end;
+function get_scaled_base:halfword;
+begin
+ get_scaled_base := scaled_base;
+end;
+function get_int_base:halfword;
+begin
+ get_int_base := int_base;
+end;
+function get_toks_base:halfword;
+begin
+ get_toks_base := toks_base;
+end;
+function get_every_eof:halfword;
+begin
+ get_every_eof := every_eof;
+end;
+function get_suppress_fontnotfound_error:boolean;
+begin
+ get_suppress_fontnotfound_error := suppress_fontnotfound_error;
+end;
+function get_pdf_image_resolution:integer;
+begin
+ get_pdf_image_resolution := pdf_image_resolution;
+end;
+function get_pdf_minor_version:integer;
+begin
+ get_pdf_minor_version := pdf_minor_version;
+end;
+function get_pdf_inclusion_errorlevel:integer;
+begin
+ get_pdf_inclusion_errorlevel := pdf_inclusion_errorlevel;
+end;
+
+@ @<Set init...@>=
+no_new_control_sequence:=true; {new identifiers are usually forbidden}
+prim_next(0):=0; prim_text(0):=0;
+for k:=1 to prim_size do prim[k]:=prim[0];
+prim_eq_level(0) := level_zero;
+prim_eq_type(0) := undefined_cs;
+prim_equiv(0) := null;
+for k:=1 to prim_size do prim_eqtb[k]:=prim_eqtb[0];
+next(hash_base):=0; text(hash_base):=0;
+for k:=hash_base+1 to undefined_control_sequence-1 do hash[k]:=hash[hash_base];
+
+@ @<Initialize table entries...@>=
+prim_used:=prim_size; {nothing is used}
+hash_used:=frozen_control_sequence; {nothing is used}
+cs_count:=0;
+eq_type(frozen_dont_expand):=dont_expand;
+text(frozen_dont_expand):="notexpanded:";
+@.notexpanded:@>
+
+eq_type(frozen_primitive):=ignore_spaces;
+equiv(frozen_primitive):=1;
+eq_level(frozen_primitive):=level_one;
+text(frozen_primitive):="primitive";
+
+@ Here is the subroutine that searches the hash table for an identifier
+that matches a given string of length |l>1| appearing in |buffer[j..
+(j+l-1)]|. If the identifier is found, the corresponding hash table address
+is returned. Otherwise, if the global variable |no_new_control_sequence|
+is |true|, the dummy address |undefined_control_sequence| is returned.
+Otherwise the identifier is inserted into the hash table and its location
+is returned.
+
+@p function id_lookup(@!j,@!l:integer):pointer; {search the hash table}
+label found; {go here if you found it}
+var h:integer; {hash code}
+@!d:integer; {number of characters in incomplete current string}
+@!p:pointer; {index in |hash| array}
+@!k:pointer; {index in |buffer| array}
+begin @<Compute the hash code |h|@>;
+p:=h+hash_base; {we start searching here; note that |0<=h<hash_prime|}
+loop@+begin if text(p)>0 then if length(text(p))=l then
+ if str_eq_buf(text(p),j) then goto found;
+ if next(p)=0 then
+ begin if no_new_control_sequence then
+ p:=undefined_control_sequence
+ else @<Insert a new control sequence after |p|, then make
+ |p| point to it@>;
+ goto found;
+ end;
+ p:=next(p);
+ end;
+found: id_lookup:=p;
+end;
+
+@ @<Insert a new control...@>=
+begin if text(p)>0 then
+ begin repeat if hash_is_full then overflow("hash size",hash_size);
+@:TeX capacity exceeded hash size}{\quad hash size@>
+ decr(hash_used);
+ until text(hash_used)=0; {search for an empty location in |hash|}
+ next(p):=hash_used; p:=hash_used;
+ end;
+str_room(l); d:=cur_length;
+while pool_ptr>str_start_macro(str_ptr) do
+ begin decr(pool_ptr); str_pool[pool_ptr+l]:=str_pool[pool_ptr];
+ end; {move current string up to make room for another}
+for k:=j to j+l-1 do append_char(buffer[k]);
+text(p):=make_string; pool_ptr:=pool_ptr+d;
+@!stat incr(cs_count);@+tats@;@/
+end
+
+@ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
+should be a prime number. The theory of hashing tells us to expect fewer
+than two table probes, on the average, when the search is successful.
+[See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
+@^Vitter, Jeffrey Scott@>
+
+@<Compute the hash code |h|@>=
+h:=buffer[j];
+for k:=j+1 to j+l-1 do
+ begin h:=h+h+buffer[k];
+ while h>=hash_prime do h:=h-hash_prime;
+ end
+
+@ Here is the subroutine that searches the primitive table for an identifier
+
+@p function prim_lookup(@!s:str_number):pointer; {search the primitives table}
+label found; {go here if you found it}
+var h:integer; {hash code}
+@!p:pointer; {index in |hash| array}
+@!k:pointer; {index in string pool}
+@!the_hash_prime:halfword;
+@!j,@!l:integer;
+begin
+the_hash_prime:= prim_prime;
+if s<string_offset then begin
+ p := s;
+ if (p<0) or (get_prim_eq_level(p)<>level_one) then
+ p := undefined_primitive;
+end
+else begin
+ j:=str_start_macro(s);
+ if s = str_ptr then l := cur_length else l := length(s);
+ @<Compute the string hash code |h|@>;
+ p:=h+prim_base; {we start searching here; note that |0<=h<hash_prime|}
+ loop@+begin if prim_text(p)>0 then if length(prim_text(p))=l then
+ if str_eq_str(prim_text(p),s) then goto found;
+ if prim_next(p)=0 then
+ begin if no_new_control_sequence then
+ p:=undefined_primitive
+ else @<Insert a new primitive after |p|, then make
+ |p| point to it@>;
+ goto found;
+ end;
+ p:=prim_next(p);
+ end;
+ end;
+found: prim_lookup:=p;
+end;
+
+function string_lookup(@!s:str_number):pointer; {search the primitives table}
+label found; {go here if you found it}
+var h:integer; {hash code}
+@!p:pointer; {index in |hash| array}
+@!k:pointer; {index in string pool}
+@!the_hash_prime: halfword;
+@!j,@!l:integer;
+begin
+the_hash_prime := hash_prime;
+if s<string_offset then begin
+ p := s;
+ if (p<0) or (eq_level(p)<>level_one) then
+ p := undefined_cs;
+end
+else begin
+ j:=str_start_macro(s);
+ if s = str_ptr then l := cur_length else l := length(s);
+ @<Compute the string hash code |h|@>;
+ p:=h+hash_base; {we start searching here; note that |0<=h<hash_prime|}
+ loop@+begin if text(p)>0 then if length(text(p))=l then
+ if str_eq_str(text(p),s) then goto found;
+ if next(p)=0 then
+ begin
+ p:=undefined_cs ;
+ goto found;
+ end;
+ p:=next(p);
+ end;
+ end;
+found: string_lookup:=p;
+end;
+
+function is_primitive(csname:str_number):boolean;
+ var n,m:integer;
+begin
+ m := prim_lookup(csname);
+ n := string_lookup(csname);
+ is_primitive :=((n<>undefined_cs) and
+ (m<>undefined_primitive) and
+ (eq_type(n)=get_prim_eq_type(m)) and
+ (equiv(n)=get_prim_equiv(m)));
+end;
+
+@ @<Insert a new primitive...@>=
+begin if prim_text(p)>0 then
+ begin repeat if prim_is_full then overflow("primitive size",prim_size);
+@:TeX capacity exceeded primitive size}{\quad primitive size@>
+ decr(prim_used);
+ until prim_text(prim_used)=0; {search for an empty location in |prim|}
+ prim_next(p):=prim_used; p:=prim_used;
+ end;
+prim_text(p):=s;
+end
+
+@ The value of |prim_prime| should be roughly 85\pct! of
+|prim_size|, and it should be a prime number.
+
+@<Compute the string hash code |h|@>=
+h:=str_pool[j];
+for k:=j+1 to j+l-1 do
+ begin h:=h+h+str_pool[k];
+ while h>=the_hash_prime do h:=h-the_hash_prime;
+ end
+
+
+@ The procedure |print_cs| prints the name of a control sequence, given
+a pointer to its address in |eqtb|. A space is printed after the name
+unless it is a single nonletter or an active character. This procedure
+might be invoked with invalid data, so it is ``extra robust.'' The
+individual characters must be printed one at a time using |print|, since
+they may be unprintable.
+
+@d single_letter(#)==(length(#)=1)or
+ ((length(#)=4)and(str_pool[str_start_macro(#)]>=@"F0))or
+ ((length(#)=3)and(str_pool[str_start_macro(#)]>=@"E0))or
+ ((length(#)=2)and(str_pool[str_start_macro(#)]>=@"C0))
+
+@<Basic printing...@>=
+procedure print_cs(@!p:integer); {prints a purported control sequence}
+begin if p<hash_base then {single character}
+ if p=null_cs then
+ begin print_esc("csname"); print_esc("endcsname");
+ end
+ else if p<active_base then print_esc("IMPOSSIBLE.")
+@.IMPOSSIBLE@>
+ else print(p-active_base)
+else if p>=undefined_control_sequence then print_esc("IMPOSSIBLE.")
+else if (text(p)<0)or(text(p)>=str_ptr) then print_esc("NONEXISTENT.")
+@.NONEXISTENT@>
+else begin
+ print_esc(text(p));
+ if single_letter(text(p)) then begin
+ if get_cat_code(cat_code_table,pool_to_unichar(str_start_macro(text(p))))=letter then
+ print_char(" ")
+ else
+ do_nothing;
+ end
+ else
+ print_char(" ");
+ end;
+end;
+
+@ Here is a similar procedure; it avoids the error checks, and it never
+prints a space after the control sequence.
+
+@<Basic printing procedures@>=
+procedure sprint_cs(@!p:pointer); {prints a control sequence}
+begin if p<hash_base then
+ if p<null_cs then print(p-active_base)
+ else begin print_esc("csname"); print_esc("endcsname");
+ end
+else print_esc(text(p));
+end;
+
+@ We need to put \TeX's ``primitive'' control sequences into the hash
+table, together with their command code (which will be the |eq_type|)
+and an operand (which will be the |equiv|). The |primitive| procedure
+does this, in a way that no \TeX\ user can. The global value |cur_val|
+contains the new |eqtb| pointer after |primitive| has acted.
+
+@p @!init procedure primitive(@!ss:str_number;@!c:quarterword;@!o:halfword);
+var k:pool_pointer; {index into |str_pool|}
+@!s:str_number; {actual |str_number| used }
+@!j:0..buf_size; {index into |buffer|}
+@!l:small_number; {length of the string}
+@!prim_val:integer; {needed to fill |prim_eqtb|}
+begin if ss<number_chars then begin
+ if ss>127 then confusion("prim"); { should be ASCII }
+ append_char(ss);
+ s:=make_string;
+ end
+else
+ s:=ss;
+k:=str_start_macro(s); l:=str_start_macro(s+1)-k;
+ {we will move |s| into the (possibly non-empty) |buffer|}
+if first+l>buf_size+1 then
+ check_buffer_overflow(first+l);
+@:TeX capacity exceeded buffer size}{\quad buffer size@>
+for j:=0 to l-1 do buffer[first+j]:=so(str_pool[k+j]);
+cur_val:=id_lookup(first,l); {|no_new_control_sequence| is |false|}
+flush_string; text(cur_val):=s; {we don't want to have the string twice}
+prim_val:=prim_lookup(s);
+eq_level(cur_val):=level_one; eq_type(cur_val):=c; equiv(cur_val):=o;
+prim_eq_level(prim_val) := level_one;
+prim_eq_type(prim_val) := c;
+prim_equiv(prim_val) := o;
+end;
+tini
+
+@ Many of \TeX's primitives need no |equiv|, since they are identifiable
+by their |eq_type| alone. These primitives are loaded into the hash table
+as follows:
+
+@<Put each of \TeX's primitives into the hash table@>=
+primitive(" ",ex_space,0);@/
+@!@:Single-character primitives /}{\quad\.{\\\ }@>
+primitive("/",ital_corr,0);@/
+@!@:Single-character primitives /}{\quad\.{\\/}@>
+primitive("accent",accent,0);@/
+@!@:accent_}{\.{\\accent} primitive@>
+primitive("advance",advance,0);@/
+@!@:advance_}{\.{\\advance} primitive@>
+primitive("afterassignment",after_assignment,0);@/
+@!@:after_assignment_}{\.{\\afterassignment} primitive@>
+primitive("aftergroup",after_group,0);@/
+@!@:after_group_}{\.{\\aftergroup} primitive@>
+primitive("begingroup",begin_group,0);@/
+@!@:begin_group_}{\.{\\begingroup} primitive@>
+primitive("char",char_num,0);@/
+@!@:char_}{\.{\\char} primitive@>
+primitive("csname",cs_name,0);@/
+@!@:cs_name_}{\.{\\csname} primitive@>
+primitive("delimiter",delim_num,0);@/
+@!@:delimiter_}{\.{\\delimiter} primitive@>
+primitive("odelimiter",delim_num,1);@/
+@!@:odelimiter_}{\.{\\odelimiter} primitive@>
+primitive("divide",divide,0);@/
+@!@:divide_}{\.{\\divide} primitive@>
+primitive("endcsname",end_cs_name,0);@/
+@!@:end_cs_name_}{\.{\\endcsname} primitive@>
+primitive("endgroup",end_group,0);
+@!@:end_group_}{\.{\\endgroup} primitive@>
+text(frozen_end_group):="endgroup"; eqtb[frozen_end_group]:=eqtb[cur_val];@/
+primitive("expandafter",expand_after,0);@/
+@!@:expand_after_}{\.{\\expandafter} primitive@>
+primitive("font",def_font,0);@/
+@!@:font_}{\.{\\font} primitive@>
+primitive("letterspacefont",letterspace_font,0);@/
+@!@:letterspace_font_}{\.{\\letterspacefont} primitive@>
+primitive("fontdimen",assign_font_dimen,0);@/
+@!@:font_dimen_}{\.{\\fontdimen} primitive@>
+primitive("halign",halign,0);@/
+@!@:halign_}{\.{\\halign} primitive@>
+primitive("hrule",hrule,0);@/
+@!@:hrule_}{\.{\\hrule} primitive@>
+primitive("ignorespaces",ignore_spaces,0);@/
+@!@:ignore_spaces_}{\.{\\ignorespaces} primitive@>
+primitive("insert",insert,0);@/
+@!@:insert_}{\.{\\insert} primitive@>
+primitive("leftghost",char_ghost,0);@/
+@!@:leftghost_}{\.{\\leftghost} primitive@>
+primitive("mark",mark,0);@/
+@!@:mark_}{\.{\\mark} primitive@>
+primitive("mathaccent",math_accent,0);@/
+@!@:math_accent_}{\.{\\mathaccent} primitive@>
+primitive("mathchar",math_char_num,0);@/
+@!@:math_char_}{\.{\\mathchar} primitive@>
+primitive("omathaccent",math_accent,1);@/
+@!@:math_accent_}{\.{\\omathaccent} primitive@>
+primitive("omathchar",math_char_num,1);@/
+@!@:math_char_}{\.{\\omathchar} primitive@>
+primitive("mathchoice",math_choice,0);@/
+@!@:math_choice_}{\.{\\mathchoice} primitive@>
+primitive("multiply",multiply,0);@/
+@!@:multiply_}{\.{\\multiply} primitive@>
+primitive("noalign",no_align,0);@/
+@!@:no_align_}{\.{\\noalign} primitive@>
+primitive("noboundary",no_boundary,0);@/
+@!@:no_boundary_}{\.{\\noboundary} primitive@>
+primitive("noexpand",no_expand,0);@/
+@!@:no_expand_}{\.{\\noexpand} primitive@>
+primitive("primitive",no_expand,1);@/
+@!@:primitive_}{\.{\\primitive} primitive@>
+primitive("pdfprimitive",no_expand,1);@/
+@!@:pdfprimitive_}{\.{\\pdfprimitive} primitive@>
+primitive("nonscript",non_script,0);@/
+@!@:non_script_}{\.{\\nonscript} primitive@>
+primitive("omit",omit,0);@/
+@!@:omit_}{\.{\\omit} primitive@>
+primitive("parshape",set_shape,par_shape_loc);@/
+@!@:par_shape_}{\.{\\parshape} primitive@>
+primitive("penalty",break_penalty,0);@/
+@!@:penalty_}{\.{\\penalty} primitive@>
+primitive("prevgraf",set_prev_graf,0);@/
+@!@:prev_graf_}{\.{\\prevgraf} primitive@>
+primitive("radical",radical,0);@/
+@!@:radical_}{\.{\\radical} primitive@>
+primitive("oradical",radical,1);@/
+@!@:radical_}{\.{\\oradical} primitive@>
+primitive("read",read_to_cs,0);@/
+@!@:read_}{\.{\\read} primitive@>
+primitive("relax",relax,too_big_char);
+@!@:relax_}{\.{\\relax} primitive@>
+text(frozen_relax):="relax"; eqtb[frozen_relax]:=eqtb[cur_val];@/
+primitive("rightghost",char_ghost,1);@/
+@!@:rightghost_}{\.{\\rightghost} primitive@>
+primitive("setbox",set_box,0);@/
+@!@:set_box_}{\.{\\setbox} primitive@>
+primitive("the",the,0);@/
+@!@:the_}{\.{\\the} primitive@>
+primitive("toks",toks_register,0);@/
+@!@:toks_}{\.{\\toks} primitive@>
+primitive("vadjust",vadjust,0);@/
+@!@:vadjust_}{\.{\\vadjust} primitive@>
+primitive("valign",valign,0);@/
+@!@:valign_}{\.{\\valign} primitive@>
+primitive("vcenter",vcenter,0);@/
+@!@:vcenter_}{\.{\\vcenter} primitive@>
+primitive("vrule",vrule,0);@/
+@!@:vrule_}{\.{\\vrule} primitive@>
+
+@ Each primitive has a corresponding inverse, so that it is possible to
+display the cryptic numeric contents of |eqtb| in symbolic form.
+Every call of |primitive| in this program is therefore accompanied by some
+straightforward code that forms part of the |print_cmd_chr| routine
+below.
+
+@<Cases of |print_cmd_chr|...@>=
+accent: print_esc("accent");
+advance: print_esc("advance");
+after_assignment: print_esc("afterassignment");
+after_group: print_esc("aftergroup");
+assign_font_dimen: print_esc("fontdimen");
+begin_group: print_esc("begingroup");
+break_penalty: print_esc("penalty");
+char_num: print_esc("char");
+char_ghost: if cur_chr=0 then print_esc("leftghost")
+ else print_esc("rightghost");
+cs_name: print_esc("csname");
+def_font: print_esc("font");
+letterspace_font: print_esc("letterspacefont");
+delim_num: if chr_code=0 then print_esc("delimiter") else print_esc("odelimiter") ;
+divide: print_esc("divide");
+end_cs_name: print_esc("endcsname");
+end_group: print_esc("endgroup");
+ex_space: print_esc(" ");
+expand_after: if chr_code=0 then print_esc("expandafter")
+ @<Cases of |expandafter| for |print_cmd_chr|@>;
+halign: print_esc("halign");
+hrule: print_esc("hrule");
+ignore_spaces: if chr_code=0 then print_esc("ignorespaces") else print_esc("primitive");
+insert: print_esc("insert");
+ital_corr: print_esc("/");
+mark: begin
+ if chr_code=0 then print_esc("mark")
+ else if chr_code=1 then print_esc("clearmarks")
+ else print_esc("marks");
+ end;
+math_accent: if chr_code=0 then print_esc("mathaccent") else print_esc("omathaccent");
+math_char_num: if chr_code=0 then print_esc("mathchar") else print_esc("omathchar");
+math_choice: print_esc("mathchoice");
+multiply: print_esc("multiply");
+no_align: print_esc("noalign");
+no_boundary:print_esc("noboundary");
+no_expand: if chr_code=0 then print_esc("noexpand")
+ else print_esc("primitive");
+non_script: print_esc("nonscript");
+omit: print_esc("omit");
+radical: if chr_code=0 then print_esc("radical") else print_esc("oradical");
+read_to_cs: if chr_code=0 then print_esc("read")
+ @<Cases of |read| for |print_cmd_chr|@>;
+relax: print_esc("relax");
+set_box: print_esc("setbox");
+set_prev_graf: print_esc("prevgraf");
+set_shape: case chr_code of
+ par_shape_loc: print_esc("parshape");
+ @<Cases of |set_shape| for |print_cmd_chr|@>@;@/
+ end; {there are no other cases}
+the: if chr_code=0 then print_esc("the")
+ @<Cases of |the| for |print_cmd_chr|@>;
+toks_register: print_esc("toks");
+vadjust: print_esc("vadjust");
+valign: print_esc("valign");
+vcenter: print_esc("vcenter");
+vrule: print_esc("vrule");
+
+@ We will deal with the other primitives later, at some point in the program
+where their |eq_type| and |equiv| values are more meaningful. For example,
+the primitives for math mode will be loaded when we consider the routines
+that deal with formulas. It is easy to find where each particular
+primitive was treated by looking in the index at the end; for example, the
+section where |"radical"| entered |eqtb| is listed under `\.{\\radical}
+primitive'. (Primitives consisting of a single nonalphabetic character,
+@!like `\.{\\/}', are listed under `Single-character primitives'.)
+@!@^Single-character primitives@>
+
+
+@* \[19] Saving and restoring equivalents.
+The nested structure provided by `$\.{\char'173}\ldots\.{\char'175}$' groups
+in \TeX\ means that |eqtb| entries valid in outer groups should be saved
+and restored later if they are overridden inside the braces. When a new |eqtb|
+value is being assigned, the program therefore checks to see if the previous
+entry belongs to an outer level. In such a case, the old value is placed
+on the |save_stack| just before the new value enters |eqtb|. At the
+end of a grouping level, i.e., when the right brace is sensed, the
+|save_stack| is used to restore the outer values, and the inner ones are
+destroyed.
+
+Entries on the |save_stack| are of type |memory_word|. The top item on
+this stack is |save_stack[p]|, where |p=save_ptr-1|; it contains three
+fields called |save_type|, |save_level|, and |save_index|, and it is
+interpreted in one of four ways:
+
+\yskip\hangg 1) If |save_type(p)=restore_old_value|, then
+|save_index(p)| is a location in |eqtb| whose current value should
+be destroyed at the end of the current group and replaced by |save_stack[p-1]|.
+Furthermore if |save_index(p)>=int_base|, then |save_level(p)|
+should replace the corresponding entry in |xeq_level|.
+
+\yskip\hangg 2) If |save_type(p)=restore_zero|, then |save_index(p)|
+is a location in |eqtb| whose current value should be destroyed at the end
+of the current group, when it should be
+replaced by the current value of |eqtb[undefined_control_sequence]|.
+
+\yskip\hangg 3) If |save_type(p)=insert_token|, then |save_index(p)|
+is a token that should be inserted into \TeX's input when the current
+group ends.
+
+\yskip\hangg 4) If |save_type(p)=level_boundary|, then |save_level(p)|
+is a code explaining what kind of group we were previously in, and
+|save_index(p)| points to the level boundary word at the bottom of
+the entries for that group.
+Furthermore, in extended \eTeX\ mode, |save_stack[p-1]| contains the
+source line number at which the current level of grouping was entered.
+
+@d save_type(#)==save_stack[#].hh.b0 {classifies a |save_stack| entry}
+@d save_level(#)==save_stack[#].hh.b1
+ {saved level for regions 5 and 6, or group code}
+@d save_index(#)==save_stack[#].hh.rh
+ {|eqtb| location or |save_stack| location}
+@d restore_old_value=0 {|save_type| when a value should be restored later}
+@d restore_zero=1 {|save_type| when an undefined entry should be restored}
+@d insert_token=2 {|save_type| when a token is being saved for later use}
+@d level_boundary=3 {|save_type| corresponding to beginning of group}
+
+@p@t\4@>@<Declare \eTeX\ procedures for tracing and input@>
+
+@ Here are the group codes that are used to discriminate between different
+kinds of groups. They allow \TeX\ to decide what special actions, if any,
+should be performed when a group ends.
+\def\grp{\.{\char'173...\char'175}}
+
+Some groups are not supposed to be ended by right braces. For example,
+the `\.\$' that begins a math formula causes a |math_shift_group| to
+be started, and this should be terminated by a matching `\.\$'. Similarly,
+a group that starts with \.{\\left} should end with \.{\\right}, and
+one that starts with \.{\\begingroup} should end with \.{\\endgroup}.
+
+@d bottom_level=0 {group code for the outside world}
+@d simple_group=1 {group code for local structure only}
+@d hbox_group=2 {code for `\.{\\hbox}\grp'}
+@d adjusted_hbox_group=3 {code for `\.{\\hbox}\grp' in vertical mode}
+@d vbox_group=4 {code for `\.{\\vbox}\grp'}
+@d vtop_group=5 {code for `\.{\\vtop}\grp'}
+@d align_group=6 {code for `\.{\\halign}\grp', `\.{\\valign}\grp'}
+@d no_align_group=7 {code for `\.{\\noalign}\grp'}
+@d output_group=8 {code for output routine}
+@d math_group=9 {code for, e.g, `\.{\char'136}\grp'}
+@d disc_group=10 {code for `\.{\\discretionary}\grp\grp\grp'}
+@d insert_group=11 {code for `\.{\\insert}\grp', `\.{\\vadjust}\grp'}
+@d vcenter_group=12 {code for `\.{\\vcenter}\grp'}
+@d math_choice_group=13 {code for `\.{\\mathchoice}\grp\grp\grp\grp'}
+@d semi_simple_group=14 {code for `\.{\\begingroup...\\endgroup}'}
+@d math_shift_group=15 {code for `\.{\$...\$}'}
+@d math_left_group=16 {code for `\.{\\left...\\right}'}
+@d local_box_group=17 {code for `\.{\\localleftbox...\\localrightbox}'}
+@d max_group_code=17
+@d split_off_group=18 {box code for the top part of a \.{\\vsplit}}
+@d split_keep_group=19 {box code for the bottom part of a \.{\\vsplit}}
+@d preamble_group=20 {box code for the preamble processing in an alignment}
+@d align_set_group=21 {box code for the final item pass in an alignment}
+@d fin_row_group=22 {box code for a provisory line in an alignment}
+
+@<Types...@>=
+@!group_code=0..max_group_code; {|save_level| for a level boundary}
+
+@ The global variable |cur_group| keeps track of what sort of group we are
+currently in. Another global variable, |cur_boundary|, points to the
+topmost |level_boundary| word. And |cur_level| is the current depth of
+nesting. The routines are designed to preserve the condition that no entry
+in the |save_stack| or in |eqtb| ever has a level greater than |cur_level|.
+
+@ @<Glob...@>=
+@!save_stack : array[0..save_size] of memory_word;
+@!save_ptr : 0..save_size; {first unused entry on |save_stack|}
+@!max_save_stack:0..save_size; {maximum usage of save stack}
+@!cur_level: quarterword; {current nesting level for groups}
+@!cur_group: group_code; {current group type}
+@!cur_boundary: 0..save_size; {where the current level begins}
+
+@ At this time it might be a good idea for the reader to review the introduction
+to |eqtb| that was given above just before the long lists of parameter names.
+Recall that the ``outer level'' of the program is |level_one|, since
+undefined control sequences are assumed to be ``defined'' at |level_zero|.
+
+@<Set init...@>=
+save_ptr:=0; cur_level:=level_one; cur_group:=bottom_level; cur_boundary:=0;
+max_save_stack:=0;
+
+@ The following macro is used to test if there is room for up to eight more
+entries on |save_stack|. By making a conservative test like this, we can
+get by with testing for overflow in only a few places.
+
+@d check_full_save_stack==if save_ptr>max_save_stack then
+ begin max_save_stack:=save_ptr;
+ if max_save_stack>save_size-8 then overflow("save size",save_size);
+@:TeX capacity exceeded save size}{\quad save size@>
+ end
+
+@ Procedure |new_save_level| is called when a group begins. The
+argument is a group identification code like `|hbox_group|'. After
+calling this routine, it is safe to put six more entries on |save_stack|.
+
+In some cases integer-valued items are placed onto the
+|save_stack| just below a |level_boundary| word, because this is a
+convenient place to keep information that is supposed to ``pop up'' just
+when the group has finished.
+For example, when `\.{\\hbox to 100pt}\grp' is being treated, the 100pt
+dimension is stored on |save_stack| just before |new_save_level| is
+called.
+
+We use the notation |saved(k)| to stand for an integer item that
+appears in location |save_ptr+k| of the save stack.
+
+@d saved(#)==save_stack[save_ptr+#].int
+
+@p procedure new_save_level(@!c:group_code); {begin a new level of grouping}
+begin check_full_save_stack;
+saved(0):=line; incr(save_ptr);
+save_type(save_ptr):=level_boundary; save_level(save_ptr):=cur_group;
+save_index(save_ptr):=cur_boundary;
+if cur_level=max_quarterword then overflow("grouping levels",
+@:TeX capacity exceeded grouping levels}{\quad grouping levels@>
+ max_quarterword-min_quarterword);
+ {quit if |(cur_level+1)| is too big to be stored in |eqtb|}
+cur_boundary:=save_ptr; cur_group:=c;
+@!stat if tracing_groups>0 then group_trace(false);@+tats@;@/
+incr(cur_level); incr(save_ptr);
+end;
+
+@ Just before an entry of |eqtb| is changed, the following procedure should
+be called to update the other data structures properly. It is important
+to keep in mind that reference counts in |mem| include references from
+within |save_stack|, so these counts must be handled carefully.
+@^reference counts@>
+
+@p procedure eq_destroy(@!w:memory_word); {gets ready to forget |w|}
+var q:pointer; {|equiv| field of |w|}
+begin case eq_type_field(w) of
+call,long_call,outer_call,long_outer_call: delete_token_ref(equiv_field(w));
+glue_ref: delete_glue_ref(equiv_field(w));
+shape_ref: begin q:=equiv_field(w); {we need to free a \.{\\parshape} block}
+ if q<>null then flush_node(q);
+ end; {such a block is |2n+1| words long, where |n=vinfo(q)|}
+box_ref: flush_node_list(equiv_field(w));
+othercases do_nothing
+endcases;
+end;
+
+@ To save a value of |eqtb[p]| that was established at level |l|, we
+can use the following subroutine.
+
+@p procedure eq_save(@!p:pointer;@!l:quarterword); {saves |eqtb[p]|}
+begin check_full_save_stack;
+if l=level_zero then save_type(save_ptr):=restore_zero
+else begin save_stack[save_ptr]:=eqtb[p]; incr(save_ptr);
+ save_type(save_ptr):=restore_old_value;
+ end;
+save_level(save_ptr):=l; save_index(save_ptr):=p; incr(save_ptr);
+end;
+
+@ The procedure |eq_define| defines an |eqtb| entry having specified
+|eq_type| and |equiv| fields, and saves the former value if appropriate.
+This procedure is used only for entries in the first four regions of |eqtb|,
+i.e., only for entries that have |eq_type| and |equiv| fields.
+After calling this routine, it is safe to put four more entries on
+|save_stack|, provided that there was room for four more entries before
+the call, since |eq_save| makes the necessary test.
+
+@d assign_trace(#)==@!stat if tracing_assigns>0 then restore_trace(#);
+ tats
+
+@p procedure eq_define(@!p:pointer;@!t:quarterword;@!e:halfword);
+ {new data for |eqtb|}
+label exit;
+begin if (eq_type(p)=t)and(equiv(p)=e) then
+ begin assign_trace(p,"reassigning")@;@/
+ eq_destroy(eqtb[p]); return;
+ end;
+assign_trace(p,"changing")@;@/
+if eq_level(p)=cur_level then eq_destroy(eqtb[p])
+else if cur_level>level_one then eq_save(p,eq_level(p));
+eq_level(p):=cur_level; eq_type(p):=t; equiv(p):=e;
+assign_trace(p,"into")@;@/
+exit:end;
+
+@ The counterpart of |eq_define| for the remaining (fullword) positions in
+|eqtb| is called |eq_word_define|. Since |xeq_level[p]>=level_one| for all
+|p|, a `|restore_zero|' will never be used in this case.
+
+@p procedure eq_word_define(@!p:pointer;@!w:integer);
+label exit;
+begin if eqtb[p].int=w then
+ begin assign_trace(p,"reassigning")@;@/
+ return;
+ end;
+assign_trace(p,"changing")@;@/
+if xeq_level[p]<>cur_level then
+ begin eq_save(p,xeq_level[p]); xeq_level[p]:=cur_level;
+ end;
+eqtb[p].int:=w;
+assign_trace(p,"into")@;@/
+exit:end;
+
+@ The |eq_define| and |eq_word_define| routines take care of local definitions.
+@^global definitions@>
+Global definitions are done in almost the same way, but there is no need
+to save old values, and the new value is associated with |level_one|.
+
+@p procedure geq_define(@!p:pointer;@!t:quarterword;@!e:halfword);
+ {global |eq_define|}
+begin assign_trace(p,"globally changing")@;@/
+begin eq_destroy(eqtb[p]);
+eq_level(p):=level_one; eq_type(p):=t; equiv(p):=e;
+end;
+assign_trace(p,"into")@;@/
+end;
+@#
+procedure geq_word_define(@!p:pointer;@!w:integer); {global |eq_word_define|}
+begin assign_trace(p,"globally changing")@;@/
+begin eqtb[p].int:=w; xeq_level[p]:=level_one;
+end;
+assign_trace(p,"into")@;@/
+end;
+
+@ Subroutine |save_for_after| puts a token on the stack for save-keeping.
+
+@p procedure save_for_after(@!t:halfword);
+begin if cur_level>level_one then
+ begin check_full_save_stack;
+ save_type(save_ptr):=insert_token; save_level(save_ptr):=level_zero;
+ save_index(save_ptr):=t; incr(save_ptr);
+ end;
+end;
+
+@ The |unsave| routine goes the other way, taking items off of |save_stack|.
+This routine takes care of restoration when a level ends; everything
+belonging to the topmost group is cleared off of the save stack.
+
+@p
+procedure@?back_input; forward; @t\2@>
+procedure unsave; {pops the top level off the save stack}
+label done;
+var p:pointer; {position to be restored}
+@!l:quarterword; {saved level, if in fullword regions of |eqtb|}
+@!t:halfword; {saved value of |cur_tok|}
+@!a:boolean; {have we already processed an \.{\\aftergroup} ?}
+begin a:=false; l:=level_one; {just in case}
+unsave_math_codes(cur_level);
+unsave_cat_codes (cat_code_table,cur_level);
+unsave_text_codes(cur_level);
+if cur_level>level_one then
+ begin decr(cur_level);
+ @<Clear off top level from |save_stack|@>;
+ end
+else confusion("curlevel"); {|unsave| is not used when |cur_group=bottom_level|}
+@:this can't happen curlevel}{\quad curlevel@>
+attr_list_cache:=cache_disabled;
+end;
+
+@ @<Clear off...@>=
+loop@+begin decr(save_ptr);
+ if save_type(save_ptr)=level_boundary then goto done;
+ p:=save_index(save_ptr);
+ if save_type(save_ptr)=insert_token then
+ @<Insert token |p| into \TeX's input@>
+ else begin if save_type(save_ptr)=restore_old_value then
+ begin l:=save_level(save_ptr); decr(save_ptr);
+ end
+ else save_stack[save_ptr]:=eqtb[undefined_control_sequence];
+ @<Store \(s)|save_stack[save_ptr]| in |eqtb[p]|, unless
+ |eqtb[p]| holds a global value@>;
+ end;
+ end;
+done: @!stat if tracing_groups>0 then group_trace(true);@+tats@;@/
+if grp_stack[in_open]=cur_boundary then group_warning;
+ {groups possibly not properly nested with files}
+cur_group:=save_level(save_ptr); cur_boundary:=save_index(save_ptr);
+decr(save_ptr)
+
+@ A global definition, which sets the level to |level_one|,
+@^global definitions@>
+will not be undone by |unsave|. If at least one global definition of
+|eqtb[p]| has been carried out within the group that just ended, the
+last such definition will therefore survive.
+
+@<Store \(s)|save...@>=
+if p<int_base then
+ if eq_level(p)=level_one then
+ begin eq_destroy(save_stack[save_ptr]); {destroy the saved value}
+ @!stat if tracing_restores>0 then restore_trace(p,"retaining");@+tats@;@/
+ end
+ else begin eq_destroy(eqtb[p]); {destroy the current value}
+ eqtb[p]:=save_stack[save_ptr]; {restore the saved value}
+ @!stat if tracing_restores>0 then restore_trace(p,"restoring");@+tats@;@/
+ end
+else if xeq_level[p]<>level_one then
+ begin eqtb[p]:=save_stack[save_ptr]; xeq_level[p]:=l;
+ @!stat if tracing_restores>0 then restore_trace(p,"restoring");@+tats@;@/
+ end
+else begin
+ @!stat if tracing_restores>0 then restore_trace(p,"retaining");@+tats@;@/
+ end
+
+@ @<Declare \eTeX\ procedures for tr...@>=
+@!stat procedure restore_trace(@!p:pointer;@!s:str_number);
+ {|eqtb[p]| has just been restored or retained}
+begin begin_diagnostic; print_char("{"); print(s); print_char(" ");
+show_eqtb(p); print_char("}");
+end_diagnostic(false);
+end;
+tats
+
+@ Most of the parameters kept in |eqtb| can be changed freely, but there's
+an exception: The magnification should not be used with two different
+values during any \TeX\ job, since a single magnification is applied to an
+entire run. The global variable |mag_set| is set to the current magnification
+whenever it becomes necessary to ``freeze'' it at a particular value.
+
+@<Glob...@>=
+@!mag_set:integer; {if nonzero, this magnification should be used henceforth}
+
+@ @<Set init...@>=
+mag_set:=0;
+
+@ The |prepare_mag| subroutine is called whenever \TeX\ wants to use |mag|
+for magnification.
+
+@p procedure prepare_mag;
+begin if (mag_set>0)and(mag<>mag_set) then
+ begin print_err("Incompatible magnification ("); print_int(mag);
+@.Incompatible magnification@>
+ print(");"); print_nl(" the previous value will be retained");
+ help2("I can handle only one magnification ratio per job. So I've")@/
+ ("reverted to the magnification you used earlier on this run.");@/
+ int_error(mag_set);
+ geq_word_define(int_base+mag_code,mag_set); {|mag:=mag_set|}
+ end;
+if (mag<=0)or(mag>32768) then
+ begin print_err("Illegal magnification has been changed to 1000");@/
+@.Illegal magnification...@>
+ help1("The magnification ratio must be between 1 and 32768.");
+ int_error(mag); geq_word_define(int_base+mag_code,1000);
+ end;
+mag_set:=mag;
+end;
+
+@* \[20] Token lists.
+A \TeX\ token is either a character or a control sequence, and it is
+@^token@>
+represented internally in one of two ways: (1)~A character whose ASCII
+code number is |c| and whose command code is |m| is represented as the
+number $2^{21}m+c$; the command code is in the range |1<=m<=14|. (2)~A control
+sequence whose |eqtb| address is |p| is represented as the number
+|cs_token_flag+p|. Here |cs_token_flag=@t$2^{25}-1$@>| is larger than
+$2^{21}m+c$, yet it is small enough that |cs_token_flag+p< max_halfword|;
+thus, a token fits comfortably in a halfword.
+
+A token |t| represents a |left_brace| command if and only if
+|t<left_brace_limit|; it represents a |right_brace| command if and only if
+we have |left_brace_limit<=t<right_brace_limit|; and it represents a |match| or
+|end_match| command if and only if |match_token<=t<=end_match_token|.
+The following definitions take care of these token-oriented constants
+and a few others.
+
+@d cs_token_flag==@"1FFFFFFF {amount added to the |eqtb| location in a
+ token that stands for a control sequence; is a multiple of~$2^{21}$, less~1}
+@d left_brace_token=@"200000 {$2^{21}\cdot|left_brace|$}
+@d left_brace_limit=@"400000 {$2^{21}\cdot(|left_brace|+1)$}
+@d right_brace_token=@"400000 {$2^{21}\cdot|right_brace|$}
+@d right_brace_limit=@"600000 {$2^{21}\cdot(|right_brace|+1)$}
+@d math_shift_token= @"600000 {$2^{21}\cdot|math_shift|$}
+@d tab_token=@"800000 {$2^{21}\cdot|tab_mark|$}
+@d out_param_token=@"A00000 {$2^{21}\cdot|out_param|$}
+@d space_token=@"1400020 {$2^{21}\cdot|spacer|+|" "|$}
+@d letter_token=@"1600000 {$2^{21}\cdot|letter|$}
+@d other_token=@"1800000 {$2^{21}\cdot|other_char|$}
+@d match_token=@"1A00000 {$2^{21}\cdot|match|$}
+@d end_match_token=@"1C00000 {$2^{21}\cdot|end_match|$}
+@d protected_token=@"1C00001 {$2^{21}\cdot|end_match|+1$}
+
+@ @<Check the ``constant''...@>=
+if cs_token_flag+undefined_control_sequence>max_halfword then bad:=21;
+
+@ A token list is a singly linked list of one-word nodes in |mem|, where
+each word contains a token and a link. Macro definitions, output-routine
+definitions, marks, \.{\\write} texts, and a few other things
+are remembered by \TeX\ in the form
+of token lists, usually preceded by a node with a reference count in its
+|token_ref_count| field. The token stored in location |p| is called
+|info(p)|.
+
+Three special commands appear in the token lists of macro definitions.
+When |m=match|, it means that \TeX\ should scan a parameter
+for the current macro; when |m=end_match|, it means that parameter
+matching should end and \TeX\ should start reading the macro text; and
+when |m=out_param|, it means that \TeX\ should insert parameter
+number |c| into the text at this point.
+
+The enclosing \.{\char'173} and \.{\char'175} characters of a macro
+definition are omitted, but the final right brace of an output routine
+is included at the end of its token list.
+
+Here is an example macro definition that illustrates these conventions.
+After \TeX\ processes the text
+$$\.{\\def\\mac a\#1\#2 \\b \{\#1\\-a \#\#1\#2 \#2\}}$$
+the definition of \.{\\mac} is represented as a token list containing
+$$\def\,{\hskip2pt}
+\vbox{\halign{\hfil#\hfil\cr
+(reference count), |letter|\,\.a, |match|\,\#, |match|\,\#, |spacer|\,\.\ ,
+\.{\\b}, |end_match|,\cr
+|out_param|\,1, \.{\\-}, |letter|\,\.a, |spacer|\,\.\ , |mac_param|\,\#,
+|other_char|\,\.1,\cr
+|out_param|\,2, |spacer|\,\.\ , |out_param|\,2.\cr}}$$
+The procedure |scan_toks| builds such token lists, and |macro_call|
+does the parameter matching.
+@^reference counts@>
+
+Examples such as
+$$\.{\\def\\m\{\\def\\m\{a\}\ b\}}$$
+explain why reference counts would be needed even if \TeX\ had no \.{\\let}
+operation: When the token list for \.{\\m} is being read, the redefinition of
+\.{\\m} changes the |eqtb| entry before the token list has been fully
+consumed, so we dare not simply destroy a token list when its
+control sequence is being redefined.
+
+If the parameter-matching part of a definition ends with `\.{\#\{}',
+the corresponding token list will have `\.\{' just before the `|end_match|'
+and also at the very end. The first `\.\{' is used to delimit the parameter; the
+second one keeps the first from disappearing.
+
+@ The procedure |show_token_list|, which prints a symbolic form of
+the token list that starts at a given node |p|, illustrates these
+conventions. The token list being displayed should not begin with a reference
+count. However, the procedure is intended to be robust, so that if the
+memory links are awry or if |p| is not really a pointer to a token list,
+nothing catastrophic will happen.
+
+An additional parameter |q| is also given; this parameter is either null
+or it points to a node in the token list where a certain magic computation
+takes place that will be explained later. (Basically, |q| is non-null when
+we are printing the two-line context information at the time of an error
+message; |q| marks the place corresponding to where the second line
+should begin.)
+
+For example, if |p| points to the node containing the first \.a in the
+token list above, then |show_token_list| will print the string
+$$\hbox{`\.{a\#1\#2\ \\b\ ->\#1\\-a\ \#\#1\#2\ \#2}';}$$
+and if |q| points to the node containing the second \.a,
+the magic computation will be performed just before the second \.a is printed.
+
+The generation will stop, and `\.{\\ETC.}' will be printed, if the length
+of printing exceeds a given limit~|l|. Anomalous entries are printed in the
+form of control sequences that are not followed by a blank space, e.g.,
+`\.{\\BAD.}'; this cannot be confused with actual control sequences because
+a real control sequence named \.{BAD} would come out `\.{\\BAD\ }'.
+
+@<Declare the procedure called |show_token_list|@>=
+procedure show_token_list(@!p,@!q:integer;@!l:integer);
+label exit;
+var m,@!c:integer; {pieces of a token}
+@!match_chr:ASCII_code; {character used in a `|match|'}
+@!n:ASCII_code; {the highest parameter number, as an ASCII digit}
+begin match_chr:="#"; n:="0"; tally:=0;
+while (p<>null) and (tally<l) do
+ begin if p=q then @<Do magic computation@>;
+ @<Display token |p|, and |return| if there are problems@>;
+ p:=link(p);
+ end;
+if p<>null then print_esc("ETC.");
+@.ETC@>
+exit:
+end;
+
+@ @<Display token |p|...@>=
+if (p<fix_mem_min) or (p>fix_mem_end) then
+ begin print_esc("CLOBBERED."); return;
+@.CLOBBERED@>
+ end;
+if info(p)>=cs_token_flag then begin
+ if not ((inhibit_par_tokens) and (info(p)=par_token)) then
+ print_cs(info(p)-cs_token_flag);
+ end
+else begin m:=info(p) div string_offset; c:=info(p) mod string_offset;
+ if info(p)<0 then print_esc("BAD.")
+@.BAD@>
+ else @<Display the token $(|m|,|c|)$@>;
+ end
+
+@ The procedure usually ``learns'' the character code used for macro
+parameters by seeing one in a |match| command before it runs into any
+|out_param| commands.
+
+@<Display the token ...@>=
+case m of
+left_brace,right_brace,math_shift,tab_mark,sup_mark,sub_mark,spacer,
+ letter,other_char: print(c);
+mac_param: begin print(c); print(c);
+ end;
+out_param: begin print(match_chr);
+ if c<=9 then print_char(c+"0")
+ else begin print_char("!"); return;
+ end;
+ end;
+match: begin match_chr:=c; print(c); incr(n); print_char(n);
+ if n>"9" then return;
+ end;
+end_match: if c=0 then print("->");
+@.->@>
+othercases print_esc("BAD.")
+@.BAD@>
+endcases
+
+@ Here's the way we sometimes want to display a token list, given a pointer
+to its reference count; the pointer may be null.
+
+@p procedure token_show(@!p:pointer);
+begin if p<>null then show_token_list(link(p),null,10000000);
+end;
+
+@ The |print_meaning| subroutine displays |cur_cmd| and |cur_chr| in
+symbolic form, including the expansion of a macro or mark.
+
+@p procedure print_meaning;
+begin print_cmd_chr(cur_cmd,cur_chr);
+if cur_cmd>=call then
+ begin print_char(":"); print_ln; token_show(cur_chr);
+ end
+else @<Show the meaning of a mark node@>;
+end;
+
+@* \[21] Introduction to the syntactic routines.
+Let's pause a moment now and try to look at the Big Picture.
+The \TeX\ program consists of three main parts: syntactic routines,
+semantic routines, and output routines. The chief purpose of the
+syntactic routines is to deliver the user's input to the semantic routines,
+one token at a time. The semantic routines act as an interpreter
+responding to these tokens, which may be regarded as commands. And the
+output routines are periodically called on to convert box-and-glue
+lists into a compact set of instructions that will be sent
+to a typesetter. We have discussed the basic data structures and utility
+routines of \TeX, so we are good and ready to plunge into the real activity by
+considering the syntactic routines.
+
+Our current goal is to come to grips with the |get_next| procedure,
+which is the keystone of \TeX's input mechanism. Each call of |get_next|
+sets the value of three variables |cur_cmd|, |cur_chr|, and |cur_cs|,
+representing the next input token.
+$$\vbox{\halign{#\hfil\cr
+ \hbox{|cur_cmd| denotes a command code from the long list of codes
+ given above;}\cr
+ \hbox{|cur_chr| denotes a character code or other modifier of the command
+ code;}\cr
+ \hbox{|cur_cs| is the |eqtb| location of the current control sequence,}\cr
+ \hbox{\qquad if the current token was a control sequence,
+ otherwise it's zero.}\cr}}$$
+Underlying this external behavior of |get_next| is all the machinery
+necessary to convert from character files to tokens. At a given time we
+may be only partially finished with the reading of several files (for
+which \.{\\input} was specified), and partially finished with the expansion
+of some user-defined macros and/or some macro parameters, and partially
+finished with the generation of some text in a template for \.{\\halign},
+and so on. When reading a character file, special characters must be
+classified as math delimiters, etc.; comments and extra blank spaces must
+be removed, paragraphs must be recognized, and control sequences must be
+found in the hash table. Furthermore there are occasions in which the
+scanning routines have looked ahead for a word like `\.{plus}' but only
+part of that word was found, hence a few characters must be put back
+into the input and scanned again.
+
+To handle these situations, which might all be present simultaneously,
+\TeX\ uses various stacks that hold information about the incomplete
+activities, and there is a finite state control for each level of the
+input mechanism. These stacks record the current state of an implicitly
+recursive process, but the |get_next| procedure is not recursive.
+Therefore it will not be difficult to translate these algorithms into
+low-level languages that do not support recursion.
+
+@<Glob...@>=
+@!cur_cmd: eight_bits; {current command set by |get_next|}
+@!cur_chr: halfword; {operand of current command}
+@!cur_cs: pointer; {control sequence found here, zero if none found}
+@!cur_tok: halfword; {packed representative of |cur_cmd| and |cur_chr|}
+
+@ The |print_cmd_chr| routine prints a symbolic interpretation of a
+command code and its modifier. This is used in certain `\.{You can\'t}'
+error messages, and in the implementation of diagnostic routines like
+\.{\\show}.
+
+The body of |print_cmd_chr| is a rather tedious listing of print
+commands, and most of it is essentially an inverse to the |primitive|
+routine that enters a \TeX\ primitive into |eqtb|. Therefore much of
+this procedure appears elsewhere in the program,
+together with the corresponding |primitive| calls.
+
+@d chr_cmd(#)==begin print(#); print(chr_code);
+ end
+
+@<Declare the procedure called |print_cmd_chr|@>=
+procedure print_cmd_chr(@!cmd:quarterword;@!chr_code:halfword);
+var n:integer; {temp variable}
+begin case cmd of
+left_brace: chr_cmd("begin-group character ");
+right_brace: chr_cmd("end-group character ");
+math_shift: chr_cmd("math shift character ");
+mac_param: chr_cmd("macro parameter character ");
+sup_mark: chr_cmd("superscript character ");
+sub_mark: chr_cmd("subscript character ");
+endv: print("end of alignment template");
+spacer: chr_cmd("blank space ");
+letter: chr_cmd("the letter ");
+other_char: chr_cmd("the character ");
+@t\4@>@<Cases of |print_cmd_chr| for symbolic printing of primitives@>@/
+othercases print("[unknown command code!]")
+endcases;
+end;
+
+@ Here is a procedure that displays the current command.
+
+@p procedure show_cur_cmd_chr;
+var n:integer; {level of \.{\\if...\\fi} nesting}
+@!l:integer; {line where \.{\\if} started}
+@!p:pointer;
+begin begin_diagnostic; print_nl("{");
+if mode<>shown_mode then
+ begin print_mode(mode); print(": "); shown_mode:=mode;
+ end;
+print_cmd_chr(cur_cmd,cur_chr);
+if tracing_ifs>0 then
+ if cur_cmd>=if_test then if cur_cmd<=fi_or_else then
+ begin print(": ");
+ if cur_cmd=fi_or_else then
+ begin print_cmd_chr(if_test,cur_if); print_char(" ");
+ n:=0; l:=if_line;
+ end
+ else begin n:=1; l:=line;
+ end;
+ p:=cond_ptr;
+ while p<>null do
+ begin incr(n); p:=vlink(p);
+ end;
+ print("(level "); print_int(n); print_char(")"); print_if_line(l);
+ end;
+print_char("}");
+end_diagnostic(false);
+end;
+
+@* \[22] Input stacks and states.
+This implementation of
+\TeX\ uses two different conventions for representing sequential stacks.
+@^stack conventions@>@^conventions for representing stacks@>
+
+\yskip\hangg 1) If there is frequent access to the top entry, and if the
+stack is essentially never empty, then the top entry is kept in a global
+variable (even better would be a machine register), and the other entries
+appear in the array $\\{stack}[0\to(\\{ptr}-1)]$. For example, the
+semantic stack described above is handled this way, and so is the input
+stack that we are about to study.
+
+\yskip\hangg 2) If there is infrequent top access, the entire stack contents
+are in the array $\\{stack}[0\to(\\{ptr}-1)]$. For example, the |save_stack|
+is treated this way, as we have seen.
+
+\yskip\noindent
+The state of \TeX's input mechanism appears in the input stack, whose
+entries are records with six fields, called |state|, |index|, |start|, |loc|,
+|limit|, and |name|. This stack is maintained with
+convention~(1), so it is declared in the following way:
+
+@<Types...@>=
+@!in_state_record = record
+ @!state_field, @!index_field: quarterword;
+ @!start_field,@!loc_field, @!limit_field, @!name_field,
+ @!ocp_lstack_field: halfword; {used for omega translation processes}
+ @!ocp_no_field: halfword; {used for omega translation processes}
+ @!nofilter_field: boolean; {used by token filtering}
+ end;
+
+@ @<Glob...@>=
+@!input_stack : array[0..stack_size] of in_state_record;
+@!input_ptr : 0..stack_size; {first unused location of |input_stack|}
+@!max_in_stack: 0..stack_size; {largest value of |input_ptr| when pushing}
+@!cur_input : in_state_record;
+ {the ``top'' input state, according to convention (1)}
+
+@ We've already defined the special variable |loc==cur_input.loc_field|
+in our discussion of basic input-output routines. The other components of
+|cur_input| are defined in the same way:
+
+@d state==cur_input.state_field {current scanner state}
+@d index==cur_input.index_field {reference for buffer information}
+@d start==cur_input.start_field {starting position in |buffer|}
+@d limit==cur_input.limit_field {end of current line in |buffer|}
+@d nofilter==cur_input.nofilter_field {is token filtering explicitly disallowed?}
+@d name==cur_input.name_field {name of the current file}
+@d current_ocp_lstack==cur_input.ocp_lstack_field {name of the current ocp}
+@d current_ocp_no==cur_input.ocp_no_field {name of the current ocp}
+
+@ Let's look more closely now at the control variables
+(|state|,~|index|,~|start|,~|loc|,~|limit|,~|name|),
+assuming that \TeX\ is reading a line of characters that have been input
+from some file or from the user's terminal. There is an array called
+|buffer| that acts as a stack of all lines of characters that are
+currently being read from files, including all lines on subsidiary
+levels of the input stack that are not yet completed. \TeX\ will return to
+the other lines when it is finished with the present input file.
+
+(Incidentally, on a machine with byte-oriented addressing, it might be
+appropriate to combine |buffer| with the |str_pool| array,
+letting the buffer entries grow downward from the top of the string pool
+and checking that these two tables don't bump into each other.)
+
+The line we are currently working on begins in position |start| of the
+buffer; the next character we are about to read is |buffer[loc]|; and
+|limit| is the location of the last character present. If |loc>limit|,
+the line has been completely read. Usually |buffer[limit]| is the
+|end_line_char|, denoting the end of a line, but this is not
+true if the current line is an insertion that was entered on the user's
+terminal in response to an error message.
+
+The |name| variable is a string number that designates the name of
+the current file, if we are reading a text file. It is zero if we
+are reading from the terminal; it is |n+1| if we are reading from
+input stream |n|, where |0<=n<=16|. (Input stream 16 stands for
+an invalid stream number; in such cases the input is actually from
+the terminal, under control of the procedure |read_toks|.)
+Finally |18<=name<=20| indicates that we are reading a pseudo file
+created by the \.{\\scantokens} or \.{\\scantextokens} command.
+
+The |state| variable has one of three values, when we are scanning such
+files:
+$$\baselineskip 15pt\vbox{\halign{#\hfil\cr
+1) |state=mid_line| is the normal state.\cr
+2) |state=skip_blanks| is like |mid_line|, but blanks are ignored.\cr
+3) |state=new_line| is the state at the beginning of a line.\cr}}$$
+These state values are assigned numeric codes so that if we add the state
+code to the next character's command code, we get distinct values. For
+example, `|mid_line+spacer|' stands for the case that a blank
+space character occurs in the middle of a line when it is not being
+ignored; after this case is processed, the next value of |state| will
+be |skip_blanks|.
+
+@d mid_line=1 {|state| code when scanning a line of characters}
+@d skip_blanks=2+max_char_code {|state| code when ignoring blanks}
+@d new_line=3+max_char_code+max_char_code {|state| code at start of line}
+
+@ Additional information about the current line is available via the
+|index| variable, which counts how many lines of characters are present
+in the buffer below the current level. We have |index=0| when reading
+from the terminal and prompting the user for each line; then if the user types,
+e.g., `\.{\\input paper}', we will have |index=1| while reading
+the file \.{paper.tex}. However, it does not follow that |index| is the
+same as the input stack pointer, since many of the levels on the input
+stack may come from token lists. For example, the instruction `\.{\\input
+paper}' might occur in a token list.
+
+The global variable |in_open| is equal to the |index|
+value of the highest non-token-list level. Thus, the number of partially read
+lines in the buffer is |in_open+1|, and we have |in_open=index|
+when we are not reading a token list.
+
+If we are not currently reading from the terminal, or from an input
+stream, we are reading from the file variable |input_file[index]|. We use
+the notation |terminal_input| as a convenient abbreviation for |name=0|,
+and |cur_file| as an abbreviation for |input_file[index]|.
+
+The global variable |line| contains the line number in the topmost
+open file, for use in error messages. If we are not reading from
+the terminal, |line_stack[index]| holds the line number for the
+enclosing level, so that |line| can be restored when the current
+file has been read. Line numbers should never be negative, since the
+negative of the current line number is used to identify the user's output
+routine in the |mode_line| field of the semantic nest entries.
+
+If more information about the input state is needed, it can be
+included in small arrays like those shown here. For example,
+the current page or segment number in the input file might be
+put into a variable |@!page|, maintained for enclosing levels in
+`\ignorespaces|@!page_stack:array[1..max_in_open] of integer|\unskip'
+by analogy with |line_stack|.
+@^system dependencies@>
+
+@d terminal_input==(name=0) {are we reading from the terminal?}
+@d cur_file==input_file[index] {the current |alpha_file| variable}
+
+@<Glob...@>=
+@!in_open : 0..max_in_open; {the number of lines in the buffer, less one}
+@!open_parens : 0..max_in_open; {the number of open text files}
+@!input_file : array[1..max_in_open] of alpha_file;
+@!line : integer; {current line number in the current source file}
+@!line_stack : array[1..max_in_open] of integer;
+
+@ Users of \TeX\ sometimes forget to balance left and right braces properly,
+and one of the ways \TeX\ tries to spot such errors is by considering an
+input file as broken into subfiles by control sequences that
+are declared to be \.{\\outer}.
+
+A variable called |scanner_status| tells \TeX\ whether or not to complain
+when a subfile ends. This variable has six possible values:
+
+\yskip\hang|normal|, means that a subfile can safely end here without incident.
+
+\yskip\hang|skipping|, means that a subfile can safely end here, but not a file,
+because we're reading past some conditional text that was not selected.
+
+\yskip\hang|defining|, means that a subfile shouldn't end now because a
+macro is being defined.
+
+\yskip\hang|matching|, means that a subfile shouldn't end now because a
+macro is being used and we are searching for the end of its arguments.
+
+\yskip\hang|aligning|, means that a subfile shouldn't end now because we are
+not finished with the preamble of an \.{\\halign} or \.{\\valign}.
+
+\yskip\hang|absorbing|, means that a subfile shouldn't end now because we are
+reading a balanced token list for \.{\\message}, \.{\\write}, etc.
+
+\yskip\noindent
+If the |scanner_status| is not |normal|, the variable |warning_index| points
+to the |eqtb| location for the relevant control sequence name to print
+in an error message.
+
+@d skipping=1 {|scanner_status| when passing conditional text}
+@d defining=2 {|scanner_status| when reading a macro definition}
+@d matching=3 {|scanner_status| when reading macro arguments}
+@d aligning=4 {|scanner_status| when reading an alignment preamble}
+@d absorbing=5 {|scanner_status| when reading a balanced text}
+
+@<Glob...@>=
+@!scanner_status : normal..absorbing; {can a subfile end now?}
+@!warning_index : pointer; {identifier relevant to non-|normal| scanner status}
+@!def_ref : pointer; {reference count of token list being defined}
+
+@ Here is a procedure that uses |scanner_status| to print a warning message
+when a subfile has ended, and at certain other crucial times:
+
+@<Declare the procedure called |runaway|@>=
+procedure runaway;
+var p:pointer; {head of runaway list}
+begin p:=null;
+ if scanner_status>skipping then
+ begin print_nl("Runaway ");
+@.Runaway...@>
+ case scanner_status of
+ defining: begin print("definition"); p:=def_ref;
+ end;
+ matching: begin print("argument"); p:=temp_token_head;
+ end;
+ aligning: begin print("preamble"); p:=hold_token_head;
+ end;
+ absorbing: begin print("text"); p:=def_ref;
+ end;
+ end; {there are no other cases}
+ print_char("?");print_ln; show_token_list(link(p),null,error_line-10);
+ end;
+end;
+
+@ However, all this discussion about input state really applies only to the
+case that we are inputting from a file. There is another important case,
+namely when we are currently getting input from a token list. In this case
+|state=token_list|, and the conventions about the other state variables
+are different:
+
+\yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
+the node that will be read next. If |loc=null|, the token list has been
+fully read.
+
+\yskip\hang|start| points to the first node of the token list; this node
+may or may not contain a reference count, depending on the type of token
+list involved.
+
+\yskip\hang|token_type|, which takes the place of |index| in the
+discussion above, is a code number that explains what kind of token list
+is being scanned.
+
+\yskip\hang|name| points to the |eqtb| address of the control sequence
+being expanded, if the current token list is a macro.
+
+\yskip\hang|param_start|, which takes the place of |limit|, tells where
+the parameters of the current macro begin in the |param_stack|, if the
+current token list is a macro.
+
+\yskip\noindent The |token_type| can take several values, depending on
+where the current token list came from:
+
+\yskip\hang|parameter|, if a parameter is being scanned;
+
+\hang|u_template|, if the \<u_j> part of an alignment
+template is being scanned;
+
+\hang|v_template|, if the \<v_j> part of an alignment
+template is being scanned;
+
+\hang|backed_up|, if the token list being scanned has been inserted as
+`to be read again'.
+
+\hang|inserted|, if the token list being scanned has been inserted as
+the text expansion of a \.{\\count} or similar variable;
+
+\hang|macro|, if a user-defined control sequence is being scanned;
+
+\hang|output_text|, if an \.{\\output} routine is being scanned;
+
+\hang|every_par_text|, if the text of \.{\\everypar} is being scanned;
+
+\hang|every_math_text|, if the text of \.{\\everymath} is being scanned;
+
+\hang|every_display_text|, if the text of \.{\\everydisplay} is being scanned;
+
+\hang|every_hbox_text|, if the text of \.{\\everyhbox} is being scanned;
+
+\hang|every_vbox_text|, if the text of \.{\\everyvbox} is being scanned;
+
+\hang|every_job_text|, if the text of \.{\\everyjob} is being scanned;
+
+\hang|every_cr_text|, if the text of \.{\\everycr} is being scanned;
+
+\hang|mark_text|, if the text of a \.{\\mark} is being scanned;
+
+\hang|write_text|, if the text of a \.{\\write} is being scanned.
+
+\yskip\noindent
+The codes for |output_text|, |every_par_text|, etc., are equal to a constant
+plus the corresponding codes for token list parameters |output_routine_loc|,
+|every_par_loc|, etc. The token list begins with a reference count if and
+only if |token_type>=macro|.
+@^reference counts@>
+
+Since \eTeX's additional token list parameters precede |toks_base|, the
+corresponding token types must precede |write_text|.
+
+@d token_list=0 {|state| code when scanning a token list}
+@d token_type==index {type of current token list}
+@d param_start==limit {base of macro parameters in |param_stack|}
+@d parameter=0 {|token_type| code for parameter}
+@d u_template=1 {|token_type| code for \<u_j> template}
+@d v_template=2 {|token_type| code for \<v_j> template}
+@d backed_up=3 {|token_type| code for text to be reread}
+@d inserted=4 {|token_type| code for inserted texts}
+@d macro=5 {|token_type| code for defined control sequences}
+@d output_text=6 {|token_type| code for output routines}
+@d every_par_text=7 {|token_type| code for \.{\\everypar}}
+@d every_math_text=8 {|token_type| code for \.{\\everymath}}
+@d every_display_text=9 {|token_type| code for \.{\\everydisplay}}
+@d every_hbox_text=10 {|token_type| code for \.{\\everyhbox}}
+@d every_vbox_text=11 {|token_type| code for \.{\\everyvbox}}
+@d every_job_text=12 {|token_type| code for \.{\\everyjob}}
+@d every_cr_text=13 {|token_type| code for \.{\\everycr}}
+@d mark_text=14 {|token_type| code for \.{\\topmark}, etc.}
+@#
+@d eTeX_text_offset=output_routine_loc-output_text
+@d every_eof_text=every_eof_loc-eTeX_text_offset
+ {|token_type| code for \.{\\everyeof}}
+@#
+@d write_text=etex_toks-eTeX_text_offset {|token_type| code for \.{\\write}}
+
+@ The |param_stack| is an auxiliary array used to hold pointers to the token
+lists for parameters at the current level and subsidiary levels of input.
+This stack is maintained with convention (2), and it grows at a different
+rate from the others.
+
+@<Glob...@>=
+@!param_stack:array [0..param_size] of pointer;
+ {token list pointers for parameters}
+@!param_ptr:0..param_size; {first unused entry in |param_stack|}
+@!max_param_stack:integer;
+ {largest value of |param_ptr|, will be |<=param_size+9|}
+
+@ The input routines must also interact with the processing of
+\.{\\halign} and \.{\\valign}, since the appearance of tab marks and
+\.{\\cr} in certain places is supposed to trigger the beginning of special
+\<v_j> template text in the scanner. This magic is accomplished by an
+|align_state| variable that is increased by~1 when a `\.{\char'173}' is
+scanned and decreased by~1 when a `\.{\char'175}' is scanned. The |align_state|
+is nonzero during the \<u_j> template, after which it is set to zero; the
+\<v_j> template begins when a tab mark or \.{\\cr} occurs at a time that
+|align_state=0|.
+
+@<Glob...@>=
+@!align_state:integer; {group level with respect to current alignment}
+
+@ Thus, the ``current input state'' can be very complicated indeed; there
+can be many levels and each level can arise in a variety of ways. The
+|show_context| procedure, which is used by \TeX's error-reporting routine to
+print out the current input state on all levels down to the most recent
+line of characters from an input file, illustrates most of these conventions.
+The global variable |base_ptr| contains the lowest level that was
+displayed by this procedure.
+
+@<Glob...@>=
+@!base_ptr:0..stack_size; {shallowest level shown by |show_context|}
+
+@ The status at each level is indicated by printing two lines, where the first
+line indicates what was read so far and the second line shows what remains
+to be read. The context is cropped, if necessary, so that the first line
+contains at most |half_error_line| characters, and the second contains
+at most |error_line|. Non-current input levels whose |token_type| is
+`|backed_up|' are shown only if they have not been fully read.
+
+@p procedure show_context; {prints where the scanner is}
+label done;
+var old_setting:0..max_selector; {saved |selector| setting}
+@!nn:integer; {number of contexts shown so far, less one}
+@!bottom_line:boolean; {have we reached the final context to be shown?}
+@<Local variables for formatting calculations@>@/
+begin base_ptr:=input_ptr; input_stack[base_ptr]:=cur_input;
+ {store current state}
+nn:=-1; bottom_line:=false;
+loop@+begin cur_input:=input_stack[base_ptr]; {enter into the context}
+ if (state<>token_list) then
+ if (name>21) or (base_ptr=0) then bottom_line:=true;
+ if (base_ptr=input_ptr)or bottom_line or(nn<error_context_lines) then
+ @<Display the current context@>
+ else if nn=error_context_lines then
+ begin print_nl("..."); incr(nn); {omitted if |error_context_lines<0|}
+ end;
+ if bottom_line then goto done;
+ decr(base_ptr);
+ end;
+done: cur_input:=input_stack[input_ptr]; {restore original state}
+end;
+
+@ @<Display the current context@>=
+begin if (base_ptr=input_ptr) or (state<>token_list) or
+ (token_type<>backed_up) or (loc<>null) then
+ {we omit backed-up token lists that have already been read}
+ begin tally:=0; {get ready to count characters}
+ old_setting:=selector;
+ if current_ocp_lstack>0 then
+ begin print_nl("OCP stack "); print_scaled(current_ocp_lstack);
+ print(" entry "); print_int(current_ocp_no); print(":");
+ @<Pseudoprint the line@>;
+ end
+ else if state<>token_list then
+ begin @<Print location of current line@>;
+ @<Pseudoprint the line@>;
+ end
+ else begin @<Print type of token list@>;
+ @<Pseudoprint the token list@>;
+ end;
+ selector:=old_setting; {stop pseudoprinting}
+ @<Print two lines using the tricky pseudoprinted information@>;
+ incr(nn);
+ end;
+end
+
+@ This routine should be changed, if necessary, to give the best possible
+indication of where the current line resides in the input file.
+For example, on some systems it is best to print both a page and line number.
+@^system dependencies@>
+
+@<Print location of current line@>=
+if name<=17 then
+ if terminal_input then
+ if base_ptr=0 then print_nl("<*>") else print_nl("<insert> ")
+ else begin print_nl("<read ");
+ if name=17 then print_char("*")@+else print_int(name-1);
+@.*\relax@>
+ print_char(">");
+ end
+else if index<>in_open then {input from a pseudo file}
+ begin print_nl("l."); print_int(line_stack[index+1]);
+ end
+else begin print_nl("l."); print_int(line);
+ end;
+print_char(" ")
+
+@ @<Print type of token list@>=
+case token_type of
+parameter: print_nl("<argument> ");
+u_template,v_template: print_nl("<template> ");
+backed_up: if loc=null then print_nl("<recently read> ")
+ else print_nl("<to be read again> ");
+inserted: print_nl("<inserted text> ");
+macro: begin print_ln; print_cs(name);
+ end;
+output_text: print_nl("<output> ");
+every_par_text: print_nl("<everypar> ");
+every_math_text: print_nl("<everymath> ");
+every_display_text: print_nl("<everydisplay> ");
+every_hbox_text: print_nl("<everyhbox> ");
+every_vbox_text: print_nl("<everyvbox> ");
+every_job_text: print_nl("<everyjob> ");
+every_cr_text: print_nl("<everycr> ");
+mark_text: print_nl("<mark> ");
+every_eof_text: print_nl("<everyeof> ");
+write_text: print_nl("<write> ");
+othercases print_nl("?") {this should never happen}
+endcases
+
+@ Here it is necessary to explain a little trick. We don't want to store a long
+string that corresponds to a token list, because that string might take up
+lots of memory; and we are printing during a time when an error message is
+being given, so we dare not do anything that might overflow one of \TeX's
+tables. So `pseudoprinting' is the answer: We enter a mode of printing
+that stores characters into a buffer of length |error_line|, where character
+$k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
+|k<trick_count|, otherwise character |k| is dropped. Initially we set
+|tally:=0| and |trick_count:=1000000|; then when we reach the
+point where transition from line 1 to line 2 should occur, we
+set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
+tally+1+error_line-half_error_line)|. At the end of the
+pseudoprinting, the values of |first_count|, |tally|, and
+|trick_count| give us all the information we need to print the two lines,
+and all of the necessary text is in |trick_buf|.
+
+Namely, let |l| be the length of the descriptive information that appears
+on the first line. The length of the context information gathered for that
+line is |k=first_count|, and the length of the context information
+gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
+where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
+descriptive information on line~1, and set |n:=l+k|; here |n| is the
+length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
+and print `\.{...}' followed by
+$$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
+where subscripts of |trick_buf| are circular modulo |error_line|. The
+second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
+unless |n+m>error_line|; in the latter case, further cropping is done.
+This is easier to program than to explain.
+
+@<Local variables for formatting...@>=
+@!i:0..buf_size; {index into |buffer|}
+@!j:0..buf_size; {end of current line in |buffer|}
+@!l:0..half_error_line; {length of descriptive information on line 1}
+@!m:integer; {context information gathered for line 2}
+@!n:0..error_line; {length of line 1}
+@!p: integer; {starting or ending place in |trick_buf|}
+@!q: integer; {temporary index}
+
+@ The following code sets up the print routines so that they will gather
+the desired information.
+
+@d begin_pseudoprint==
+ begin l:=tally; tally:=0; selector:=pseudo;
+ trick_count:=1000000;
+ end
+@d set_trick_count==
+ begin first_count:=tally;
+ trick_count:=tally+1+error_line-half_error_line;
+ if trick_count<error_line then trick_count:=error_line;
+ end
+
+@ And the following code uses the information after it has been gathered.
+
+@<Print two lines using the tricky pseudoprinted information@>=
+if trick_count=1000000 then set_trick_count;
+ {|set_trick_count| must be performed}
+if tally<trick_count then m:=tally-first_count
+else m:=trick_count-first_count; {context on line 2}
+if l+first_count<=half_error_line then
+ begin p:=0; n:=l+first_count;
+ end
+else begin print("..."); p:=l+first_count-half_error_line+3;
+ n:=half_error_line;
+ end;
+for q:=p to first_count-1 do print_char(trick_buf[q mod error_line]);
+print_ln;
+for q:=1 to n do print_char(" "); {print |n| spaces to begin line~2}
+if m+n<=error_line then p:=first_count+m else p:=first_count+(error_line-n-3);
+for q:=first_count to p-1 do print_char(trick_buf[q mod error_line]);
+if m+n>error_line then print("...")
+
+@ But the trick is distracting us from our current goal, which is to
+understand the input state. So let's concentrate on the data structures that
+are being pseudoprinted as we finish up the |show_context| procedure.
+
+@<Pseudoprint the line@>=
+begin_pseudoprint;
+if buffer[limit]=end_line_char then j:=limit
+else j:=limit+1; {determine the effective end of the line}
+if j>0 then for i:=start to j-1 do
+ begin if i=loc then set_trick_count;
+ print_char(buffer[i]);
+ end
+
+@ @<Pseudoprint the token list@>=
+begin_pseudoprint;
+if token_type<macro then show_token_list(start,loc,100000)
+else show_token_list(link(start),loc,100000) {avoid reference count}
+
+@ Here is the missing piece of |show_token_list| that is activated when the
+token beginning line~2 is about to be shown:
+
+@<Do magic computation@>=set_trick_count
+
+@* \[23] Maintaining the input stacks.
+The following subroutines change the input status in commonly needed ways.
+
+First comes |push_input|, which stores the current state and creates a
+new level (having, initially, the same properties as the old).
+
+@d push_input==@t@> {enter a new input level, save the old}
+ begin if input_ptr>max_in_stack then
+ begin max_in_stack:=input_ptr;
+ if input_ptr=stack_size then overflow("input stack size",stack_size);
+@:TeX capacity exceeded input stack size}{\quad input stack size@>
+ end;
+ input_stack[input_ptr]:=cur_input; {stack the record}
+ nofilter:=false;
+ incr(input_ptr);
+ end
+
+@ And of course what goes up must come down.
+
+@d pop_input==@t@> {leave an input level, re-enter the old}
+ begin decr(input_ptr); cur_input:=input_stack[input_ptr];
+ end
+
+@ Here is a procedure that starts a new level of token-list input, given
+a token list |p| and its type |t|. If |t=macro|, the calling routine should
+set |name| and |loc|.
+
+@d back_list(#)==begin_token_list(#,backed_up) {backs up a simple token list}
+@d ins_list(#)==begin_token_list(#,inserted) {inserts a simple token list}
+
+@p procedure begin_token_list(@!p:pointer;@!t:quarterword);
+begin push_input; state:=token_list; start:=p; token_type:=t;
+if t>=macro then {the token list starts with a reference count}
+ begin add_token_ref(p);
+ if t=macro then param_start:=param_ptr
+ else begin loc:=link(p);
+ if tracing_macros>1 then
+ begin begin_diagnostic; print_nl("");
+ case t of
+ mark_text:print_esc("mark");
+ write_text:print_esc("write");
+ othercases print_cmd_chr(assign_toks,t-output_text+output_routine_loc)
+ endcases;@/
+ print("->"); token_show(p); end_diagnostic(false);
+ end;
+ end;
+ end
+else loc:=p;
+end;
+
+@ When a token list has been fully scanned, the following computations
+should be done as we leave that level of input. The |token_type| tends
+to be equal to either |backed_up| or |inserted| about 2/3 of the time.
+@^inner loop@>
+
+@p procedure end_token_list; {leave a token-list input level}
+begin if token_type>=backed_up then {token list to be deleted}
+ begin if token_type<=inserted then flush_list(start)
+ else begin delete_token_ref(start); {update reference count}
+ if token_type=macro then {parameters must be flushed}
+ while param_ptr>param_start do
+ begin decr(param_ptr);
+ flush_list(param_stack[param_ptr]);
+ end;
+ end;
+ end
+else if token_type=u_template then
+ if align_state>500000 then align_state:=0
+ else fatal_error("(interwoven alignment preambles are not allowed)");
+@.interwoven alignment preambles...@>
+pop_input;
+check_interrupt;
+end;
+
+@ Sometimes \TeX\ has read too far and wants to ``unscan'' what it has
+seen. The |back_input| procedure takes care of this by putting the token
+just scanned back into the input stream, ready to be read again. This
+procedure can be used only if |cur_tok| represents the token to be
+replaced. Some applications of \TeX\ use this procedure a lot,
+so it has been slightly optimized for speed.
+@^inner loop@>
+
+@p procedure back_input; {undoes one token of input}
+var p:pointer; {a token list of length one}
+begin while (state=token_list)and(loc=null)and(token_type<>v_template) do
+ end_token_list; {conserve stack space}
+p:=get_avail; info(p):=cur_tok;
+if cur_tok<right_brace_limit then
+ if cur_tok<left_brace_limit then decr(align_state)
+ else incr(align_state);
+push_input; state:=token_list; start:=p; token_type:=backed_up;
+loc:=p; {that was |back_list(p)|, without procedure overhead}
+end;
+
+@ @<Insert token |p| into \TeX's input@>=
+begin t:=cur_tok; cur_tok:=p;
+if a then
+ begin p:=get_avail; info(p):=cur_tok; link(p):=loc; loc:=p; start:=p;
+ if cur_tok<right_brace_limit then
+ if cur_tok<left_brace_limit then decr(align_state)
+ else incr(align_state);
+ end
+else begin back_input; a:=1; { etex is always on }
+ end;
+cur_tok:=t;
+end
+
+@ The |back_error| routine is used when we want to replace an offending token
+just before issuing an error message. This routine, like |back_input|,
+requires that |cur_tok| has been set. We disable interrupts during the
+call of |back_input| so that the help message won't be lost.
+
+@p procedure back_error; {back up one token and call |error|}
+begin OK_to_interrupt:=false; back_input; OK_to_interrupt:=true; error;
+end;
+@#
+procedure ins_error; {back up one inserted token and call |error|}
+begin OK_to_interrupt:=false; back_input; token_type:=inserted;
+OK_to_interrupt:=true; error;
+end;
+
+@ The |begin_file_reading| procedure starts a new level of input for lines
+of characters to be read from a file, or as an insertion from the
+terminal. It does not take care of opening the file, nor does it set |loc|
+or |limit| or |line|.
+@^system dependencies@>
+
+@p procedure begin_file_reading;
+begin if in_open=max_in_open then overflow("text input levels",max_in_open);
+@:TeX capacity exceeded text input levels}{\quad text input levels@>
+if first=buf_size then check_buffer_overflow(first);
+@:TeX capacity exceeded buffer size}{\quad buffer size@>
+incr(in_open); push_input; index:=in_open;
+eof_seen[index]:=false;
+grp_stack[index]:=cur_boundary; if_stack[index]:=cond_ptr;
+line_stack[index]:=line; start:=first; state:=mid_line;
+name:=0; {|terminal_input| is now |true|}
+end;
+
+@ Conversely, the variables must be downdated when such a level of input
+is finished:
+
+@p procedure end_file_reading;
+begin first:=start; line:=line_stack[index];
+if (name>=18)and(name<=20) then pseudo_close else
+if name=21 then luacstring_close(index) else
+if name>17 then lua_a_close_in(cur_file,0); {forget it}
+pop_input; decr(in_open);
+end;
+
+@ In order to keep the stack from overflowing during a long sequence of
+inserted `\.{\\show}' commands, the following routine removes completed
+error-inserted lines from memory.
+
+@p procedure clear_for_error_prompt;
+begin while (state<>token_list)and terminal_input and@|
+ (input_ptr>0)and(loc>limit) do end_file_reading;
+print_ln; clear_terminal;
+end;
+
+@ To get \TeX's whole input mechanism going, we perform the following
+actions.
+
+@<Initialize the input routines@>=
+begin input_ptr:=0; max_in_stack:=0;
+in_open:=0; open_parens:=0; max_buf_stack:=0;
+grp_stack[0]:=0; if_stack[0]:=null;
+param_ptr:=0; max_param_stack:=0;
+first:=buf_size; repeat buffer[first]:=0; decr(first); until first=0;
+scanner_status:=normal; warning_index:=null; first:=1;
+state:=new_line; start:=1; index:=0; line:=0; name:=0;
+current_ocp_lstack:=0; current_ocp_no:=0; nofilter:=false;
+force_eof:=false; luacstrings :=0;
+align_state:=1000000;@/
+if not init_terminal then goto final_end;
+limit:=last; first:=last+1; {|init_terminal| has set |loc| and |last|}
+end
+
+@* \[24] Getting the next token.
+The heart of \TeX's input mechanism is the |get_next| procedure, which
+we shall develop in the next few sections of the program. Perhaps we
+shouldn't actually call it the ``heart,'' however, because it really acts
+as \TeX's eyes and mouth, reading the source files and gobbling them up.
+And it also helps \TeX\ to regurgitate stored token lists that are to be
+processed again.
+@^eyes and mouth@>
+
+The main duty of |get_next| is to input one token and to set |cur_cmd|
+and |cur_chr| to that token's command code and modifier. Furthermore, if
+the input token is a control sequence, the |eqtb| location of that control
+sequence is stored in |cur_cs|; otherwise |cur_cs| is set to zero.
+
+Underlying this simple description is a certain amount of complexity
+because of all the cases that need to be handled.
+However, the inner loop of |get_next| is reasonably short and fast.
+
+When |get_next| is asked to get the next token of a \.{\\read} line,
+it sets |cur_cmd=cur_chr=cur_cs=0| in the case that no more tokens
+appear on that line. (There might not be any tokens at all, if the
+|end_line_char| has |ignore| as its catcode.)
+
+@ The value of |par_loc| is the |eqtb| address of `\.{\\par}'. This quantity
+is needed because a blank line of input is supposed to be exactly equivalent
+to the appearance of \.{\\par}; we must set |cur_cs:=par_loc|
+when detecting a blank line.
+
+@<Glob...@>=
+@!par_loc:pointer; {location of `\.{\\par}' in |eqtb|}
+@!par_token:halfword; {token representing `\.{\\par}'}
+
+@ @<Put each...@>=
+primitive("par",par_end,too_big_char); {cf. |scan_file_name|}
+@!@:par_}{\.{\\par} primitive@>
+par_loc:=cur_val; par_token:=cs_token_flag+par_loc;
+
+@ @<Cases of |print_cmd_chr|...@>=
+par_end:print_esc("par");
+
+@ The function |get_next| is now defined in |textoken.c|. Parts of
+this routine are executed more often than any other instructions of \TeX.
+@^mastication@>@^inner loop@>
+
+@ The global variable |force_eof| is normally |false|; it is set |true|
+by an \.{\\endinput} command. |luacstrings| is the number of lua print
+statements waiting to be input, it is changed by |luatokencall|.
+
+|no_expand_flag| is a special character value that is inserted by
+|get_next| if it wants to suppress expansion.
+
+@d no_expand_flag==special_char {this characterizes a special variant of |relax|}
+@d end_line_char_inactive==(end_line_char<0)or(end_line_char>127)
+
+
+@<Glob...@>=
+@!force_eof:boolean; {should the next \.{\\input} be aborted early?}
+@!luacstrings:integer; {how many lua strings are waiting to be input?}
+
+@ If the user has set the |pausing| parameter to some positive value,
+and if nonstop mode has not been selected, each line of input is displayed
+on the terminal and the transcript file, followed by `\.{=>}'.
+\TeX\ waits for a response. If the response is simply |carriage_return|, the
+line is accepted as it stands, otherwise the line typed is
+used instead of the line in the file.
+
+@p procedure firm_up_the_line;
+var k:0..buf_size; {an index into |buffer|}
+begin limit:=last;
+if pausing>0 then if interaction>nonstop_mode then
+ begin wake_up_terminal; print_ln;
+ if start<limit then for k:=start to limit-1 do print(buffer[k]);
+ first:=limit; prompt_input("=>"); {wait for user response}
+@.=>@>
+ if last>first then
+ begin for k:=first to last-1 do {move line down in buffer}
+ buffer[k+start-first]:=buffer[k];
+ limit:=start+last-first;
+ end;
+ end;
+end;
+
+@ Since |get_next| is used so frequently in \TeX, it is convenient
+to define three related procedures that do a little more:
+
+\yskip\hang|get_token| not only sets |cur_cmd| and |cur_chr|, it
+also sets |cur_tok|, a packed halfword version of the current token.
+
+\yskip\hang|get_x_token|, meaning ``get an expanded token,'' is like
+|get_token|, but if the current token turns out to be a user-defined
+control sequence (i.e., a macro call), or a conditional,
+or something like \.{\\topmark} or \.{\\expandafter} or \.{\\csname},
+it is eliminated from the input by beginning the expansion of the macro
+or the evaluation of the conditional.
+
+\yskip\hang|x_token| is like |get_x_token| except that it assumes that
+|get_next| has already been called.
+
+\yskip\noindent
+In fact, these three procedures account for {\sl all\/} uses of |get_next|,
+except for two places in the ``inner loop'' when |cur_tok| need not be set,
+and except when the arguments to \.{\\ifx} are being scanned.
+
+@ No new control sequences will be defined except during a call of
+|get_token|, or when \.{\\csname} compresses a token list, because
+|no_new_control_sequence| is always |true| at other times.
+
+@p procedure get_token; {sets |cur_cmd|, |cur_chr|, |cur_tok|}
+begin no_new_control_sequence:=false; get_filtered_next; no_new_control_sequence:=true;
+@^inner loop@>
+if cur_cs=0 then cur_tok:=(cur_cmd*string_offset)+cur_chr
+else cur_tok:=cs_token_flag+cur_cs;
+end;
+
+@* \[25] Expanding the next token.
+Only a dozen or so command codes |>max_command| can possibly be returned by
+|get_next|; in increasing order, they are |undefined_cs|, |expand_after|,
+|no_expand|, |input|, |if_test|, |fi_or_else|, |cs_name|, |convert|, |the|,
+|top_bot_mark|, |call|, |long_call|, |outer_call|, |long_outer_call|, and
+|end_template|.{\emergencystretch=40pt\par}
+
+@ Sometimes, recursive calls to the following |expand| routine may
+cause exhaustion of the run-time calling stack, resulting in
+forced execution stops by the operating system. To diminish the chance
+of this happening, a counter is used to keep track of the recursion
+depth, in conjunction with a constant called |expand_depth|.
+
+Note that this does not catch all possible infinite recursion loops,
+just the ones that exhaust the application calling stack. The
+actual maximum value of |expand_depth| is outside of our control, but
+the initial setting of |100| should be enough to prevent problems.
+@^system dependencies@>
+
+@<Global...@>=
+expand_depth_count:integer;
+
+@ @<Initialize whatever ...@>=
+expand_depth_count:=0;
+
+@ The |expand| subroutine is used when |cur_cmd>max_command|. It removes a
+``call'' or a conditional or one of the other special operations just
+listed. It follows that |expand| might invoke itself recursively. In all
+cases, |expand| destroys the current token, but it sets things up so that
+the next |get_next| will deliver the appropriate next token. The value of
+|cur_tok| need not be known when |expand| is called.
+
+Since several of the basic scanning routines communicate via global variables,
+their values are saved as local variables of |expand| so that
+recursive calls don't invalidate them.
+@^recursion@>
+
+@p@t\4@>@<Declare the procedure called |macro_call|@>@;@/
+@t\4@>@<Declare the procedure called |insert_relax|@>@;@/
+@t\4@>@<Declare \eTeX\ procedures for expanding@>@;@/
+procedure@?pass_text; forward;@t\2@>
+procedure@?start_input; forward;@t\2@>
+procedure@?conditional; forward;@t\2@>
+procedure@?get_x_token; forward;@t\2@>
+procedure@?conv_toks; forward;@t\2@>
+procedure@?ins_the_toks; forward;@t\2@>
+procedure expand;
+label reswitch;
+var t:halfword; {token that is being ``expanded after''}
+@!p,@!q,@!r:pointer; {for list manipulation}
+@!cur_ptr:pointer; { for a local token list pointer }
+@!j:0..buf_size; {index into |buffer|}
+@!s:ASCII_code; { a character }
+@!cv_backup:integer; {to save the global quantity |cur_val|}
+@!cvl_backup,@!radix_backup,@!co_backup:small_number;
+ {to save |cur_val_level|, etc.}
+@!backup_backup:pointer; {to save |link(backup_head)|}
+@!save_scanner_status:small_number; {temporary storage of |scanner_status|}
+begin
+incr(expand_depth_count);
+if expand_depth_count>=expand_depth then overflow("expansion depth",expand_depth);
+cv_backup:=cur_val; cvl_backup:=cur_val_level; radix_backup:=radix;
+co_backup:=cur_order; backup_backup:=link(backup_head);
+reswitch:
+if cur_cmd<call then @<Expand a nonmacro@>
+else if cur_cmd<end_template then macro_call
+else @<Insert a token containing |frozen_endv|@>;
+cur_val:=cv_backup; cur_val_level:=cvl_backup; radix:=radix_backup;
+cur_order:=co_backup; link(backup_head):=backup_backup;
+decr(expand_depth_count);
+end;
+
+@ @<Glob...@>=
+@!is_in_csname: boolean;
+
+@ @<Set init...@>=
+is_in_csname := false;
+
+@ @<Expand a nonmacro@>=
+begin if tracing_commands>1 then show_cur_cmd_chr;
+case cur_cmd of
+top_bot_mark:@<Insert the \(a)appropriate mark text into the scanner@>;
+expand_after:if cur_chr=0 then @<Expand the token after the next token@>
+ else @<Negate a boolean conditional and |goto reswitch|@>;
+no_expand: if cur_chr=0 then @<Suppress expansion of the next token@>
+ else @<Implement \.{\\primitive}@>;
+cs_name:@<Manufacture a control sequence name@>;
+convert:conv_toks; {this procedure is discussed in Part 27 below}
+the:ins_the_toks; {this procedure is discussed in Part 27 below}
+if_test:conditional; {this procedure is discussed in Part 28 below}
+fi_or_else:@<Terminate the current conditional and skip to \.{\\fi}@>;
+input:@<Initiate or terminate input from a file@>;
+othercases @<Complain about an undefined macro@>
+endcases;
+end
+
+@ It takes only a little shuffling to do what \TeX\ calls \.{\\expandafter}.
+
+@<Expand the token after...@>=
+begin get_token; t:=cur_tok; get_token;
+if cur_cmd>max_command then expand@+else back_input;
+cur_tok:=t; back_input;
+end
+
+@ The implementation of \.{\\noexpand} is a bit trickier, because it is
+necessary to insert a special `|dont_expand|' marker into \TeX's reading
+mechanism. This special marker is processed by |get_next|, but it does
+not slow down the inner loop.
+
+Since \.{\\outer} macros might arise here, we must also
+clear the |scanner_status| temporarily.
+
+@<Suppress expansion...@>=
+begin save_scanner_status:=scanner_status; scanner_status:=normal;
+get_token; scanner_status:=save_scanner_status; t:=cur_tok;
+back_input; {now |start| and |loc| point to the backed-up token |t|}
+if t>=cs_token_flag then
+ begin p:=get_avail; info(p):=cs_token_flag+frozen_dont_expand;
+ link(p):=loc; start:=p; loc:=p;
+ end;
+end
+
+@ The \.{\\primitive} handling. If the primitive meaning of the next
+token is an expandable command, it suffices to replace the current
+token with the primitive one and restart |expand|.
+
+Otherwise, the token we just read has to be pushed back, as well
+as a token matching the internal form of \.{\\primitive}, that is
+sneaked in as an alternate form of |ignore_spaces|.
+@!@:primitive_}{\.{\\primitive} primitive (internalized)@>
+
+An implementation problem surfaces: There really is no |cur_cs|
+attached to the inserted primitive command, so it is safer to set
+|cur_cs| to zero. |cur_tok| has a similar problem. And for the
+non-expanded branch, simply pushing back a token that matches the
+correct internal command does not work, because that approach would
+not survive roundtripping to a temporary file or even a token list.
+
+In a next version, it would be smart to create |frozen_| versions of
+all the primitives. Then, this problem would not happen, at the
+expense of a few hundred extra control sequences.
+
+@<Implement \.{\\primitive}@>=
+begin save_scanner_status := scanner_status; scanner_status:=normal;
+get_token; scanner_status:=save_scanner_status;
+cur_cs := prim_lookup(text(cur_cs));
+if cur_cs<>undefined_primitive then begin
+ t:=get_prim_eq_type(cur_cs);
+ if t>max_command then begin
+ cur_cmd := t;
+ cur_chr := get_prim_equiv(cur_cs);
+ cur_tok := (cur_cmd*string_offset)+cur_chr;
+ cur_cs := 0;
+ goto reswitch;
+ end
+ else begin
+ back_input; { now |loc| and |start| point to a one-item list }
+ p:=get_avail; info(p):=cs_token_flag+frozen_primitive;
+ link(p):=loc; loc:=p; start:=p;
+ end;
+ end;
+end
+
+@ @<Complain about an undefined macro@>=
+begin print_err("Undefined control sequence");
+@.Undefined control sequence@>
+help5("The control sequence at the end of the top line")@/
+("of your error message was never \def'ed. If you have")@/
+("misspelled it (e.g., `\hobx'), type `I' and the correct")@/
+("spelling (e.g., `I\hbox'). Otherwise just continue,")@/
+("and I'll forget about whatever was undefined.");
+error;
+end
+
+@ The |expand| procedure and some other routines that construct token
+lists find it convenient to use the following macros, which are valid only if
+the variables |p| and |q| are reserved for token-list building.
+
+@d store_new_token(#)==begin q:=get_avail; link(p):=q; info(q):=#;
+ p:=q; {|link(p)| is |null|}
+ end
+@d fast_store_new_token(#)==begin fast_get_avail(q); link(p):=q; info(q):=#;
+ p:=q; {|link(p)| is |null|}
+ end
+
+@ @<Manufacture a control...@>=
+begin r:=get_avail; p:=r; {head of the list of characters}
+is_in_csname := true;
+repeat get_x_token;
+if cur_cs=0 then store_new_token(cur_tok);
+until cur_cs<>0;
+if cur_cmd<>end_cs_name then @<Complain about missing \.{\\endcsname}@>;
+is_in_csname := false;
+@<Look up the characters of list |r| in the hash table, and set |cur_cs|@>;
+flush_list(r);
+if eq_type(cur_cs)=undefined_cs then
+ begin eq_define(cur_cs,relax,too_big_char); {N.B.: The |save_stack| might change}
+ end; {the control sequence will now match `\.{\\relax}'}
+cur_tok:=cur_cs+cs_token_flag; back_input;
+end
+
+@ @<Complain about missing \.{\\endcsname}@>=
+begin print_err("Missing "); print_esc("endcsname"); print(" inserted");
+@.Missing \\endcsname...@>
+help2("The control sequence marked <to be read again> should")@/
+ ("not appear between \csname and \endcsname.");
+back_error;
+end
+
+@ @<Look up the characters of list |r| in the hash table...@>=
+j:=first; p:=link(r);
+while p<>null do
+ begin if j>=max_buf_stack then
+ begin max_buf_stack:=j+4;
+ if max_buf_stack=buf_size then
+ check_buffer_overflow(max_buf_stack);
+@:TeX capacity exceeded buffer size}{\quad buffer size@>
+ end;
+ s := info(p) mod string_offset;
+ if s <= @"7F then begin
+ buffer[j]:=s; incr(j);
+ end
+ else if s<=@"7FF then begin
+ buffer[j]:=@"C0 + s div @"40; incr(j);
+ buffer[j]:=@"80 + s mod @"40; incr(j);
+ end
+ else if s<=@"FFFF then begin
+ buffer[j]:=@"E0 + s div @"1000; incr(j);
+ buffer[j]:=@"80 + (s mod @"1000) div @"40; incr(j);
+ buffer[j]:=@"80 + (s mod @"1000) mod @"40; incr(j);
+ end
+ else begin
+ buffer[j]:=@"F0 + s div @"40000; incr(j);
+ buffer[j]:=@"80 + (s mod @"40000) div @"1000; incr(j);
+ buffer[j]:=@"80 + ((s mod @"40000) mod @"1000) div @"40; incr(j);
+ buffer[j]:=@"80 + ((s mod @"40000) mod @"1000) mod @"40; incr(j);
+ end;
+ p:=link(p);
+ end;
+if j>first then
+ begin no_new_control_sequence:=false; cur_cs:=id_lookup(first,j-first);
+ no_new_control_sequence:=true;
+ end
+else if j=first then cur_cs:=null_cs {the list is empty}
+
+@ An |end_template| command is effectively changed to an |endv| command
+by the following code. (The reason for this is discussed below; the
+|frozen_end_template| at the end of the template has passed the
+|check_outer_validity| test, so its mission of error detection has been
+accomplished.)
+
+@<Insert a token containing |frozen_endv|@>=
+begin cur_tok:=cs_token_flag+frozen_endv; back_input;
+end
+
+@ The processing of \.{\\input} involves the |start_input| subroutine,
+which will be declared later; the processing of \.{\\endinput} is trivial.
+
+@<Put each...@>=
+primitive("input",input,0);@/
+@!@:input_}{\.{\\input} primitive@>
+primitive("endinput",input,1);@/
+@!@:end_input_}{\.{\\endinput} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+input: if chr_code=0 then print_esc("input")
+ @/@<Cases of |input| for |print_cmd_chr|@>@/
+ else print_esc("endinput");
+
+@ @<Initiate or terminate input...@>=
+if cur_chr=1 then force_eof:=true
+@/@<Cases for |input|@>@/
+else if name_in_progress then insert_relax
+else start_input
+
+@ Sometimes the expansion looks too far ahead, so we want to insert
+a harmless \.{\\relax} into the user's input.
+
+@<Declare the procedure called |insert_relax|@>=
+procedure insert_relax;
+begin cur_tok:=cs_token_flag+cur_cs; back_input;
+cur_tok:=cs_token_flag+frozen_relax; back_input; token_type:=inserted;
+end;
+
+@ Here is a recursive procedure that is \TeX's usual way to get the
+next token of input. It has been slightly optimized to take account of
+common cases.
+
+@p procedure get_x_token; {sets |cur_cmd|, |cur_chr|, |cur_tok|,
+ and expands macros}
+label restart,done;
+begin restart: get_filtered_next;
+@^inner loop@>
+if cur_cmd<=max_command then goto done;
+if cur_cmd>=call then
+ if cur_cmd<end_template then macro_call
+ else begin cur_cs:=frozen_endv; cur_cmd:=endv;
+ goto done; {|cur_chr=null_list|}
+ end
+else expand;
+goto restart;
+done: if cur_cs=0 then cur_tok:=(cur_cmd*string_offset)+cur_chr
+else cur_tok:=cs_token_flag+cur_cs;
+end;
+
+@ The |get_x_token| procedure is equivalent to two consecutive
+procedure calls: |get_next; x_token|.
+
+@p procedure x_token; {|get_x_token| without the initial |get_next|}
+begin while cur_cmd>max_command do
+ begin expand;
+ get_filtered_next;
+ end;
+if cur_cs=0 then cur_tok:=(cur_cmd*string_offset)+cur_chr
+else cur_tok:=cs_token_flag+cur_cs;
+end;
+
+@ The |get_filtered_next| procedure allows Lua code to mutate the
+output of |get_next| before \TeX\ looks at it. The implementation
+is in the C file |luatoken.c|.
+
+@d get_filtered_next==get_token_lua
+
+
+
+@ A control sequence that has been \.{\\def}'ed by the user is expanded by
+\TeX's |macro_call| procedure.
+
+Before we get into the details of |macro_call|, however, let's consider the
+treatment of primitives like \.{\\topmark}, since they are essentially
+macros without parameters. The token lists for such marks are kept in five
+global arrays of pointers; we refer to the individual entries of these
+arrays by symbolic macros |top_mark|, etc. The value of |top_mark(x)|, etc.
+is either |null| or a pointer to the reference count of a token list.
+
+The variable |biggest_used_mark| is an aid to try and keep the code
+somehwat efficient without too much extra work: it registers the
+highest mark class ever instantiated by the user, so the loops
+in |fire_up| and |vsplit| do not have to traverse the full range
+|0..biggest_mark|.
+
+@d top_mark_code=0 {the mark in effect at the previous page break}
+@d first_mark_code=1 {the first mark between |top_mark| and |bot_mark|}
+@d bot_mark_code=2 {the mark in effect at the current page break}
+@d split_first_mark_code=3 {the first mark found by \.{\\vsplit}}
+@d split_bot_mark_code=4 {the last mark found by \.{\\vsplit}}
+@#
+@d top_mark(#)==top_marks_array[#]
+@d first_mark(#)==first_marks_array[#]
+@d bot_mark(#)==bot_marks_array[#]
+@d split_first_mark(#)==split_first_marks_array[#]
+@d split_bot_mark(#)==split_bot_marks_array[#]
+@#
+@d delete_top_mark(#)==begin if top_mark(#)<>null then
+ delete_token_ref(top_mark(#)); top_mark(#):=null; end
+@d delete_bot_mark(#)==begin if bot_mark(#)<>null then
+ delete_token_ref(bot_mark(#)); bot_mark(#):=null; end
+@d delete_first_mark(#)==begin if first_mark(#)<>null then
+ delete_token_ref(first_mark(#)); first_mark(#):=null; end
+@d delete_split_first_mark(#)==begin if split_first_mark(#)<>null then
+ delete_token_ref(split_first_mark(#)); split_first_mark(#):=null; end
+@d delete_split_bot_mark(#)==begin if split_bot_mark(#)<>null then
+ delete_token_ref(split_bot_mark(#)); split_bot_mark(#):=null; end
+@#
+@d clear_marks_code=1
+@d marks_code=5
+@#
+
+@<Glob...@>=
+@!top_marks_array:array[0..biggest_mark] of pointer;
+@!first_marks_array:array[0..biggest_mark] of pointer;
+@!bot_marks_array:array[0..biggest_mark] of pointer;
+@!split_first_marks_array:array[0..biggest_mark] of pointer;
+@!split_bot_marks_array:array[0..biggest_mark] of pointer;
+biggest_used_mark:halfword;
+
+@ @<Set init...@>=
+biggest_used_mark:=0;
+for i:=0 to biggest_mark do begin
+ top_mark(i):=null;
+ first_mark(i):=null;
+ bot_mark(i):=null;
+ split_first_mark(i):=null;
+ split_bot_mark(i):=null;
+end;
+
+@ @<Put each...@>=
+primitive("topmark",top_bot_mark,top_mark_code);
+@!@:top_mark_}{\.{\\topmark} primitive@>
+primitive("firstmark",top_bot_mark,first_mark_code);
+@!@:first_mark_}{\.{\\firstmark} primitive@>
+primitive("botmark",top_bot_mark,bot_mark_code);
+@!@:bot_mark_}{\.{\\botmark} primitive@>
+primitive("splitfirstmark",top_bot_mark,split_first_mark_code);
+@!@:split_first_mark_}{\.{\\splitfirstmark} primitive@>
+primitive("splitbotmark",top_bot_mark,split_bot_mark_code);
+@!@:split_bot_mark_}{\.{\\splitbotmark} primitive@>
+primitive("clearmarks",mark,clear_marks_code);@/
+@!@:clearmarks_}{\.{\\clearmarks} primitive@>
+primitive("marks",mark,marks_code);
+@!@:marks_}{\.{\\marks} primitive@>
+primitive("topmarks",top_bot_mark,top_mark_code+marks_code);
+@!@:top_marks_}{\.{\\topmarks} primitive@>
+primitive("firstmarks",top_bot_mark,first_mark_code+marks_code);
+@!@:first_marks_}{\.{\\firstmarks} primitive@>
+primitive("botmarks",top_bot_mark,bot_mark_code+marks_code);
+@!@:bot_marks_}{\.{\\botmarks} primitive@>
+primitive("splitfirstmarks",top_bot_mark,split_first_mark_code+marks_code);
+@!@:split_first_marks_}{\.{\\splitfirstmarks} primitive@>
+primitive("splitbotmarks",top_bot_mark,split_bot_mark_code+marks_code);
+@!@:split_bot_marks_}{\.{\\splitbotmarks} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+top_bot_mark: begin case (chr_code mod marks_code) of
+ first_mark_code: print_esc("firstmark");
+ bot_mark_code: print_esc("botmark");
+ split_first_mark_code: print_esc("splitfirstmark");
+ split_bot_mark_code: print_esc("splitbotmark");
+ othercases print_esc("topmark")
+ endcases;
+ if chr_code>=marks_code then print_char("s");
+ end;
+
+@ The following code is activated when |cur_cmd=top_bot_mark| and
+when |cur_chr| is a code like |top_mark_code|.
+
+@<Insert the \(a)appropriate mark text into the scanner@>=
+begin t:=cur_chr mod marks_code;
+if cur_chr>=marks_code then scan_mark_num@+else cur_val:=0;
+case t of
+ first_mark_code: cur_ptr:=first_mark(cur_val);
+ bot_mark_code: cur_ptr:=bot_mark(cur_val);
+ split_first_mark_code: cur_ptr:=split_first_mark(cur_val);
+ split_bot_mark_code: cur_ptr:=split_bot_mark(cur_val);
+ othercases cur_ptr:=top_mark(cur_val)
+endcases;
+if cur_ptr<>null then begin_token_list(cur_ptr,mark_text);
+end
+
+@ Now let's consider |macro_call| itself, which is invoked when \TeX\ is
+scanning a control sequence whose |cur_cmd| is either |call|, |long_call|,
+|outer_call|, or |long_outer_call|. The control sequence definition
+appears in the token list whose reference count is in location |cur_chr|
+of |mem|.
+
+The global variable |long_state| will be set to |call| or to |long_call|,
+depending on whether or not the control sequence disallows \.{\\par}
+in its parameters. The |get_next| routine will set |long_state| to
+|outer_call| and emit \.{\\par}, if a file ends or if an \.{\\outer}
+control sequence occurs in the midst of an argument.
+
+@<Glob...@>=
+@!long_state:call..long_outer_call; {governs the acceptance of \.{\\par}}
+
+@ The parameters, if any, must be scanned before the macro is expanded.
+Parameters are token lists without reference counts. They are placed on
+an auxiliary stack called |pstack| while they are being scanned, since
+the |param_stack| may be losing entries during the matching process.
+(Note that |param_stack| can't be gaining entries, since |macro_call| is
+the only routine that puts anything onto |param_stack|, and it
+is not recursive.)
+
+@<Glob...@>=
+@!pstack:array[0..8] of pointer; {arguments supplied to a macro}
+
+@ After parameter scanning is complete, the parameters are moved to the
+|param_stack|. Then the macro body is fed to the scanner; in other words,
+|macro_call| places the defined text of the control sequence at the
+top of\/ \TeX's input stack, so that |get_next| will proceed to read it
+next.
+
+The global variable |cur_cs| contains the |eqtb| address of the control sequence
+being expanded, when |macro_call| begins. If this control sequence has not been
+declared \.{\\long}, i.e., if its command code in the |eq_type| field is
+not |long_call| or |long_outer_call|, its parameters are not allowed to contain
+the control sequence \.{\\par}. If an illegal \.{\\par} appears, the macro
+call is aborted, and the \.{\\par} will be rescanned.
+
+@<Declare the procedure called |macro_call|@>=
+procedure macro_call; {invokes a user-defined control sequence}
+label exit, continue, done, done1, found;
+var r:pointer; {current node in the macro's token list}
+@!p:pointer; {current node in parameter token list being built}
+@!q:pointer; {new node being put into the token list}
+@!s:pointer; {backup pointer for parameter matching}
+@!t:pointer; {cycle pointer for backup recovery}
+@!u,@!v:pointer; {auxiliary pointers for backup recovery}
+@!rbrace_ptr:pointer; {one step before the last |right_brace| token}
+@!n:small_number; {the number of parameters scanned}
+@!unbalance:halfword; {unmatched left braces in current parameter}
+@!m:halfword; {the number of tokens or groups (usually)}
+@!ref_count:pointer; {start of the token list}
+@!save_scanner_status:small_number; {|scanner_status| upon entry}
+@!save_warning_index:pointer; {|warning_index| upon entry}
+@!match_chr:ASCII_code; {character used in parameter}
+begin save_scanner_status:=scanner_status; save_warning_index:=warning_index;
+warning_index:=cur_cs; ref_count:=cur_chr; r:=link(ref_count); n:=0;
+p:=null; m:=0; rbrace_ptr:=null; match_chr:=0;
+if tracing_macros>0 then @<Show the text of the macro being expanded@>;
+if info(r)=protected_token then r:=link(r);
+if info(r)<>end_match_token then
+ @<Scan the parameters and make |link(r)| point to the macro body; but
+ |return| if an illegal \.{\\par} is detected@>;
+@<Feed the macro body and its parameters to the scanner@>;
+exit:scanner_status:=save_scanner_status; warning_index:=save_warning_index;
+end;
+
+@ Before we put a new token list on the input stack, it is wise to clean off
+all token lists that have recently been depleted. Then a user macro that ends
+with a call to itself will not require unbounded stack space.
+
+@<Feed the macro body and its parameters to the scanner@>=
+while (state=token_list)and(loc=null)and(token_type<>v_template) do
+ end_token_list; {conserve stack space}
+begin_token_list(ref_count,macro); name:=warning_index; loc:=link(r);
+if n>0 then
+ begin if param_ptr+n>max_param_stack then
+ begin max_param_stack:=param_ptr+n;
+ if max_param_stack>param_size then
+ overflow("parameter stack size",param_size);
+@:TeX capacity exceeded parameter stack size}{\quad parameter stack size@>
+ end;
+ for m:=0 to n-1 do param_stack[param_ptr+m]:=pstack[m];
+ param_ptr:=param_ptr+n;
+ end
+
+@ At this point, the reader will find it advisable to review the explanation
+of token list format that was presented earlier, since many aspects of that
+format are of importance chiefly in the |macro_call| routine.
+
+The token list might begin with a string of compulsory tokens before the
+first |match| or |end_match|. In that case the macro name is supposed to be
+followed by those tokens; the following program will set |s=null| to
+represent this restriction. Otherwise |s| will be set to the first token of
+a string that will delimit the next parameter.
+
+@<Scan the parameters and make |link(r)| point to the macro body...@>=
+begin scanner_status:=matching; unbalance:=0;
+long_state:=eq_type(cur_cs);
+if long_state>=outer_call then long_state:=long_state-2;
+repeat link(temp_token_head):=null;
+if (info(r)>=end_match_token)or(info(r)<match_token) then s:=null
+else begin match_chr:=info(r)-match_token; s:=link(r); r:=s;
+ p:=temp_token_head; m:=0;
+ end;
+@<Scan a parameter until its delimiter string has been found; or, if |s=null|,
+ simply scan the delimiter string@>;@/
+{now |info(r)| is a token whose command code is either |match| or |end_match|}
+until info(r)=end_match_token;
+end
+
+@ If |info(r)| is a |match| or |end_match| command, it cannot be equal to
+any token found by |get_token|. Therefore an undelimited parameter---i.e.,
+a |match| that is immediately followed by |match| or |end_match|---will
+always fail the test `|cur_tok=info(r)|' in the following algorithm.
+
+@<Scan a parameter until its delimiter string has been found; or, ...@>=
+continue: get_token; {set |cur_tok| to the next token of input}
+if cur_tok=info(r) then
+ @<Advance \(r)|r|; |goto found| if the parameter delimiter has been
+ fully matched, otherwise |goto continue|@>;
+@<Contribute the recently matched tokens to the current parameter, and
+ |goto continue| if a partial match is still in effect;
+ but abort if |s=null|@>;
+if cur_tok=par_token then if long_state<>long_call then
+ @<Report a runaway argument and abort@>;
+if cur_tok<right_brace_limit then
+ if cur_tok<left_brace_limit then
+ @<Contribute an entire group to the current parameter@>
+ else @<Report an extra right brace and |goto continue|@>
+else @<Store the current token, but |goto continue| if it is
+ a blank space that would become an undelimited parameter@>;
+incr(m);
+if info(r)>end_match_token then goto continue;
+if info(r)<match_token then goto continue;
+found: if s<>null then @<Tidy up the parameter just scanned, and tuck it away@>
+
+@ @<Store the current token, but |goto continue| if it is...@>=
+begin if cur_tok=space_token then
+ if info(r)<=end_match_token then
+ if info(r)>=match_token then goto continue;
+store_new_token(cur_tok);
+end
+
+@ A slightly subtle point arises here: When the parameter delimiter ends
+with `\.{\#\{}', the token list will have a left brace both before and
+after the |end_match|\kern-.4pt. Only one of these should affect the
+|align_state|, but both will be scanned, so we must make a correction.
+
+@<Advance \(r)|r|; |goto found| if the parameter delimiter has been fully...@>=
+begin r:=link(r);
+if (info(r)>=match_token)and(info(r)<=end_match_token) then
+ begin if cur_tok<left_brace_limit then decr(align_state);
+ goto found;
+ end
+else goto continue;
+end
+
+@ @<Report an extra right brace and |goto continue|@>=
+begin back_input; print_err("Argument of "); sprint_cs(warning_index);
+@.Argument of \\x has...@>
+print(" has an extra }");
+help6("I've run across a `}' that doesn't seem to match anything.")@/
+ ("For example, `\def\a#1{...}' and `\a}' would produce")@/
+ ("this error. If you simply proceed now, the `\par' that")@/
+ ("I've just inserted will cause me to report a runaway")@/
+ ("argument that might be the root of the problem. But if")@/
+ ("your `}' was spurious, just type `2' and it will go away.");
+incr(align_state); long_state:=call; cur_tok:=par_token; ins_error;
+end {a white lie; the \.{\\par} won't always trigger a runaway}
+
+@ If |long_state=outer_call|, a runaway argument has already been reported.
+
+@<Report a runaway argument and abort@>=
+begin if long_state=call then
+ begin runaway; print_err("Paragraph ended before ");
+@.Paragraph ended before...@>
+ sprint_cs(warning_index); print(" was complete");
+ help3("I suspect you've forgotten a `}', causing me to apply this")@/
+ ("control sequence to too much text. How can we recover?")@/
+ ("My plan is to forget the whole thing and hope for the best.");
+ back_error;
+ end;
+pstack[n]:=link(temp_token_head); align_state:=align_state-unbalance;
+for m:=0 to n do flush_list(pstack[m]);
+return;
+end
+
+@ When the following code becomes active, we have matched tokens from |s| to
+the predecessor of |r|, and we have found that |cur_tok<>info(r)|. An
+interesting situation now presents itself: If the parameter is to be
+delimited by a string such as `\.{ab}', and if we have scanned `\.{aa}',
+we want to contribute one `\.a' to the current parameter and resume
+looking for a `\.b'. The program must account for such partial matches and
+for others that can be quite complex. But most of the time we have |s=r|
+and nothing needs to be done.
+
+Incidentally, it is possible for \.{\\par} tokens to sneak in to certain
+parameters of non-\.{\\long} macros. For example, consider a case like
+`\.{\\def\\a\#1\\par!\{...\}}' where the first \.{\\par} is not followed
+by an exclamation point. In such situations it does not seem appropriate
+to prohibit the \.{\\par}, so \TeX\ keeps quiet about this bending of
+the rules.
+
+@<Contribute the recently matched tokens to the current parameter...@>=
+if s<>r then
+ if s=null then @<Report an improper use of the macro and abort@>
+ else begin t:=s;
+ repeat store_new_token(info(t)); incr(m); u:=link(t); v:=s;
+ loop@+ begin if u=r then
+ if cur_tok<>info(v) then goto done
+ else begin r:=link(v); goto continue;
+ end;
+ if info(u)<>info(v) then goto done;
+ u:=link(u); v:=link(v);
+ end;
+ done: t:=link(t);
+ until t=r;
+ r:=s; {at this point, no tokens are recently matched}
+ end
+
+@ @<Report an improper use...@>=
+begin print_err("Use of "); sprint_cs(warning_index);
+@.Use of x doesn't match...@>
+print(" doesn't match its definition");
+help4("If you say, e.g., `\def\a1{...}', then you must always")@/
+ ("put `1' after `\a', since control sequence names are")@/
+ ("made up of letters only. The macro here has not been")@/
+ ("followed by the required stuff, so I'm ignoring it.");
+error; return;
+end
+
+@ @<Contribute an entire group to the current parameter@>=
+begin unbalance:=1;
+@^inner loop@>
+loop@+ begin fast_store_new_token(cur_tok); get_token;
+ if cur_tok=par_token then if long_state<>long_call then
+ @<Report a runaway argument and abort@>;
+ if cur_tok<right_brace_limit then
+ if cur_tok<left_brace_limit then incr(unbalance)
+ else begin decr(unbalance);
+ if unbalance=0 then goto done1;
+ end;
+ end;
+done1: rbrace_ptr:=p; store_new_token(cur_tok);
+end
+
+@ If the parameter consists of a single group enclosed in braces, we must
+strip off the enclosing braces. That's why |rbrace_ptr| was introduced.
+
+@<Tidy up the parameter just scanned, and tuck it away@>=
+begin if (m=1)and(info(p)<right_brace_limit)and(p<>temp_token_head) then
+ begin link(rbrace_ptr):=null; free_avail(p);
+ p:=link(temp_token_head); pstack[n]:=link(p); free_avail(p);
+ end
+else pstack[n]:=link(temp_token_head);
+incr(n);
+if tracing_macros>0 then
+ begin begin_diagnostic; print_nl(match_chr); print_int(n);
+ print("<-"); show_token_list(pstack[n-1],null,1000);
+ end_diagnostic(false);
+ end;
+end
+
+@ @<Show the text of the macro being expanded@>=
+begin begin_diagnostic; print_ln; print_cs(warning_index);
+token_show(ref_count); end_diagnostic(false);
+end
+
+@* \[26] Basic scanning subroutines.
+Let's turn now to some procedures that \TeX\ calls upon frequently to digest
+certain kinds of patterns in the input. Most of these are quite simple;
+some are quite elaborate. Almost all of the routines call |get_x_token|,
+which can cause them to be invoked recursively.
+@^stomach@>
+@^recursion@>
+
+@ The |scan_left_brace| routine is called when a left brace is supposed to be
+the next non-blank token. (The term ``left brace'' means, more precisely,
+a character whose catcode is |left_brace|.) \TeX\ allows \.{\\relax} to
+appear before the |left_brace|.
+
+@p procedure scan_left_brace; {reads a mandatory |left_brace|}
+begin @<Get the next non-blank non-relax non-call token@>;
+if cur_cmd<>left_brace then
+ begin print_err("Missing { inserted");
+@.Missing \{ inserted@>
+ help4("A left brace was mandatory here, so I've put one in.")@/
+ ("You might want to delete and/or insert some corrections")@/
+ ("so that I will find a matching right brace soon.")@/
+ ("(If you're confused by all this, try typing `I}' now.)");
+ back_error; cur_tok:=left_brace_token+"{"; cur_cmd:=left_brace;
+ cur_chr:="{"; incr(align_state);
+ end;
+end;
+
+@ The |scan_right_brace| routine is called when a right brace is supposed to be
+the next non-blank token. (The term ``right brace'' means, more precisely,
+a character whose catcode is |right_brace|.) \TeX\ allows \.{\\relax} to
+appear before the |right_brace|.
+
+@p procedure scan_right_brace; {reads a mandatory |right_brace|}
+begin @<Get the next non-blank non-relax non-call token@>;
+if cur_cmd<>right_brace then
+ begin print_err("Missing { inserted");
+@.Missing \{ inserted@>
+ help4("A right brace was mandatory here, so I've put one in.")@/
+ ("You might want to delete and/or insert some corrections")@/
+ ("so that I will find a matching right brace soon.")@/
+ ("(If you're confused by all this, try typing `I}' now.)");
+ back_error; cur_tok:=right_brace_token+"}"; cur_cmd:=right_brace;
+ cur_chr:="}"; incr(align_state);
+ end;
+end;
+
+@ @<Get the next non-blank non-relax non-call token@>=
+repeat get_x_token;
+until (cur_cmd<>spacer)and(cur_cmd<>relax)
+
+@ The |scan_optional_equals| routine looks for an optional `\.=' sign preceded
+by optional spaces; `\.{\\relax}' is not ignored here.
+
+@p procedure scan_optional_equals;
+begin @<Get the next non-blank non-call token@>;
+if cur_tok<>other_token+"=" then back_input;
+end;
+
+@ @<Get the next non-blank non-call token@>=
+repeat get_x_token;
+until cur_cmd<>spacer
+
+@ In case you are getting bored, here is a slightly less trivial routine:
+Given a string of lowercase letters, like `\.{pt}' or `\.{plus}' or
+`\.{width}', the |scan_keyword| routine checks to see whether the next
+tokens of input match this string. The match must be exact, except that
+uppercase letters will match their lowercase counterparts; uppercase
+equivalents are determined by subtracting |"a"-"A"|, rather than using the
+|uc_code| table, since \TeX\ uses this routine only for its own limited
+set of keywords.
+
+If a match is found, the characters are effectively removed from the input
+and |true| is returned. Otherwise |false| is returned, and the input
+is left essentially unchanged (except for the fact that some macros
+may have been expanded, etc.).
+@^inner loop@>
+
+@p function scan_keyword(@!s:str_number):boolean; {look for a given string}
+label exit;
+var p:pointer; {tail of the backup list}
+@!q:pointer; {new node being added to the token list via |store_new_token|}
+@!k:pool_pointer; {index into |str_pool|}
+begin
+if s<number_chars then begin
+ @<Get the next non-blank non-call token@>;
+ if (cur_cs=0)and((cur_chr=s)or(cur_chr=s-"a"+"A")) then
+ scan_keyword:=true
+ else
+ begin back_input;
+ scan_keyword:=false; return;
+ end;
+ end
+else begin
+ p:=backup_head; link(p):=null;
+ k:=str_start_macro(s);
+ while k<str_start_macro(s+1) do
+ begin get_x_token; {recursion is possible here}
+@^recursion@>
+ if (cur_cs=0)and@|
+ ((cur_chr=so(str_pool[k]))or(cur_chr=so(str_pool[k])-"a"+"A")) then
+ begin store_new_token(cur_tok); incr(k);
+ end
+ else if (cur_cmd<>spacer)or(p<>backup_head) then
+ begin
+ if p<>backup_head then begin
+ q:=get_avail; info(q):=cur_tok; link(q):=null;
+ link(p) := q;
+ back_list(link(backup_head));
+ end
+ else
+ back_input;
+ scan_keyword:=false; return;
+ end;
+ end;
+ flush_list(link(backup_head)); scan_keyword:=true;
+end;
+exit:end;
+
+@ Here is a procedure that sounds an alarm when mu and non-mu units
+are being switched.
+
+@p procedure mu_error;
+begin print_err("Incompatible glue units");
+@.Incompatible glue units@>
+help1("I'm going to assume that 1mu=1pt when they're mixed.");
+error;
+end;
+
+@ The next routine `|scan_something_internal|' is used to fetch internal
+numeric quantities like `\.{\\hsize}', and also to handle the `\.{\\the}'
+when expanding constructions like `\.{\\the\\toks0}' and
+`\.{\\the\\baselineskip}'. Soon we will be considering the |scan_int|
+procedure, which calls |scan_something_internal|; on the other hand,
+|scan_something_internal| also calls |scan_int|, for constructions like
+`\.{\\catcode\`\\\$}' or `\.{\\fontdimen} \.3 \.{\\ff}'. So we
+have to declare |scan_int| as a |forward| procedure. A few other
+procedures are also declared at this point.
+
+@p procedure@?scan_int; forward; {scans an integer value}
+@t\4\4@>@<Declare procedures that scan restricted classes of integers@>@;
+@t\4\4@>@<Declare \eTeX\ procedures for scanning@>@;
+@t\4\4@>@<Declare procedures that scan font-related stuff@>
+@t\4\4@>@<Declare procedures that scan ocp-related stuff@>
+
+@ \TeX\ doesn't know exactly what to expect when
+|scan_something_internal| begins. For example, an integer or
+dimension or glue value could occur immediately after `\.{\\hskip}';
+and one can even say \.{\\the} with respect to token lists in
+constructions like `\.{\\xdef\\o\{\\the\\output\}}'. On the other
+hand, only integers are allowed after a construction like
+`\.{\\count}'. To handle the various possibilities,
+|scan_something_internal| has a |level| parameter, which tells the
+``highest'' kind of quantity that |scan_something_internal| is allowed
+to produce. Eight levels are distinguished, namely |int_val|,
+|attr_val|, |dimen_val|, |glue_val|, |mu_val|, |dir_val|, |ident_val|,
+and |tok_val|.
+
+The output of |scan_something_internal| (and of the other routines
+|scan_int|, |scan_dimen|, and |scan_glue| below) is put into the global
+variable |cur_val|, and its level is put into |cur_val_level|. The highest
+values of |cur_val_level| are special: |mu_val| is used only when
+|cur_val| points to something in a ``muskip'' register, or to one of the
+three parameters \.{\\thinmuskip}, \.{\\medmuskip}, \.{\\thickmuskip};
+|ident_val| is used only when |cur_val| points to a font identifier;
+|tok_val| is used only when |cur_val| points to |null| or to the reference
+count of a token list. The last two cases are allowed only when
+|scan_something_internal| is called with |level=tok_val|.
+
+If the output is glue, |cur_val| will point to a glue specification, and
+the reference count of that glue will have been updated to reflect this
+reference; if the output is a nonempty token list, |cur_val| will point to
+its reference count, but in this case the count will not have been updated.
+Otherwise |cur_val| will contain the integer or scaled value in question.
+
+@d int_val=0 {integer values}
+@d attr_val=1 {integer values}
+@d dimen_val=2 {dimension values}
+@d glue_val=3 {glue specifications}
+@d mu_val=4 {math glue specifications}
+@d dir_val=5 {directions}
+@d ident_val=6 {font identifier}
+@d tok_val=7 {token lists}
+
+@<Glob...@>=
+@!cur_val:integer; {value returned by numeric scanners}
+@!cur_val1:integer; {delcodes are now 51 digits}
+@!cur_val_level:int_val..tok_val; {the ``level'' of this value}
+
+@ The hash table is initialized with `\.{\\count}', `\.{\\attribute}',
+`\.{\\dimen}', `\.{\\skip}', and `\.{\\muskip}' all having |register|
+as their command code; they are distinguished by the |chr_code|, which
+is either |int_val|, |attr_val|, |dimen_val|, |glue_val|, or |mu_val|.
+
+@<Put each...@>=
+primitive("count",register,int_val);
+@!@:count_}{\.{\\count} primitive@>
+primitive("attribute",register,attr_val);
+@!@:count_}{\.{\\attribute} primitive@>
+primitive("dimen",register,dimen_val);
+@!@:dimen_}{\.{\\dimen} primitive@>
+primitive("skip",register,glue_val);
+@!@:skip_}{\.{\\skip} primitive@>
+primitive("muskip",register,mu_val);
+
+@ @<Cases of |print_cmd_chr|...@>=
+register: if chr_code=int_val then print_esc("count")
+ else if chr_code=attr_val then print_esc("attribute")
+ else if chr_code=dimen_val then print_esc("dimen")
+ else if chr_code=glue_val then print_esc("skip")
+ else print_esc("muskip");
+
+@ OK, we're ready for |scan_something_internal| itself. A second parameter,
+|negative|, is set |true| if the value that is found should be negated.
+It is assumed that |cur_cmd| and |cur_chr| represent the first token of
+the internal quantity to be scanned; an error will be signalled if
+|cur_cmd<min_internal| or |cur_cmd>max_internal|.
+
+@d scanned_result_end(#)==cur_val_level:=#;@+end
+@d scanned_result(#)==@+begin cur_val:=#;scanned_result_end
+
+@p procedure scan_something_internal(@!level:small_number;@!negative:boolean);
+ {fetch an internal parameter}
+label exit;
+var m:halfword; {|chr_code| part of the operand token}
+ n, k: integer; {accumulators}
+@!q:halfword; {general purpose index}
+@!p:0..nest_size; {index into |nest|}
+begin m:=cur_chr;
+case cur_cmd of
+def_code: @<Fetch a character code from some table@>;
+extdef_code: @<Fetch an ext character code from some table@>;
+toks_register,assign_toks,def_family,set_font,def_font,letterspace_font: @<Fetch a token list or
+ font identifier, provided that |level=tok_val|@>;
+assign_int: scanned_result(eqtb[m].int)(int_val);
+assign_attr: scanned_result(eqtb[m].int)(int_val);
+assign_box_dir: begin
+ scan_register_num;
+ m:=cur_val;
+ if box(m)<>null then cur_val:=box_dir(box(m))
+ else cur_val:=0;
+ cur_val_level:=dir_val;
+ end;
+assign_dir: scanned_result(eqtb[m].int)(dir_val);
+assign_dimen: scanned_result(eqtb[m].sc)(dimen_val);
+assign_glue: scanned_result(equiv(m))(glue_val);
+assign_mu_glue: scanned_result(equiv(m))(mu_val);
+set_aux: @<Fetch the |space_factor| or the |prev_depth|@>;
+set_prev_graf: @<Fetch the |prev_graf|@>;
+set_page_int:@<Fetch the |dead_cycles| or the |insert_penalties|@>;
+set_page_dimen: @<Fetch something on the |page_so_far|@>;
+set_shape: @<Fetch the |par_shape| size@>;
+set_box_dimen: @<Fetch a box dimension@>;
+char_given,math_given,omath_given: scanned_result(cur_chr)(int_val);
+assign_font_dimen: @<Fetch a font dimension@>;
+assign_font_int: @<Fetch a font integer@>;
+register: @<Fetch a register@>;
+last_item: @<Fetch an item in the current node, if appropriate@>;
+othercases @<Complain that \.{\\the} can't do this; give zero result@>
+endcases;@/
+while cur_val_level>level do @<Convert \(c)|cur_val| to a lower level@>;
+@<Fix the reference count, if any, and negate |cur_val| if |negative|@>;
+exit:end;
+
+procedure scan_something_simple(@!cmd:halfword;@!subitem:halfword);
+ {fetch an internal parameter}
+label exit;
+var m:halfword; {|chr_code| part of the operand token}
+@!p:0..nest_size; {index into |nest|}
+@!level:small_number; { allowed level}
+begin m:=subitem; level:=tok_val;
+case cmd of
+assign_toks: scanned_result(equiv(m))(tok_val);
+assign_int: scanned_result(eqtb[m].int)(int_val);
+assign_attr: scanned_result(eqtb[m].int)(int_val);
+assign_dir: scanned_result(eqtb[m].int)(dir_val);
+assign_dimen: scanned_result(eqtb[m].sc)(dimen_val);
+assign_glue: scanned_result(equiv(m))(glue_val);
+assign_mu_glue: scanned_result(equiv(m))(mu_val);
+set_aux: @<Fetch the |space_factor| or the |prev_depth|@>;
+set_prev_graf: @<Fetch the |prev_graf|@>;
+set_page_int:@<Fetch the |dead_cycles| or the |insert_penalties|@>;
+set_page_dimen: @<Fetch something on the |page_so_far|@>;
+set_shape: @<Fetch the |par_shape| size@>;
+char_given,math_given,omath_given: scanned_result(m)(int_val); {TH: TODO, doesnt work}
+othercases @<Complain that |texlib| can't do this; give zero result@>
+endcases;@/
+exit:end;
+
+@ @<Fetch a character code from some table@>=
+begin scan_char_num;
+if m=math_code_base then begin
+ cur_val1:=get_math_code(cur_val);
+ if ((cur_val1 div @"1000000)>8) or
+ (((cur_val1 mod @"1000000) div @"10000)>15) or
+ ((cur_val1 mod @"10000)>255) then
+ begin print_err("Extended mathchar used as mathchar");
+@.Bad mathchar@>
+ help2("A mathchar number must be between 0 and ""7FFF.")@/
+ ("I changed this one to zero."); int_error(cur_val1); cur_val1:=0;
+ end;
+ cur_val1:=((cur_val1 div @"1000000)*@"1000) +
+ (((cur_val1 mod @"1000000) div @"10000)*@"100) +
+ (cur_val1 mod @"10000);
+ scanned_result(cur_val1)(int_val);
+ end
+else if m=lc_code_base then begin
+ cur_val1:=get_lc_code(cur_val);
+ scanned_result(cur_val1)(int_val);
+ end
+else if m=uc_code_base then begin
+ cur_val1:=get_uc_code(cur_val);
+ scanned_result(cur_val1)(int_val);
+ end
+else if m=sf_code_base then begin
+ cur_val1:=get_sf_code(cur_val);
+ scanned_result(cur_val1)(int_val);
+ end
+else if m=cat_code_base then begin
+ cur_val1:=get_cat_code(cat_code_table,cur_val);
+ scanned_result(cur_val1)(int_val);
+ end
+else if m<math_code_base then scanned_result(equiv(m+cur_val))(int_val)
+else scanned_result(eqtb[m+cur_val].int)(int_val);
+end
+
+@ @<Fetch an ext character code from some table@>=
+begin scan_char_num;
+if m=math_code_base then scanned_result(get_math_code(cur_val))(int_val)
+{ TH: next two lines should not be possible }
+else if m<math_code_base then scanned_result(equiv(m+cur_val))(int_val)
+else scanned_result(eqtb[m+cur_val].int)(int_val);
+end
+
+@ @<Fetch a token list...@>=
+if level<>tok_val then
+ begin print_err("Missing number, treated as zero");
+@.Missing number...@>
+ help3("A number should have been here; I inserted `0'.")@/
+ ("(If you can't figure out why I needed to see a number,")@/
+ ("look up `weird error' in the index to The TeXbook.)");
+@:TeXbook}{\sl The \TeX book@>
+ back_error; scanned_result(0)(dimen_val);
+ end
+else if cur_cmd<=assign_toks then
+ begin if cur_cmd<assign_toks then {|cur_cmd=toks_register|}
+ begin scan_register_num; m:=toks_base+cur_val;
+ end;
+ scanned_result(equiv(m))(tok_val);
+ end
+else begin back_input; scan_font_ident;
+ scanned_result(font_id_base+cur_val)(ident_val);
+ end
+
+@ Users refer to `\.{\\the\\spacefactor}' only in horizontal
+mode, and to `\.{\\the\\prevdepth}' only in vertical mode; so we put the
+associated mode in the modifier part of the |set_aux| command.
+The |set_page_int| command has modifier 0 or 1, for `\.{\\deadcycles}' and
+`\.{\\insertpenalties}', respectively. The |set_box_dimen| command is
+modified by either |width_offset|, |height_offset|, or |depth_offset|.
+And the |last_item| command is modified by either |int_val|, |dimen_val|,
+|glue_val|, |input_line_no_code|, or |badness_code|.
+\pdfTeX\ adds the codes for its extensions: |pdftex_version_code|, \dots\ .
+\eTeX\ inserts |last_node_type_code| after |glue_val| and adds
+the codes for its extensions: |eTeX_version_code|, \dots\ .
+
+@d last_node_type_code=glue_val+1 {code for \.{\\lastnodetype}}
+@d input_line_no_code=glue_val+2 {code for \.{\\inputlineno}}
+@d badness_code=input_line_no_code+1 {code for \.{\\badness}}
+@#
+@d pdftex_first_rint_code = badness_code + 1 {base for \pdfTeX's command codes}
+@d pdftex_version_code = pdftex_first_rint_code + 0 {code for \.{\\pdftexversion}}
+@d pdf_last_obj_code = pdftex_first_rint_code + 1 {code for \.{\\pdflastobj}}
+@d pdf_last_xform_code = pdftex_first_rint_code + 2 {code for \.{\\pdflastxform}}
+@d pdf_last_ximage_code = pdftex_first_rint_code + 3 {code for \.{\\pdflastximage}}
+@d pdf_last_ximage_pages_code = pdftex_first_rint_code + 4 {code for \.{\\pdflastximagepages}}
+@d pdf_last_annot_code = pdftex_first_rint_code + 5 {code for \.{\\pdflastannot}}
+@d pdf_last_x_pos_code = pdftex_first_rint_code + 6 {code for \.{\\pdflastxpos}}
+@d pdf_last_y_pos_code = pdftex_first_rint_code + 7 {code for \.{\\pdflastypos}}
+@d pdf_retval_code = pdftex_first_rint_code + 8 {global multi-purpose return value}
+@d pdf_last_ximage_colordepth_code = pdftex_first_rint_code + 9 {code for \.{\\pdflastximagecolordepth}}
+@d random_seed_code = pdftex_first_rint_code + 10 {code for \.{\\pdfrandomseed}}
+@d pdf_last_link_code = pdftex_first_rint_code + 11 {code for \.{\\pdflastlink}}
+@d luatex_version_code = pdftex_first_rint_code + 12 {code for \.{\\luatexversion}}
+@d pdftex_last_item_codes = pdftex_first_rint_code + 12 {end of \pdfTeX's command codes}
+@#
+@d Aleph_int=pdftex_last_item_codes+1 {first of \Aleph\ codes for integers}
+@d Aleph_int_num=5 {number of \Aleph\ integers}
+@d eTeX_int=Aleph_int+Aleph_int_num {first of \eTeX\ codes for integers}
+@d eTeX_dim=eTeX_int+8 {first of \eTeX\ codes for dimensions}
+@d eTeX_glue=eTeX_dim+9 {first of \eTeX\ codes for glue}
+@d eTeX_mu=eTeX_glue+1 {first of \eTeX\ codes for muglue}
+@d eTeX_expr=eTeX_mu+1 {first of \eTeX\ codes for expressions}
+
+@<Put each...@>=
+primitive("spacefactor",set_aux,hmode);
+@!@:space_factor_}{\.{\\spacefactor} primitive@>
+primitive("prevdepth",set_aux,vmode);@/
+@!@:prev_depth_}{\.{\\prevdepth} primitive@>
+primitive("deadcycles",set_page_int,0);
+@!@:dead_cycles_}{\.{\\deadcycles} primitive@>
+primitive("insertpenalties",set_page_int,1);
+@!@:insert_penalties_}{\.{\\insertpenalties} primitive@>
+primitive("wd",set_box_dimen,width_offset);
+@!@:wd_}{\.{\\wd} primitive@>
+primitive("ht",set_box_dimen,height_offset);
+@!@:ht_}{\.{\\ht} primitive@>
+primitive("dp",set_box_dimen,depth_offset);
+@!@:dp_}{\.{\\dp} primitive@>
+primitive("lastpenalty",last_item,int_val);
+@!@:last_penalty_}{\.{\\lastpenalty} primitive@>
+primitive("lastkern",last_item,dimen_val);
+@!@:last_kern_}{\.{\\lastkern} primitive@>
+primitive("lastskip",last_item,glue_val);
+@!@:last_skip_}{\.{\\lastskip} primitive@>
+primitive("inputlineno",last_item,input_line_no_code);
+@!@:input_line_no_}{\.{\\inputlineno} primitive@>
+primitive("badness",last_item,badness_code);
+@!@:badness_}{\.{\\badness} primitive@>
+primitive("pdftexversion",last_item,pdftex_version_code);@/
+@!@:pdftex_version_}{\.{\\pdftexversion} primitive@>
+primitive("luatexversion",last_item,luatex_version_code);@/
+@!@:luatex_version_}{\.{\\luatexversion} primitive@>
+primitive("pdflastobj",last_item,pdf_last_obj_code);@/
+@!@:pdf_last_obj_}{\.{\\pdflastobj} primitive@>
+primitive("pdflastxform",last_item,pdf_last_xform_code);@/
+@!@:pdf_last_xform_}{\.{\\pdflastxform} primitive@>
+primitive("pdflastximage",last_item,pdf_last_ximage_code);@/
+@!@:pdf_last_ximage_}{\.{\\pdflastximage} primitive@>
+primitive("pdflastximagepages",last_item,pdf_last_ximage_pages_code);@/
+@!@:pdf_last_ximage_pages_}{\.{\\pdflastximagepages} primitive@>
+primitive("pdflastannot",last_item,pdf_last_annot_code);@/
+@!@:pdf_last_annot_}{\.{\\pdflastannot} primitive@>
+primitive("pdflastxpos",last_item,pdf_last_x_pos_code);@/
+@!@:pdf_last_x_pos_}{\.{\\pdflastxpos} primitive@>
+primitive("pdflastypos",last_item,pdf_last_y_pos_code);@/
+@!@:pdf_last_y_pos_}{\.{\\pdflastypos} primitive@>
+primitive("pdfretval",last_item,pdf_retval_code);@/
+@!@:pdf_retval_}{\.{\\pdfretval} primitive@>
+primitive("pdflastximagecolordepth",last_item,pdf_last_ximage_colordepth_code);@/
+@!@:pdf_last_ximage_colordepth_}{\.{\\pdflastximagecolordepth} primitive@>
+primitive("pdfrandomseed",last_item,random_seed_code);
+@!@:random_seed_}{\.{\\pdfrandomseed} primitive@>
+primitive("pdflastlink",last_item,pdf_last_link_code);@/
+@!@:pdf_last_link_}{\.{\\pdflastlink} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+set_aux: if chr_code=vmode then print_esc("prevdepth")
+@+else print_esc("spacefactor");
+set_page_int: if chr_code=0 then print_esc("deadcycles")
+@/@<Cases of |set_page_int| for |print_cmd_chr|@>@/
+@+else print_esc("insertpenalties");
+set_box_dimen: if chr_code=width_offset then print_esc("wd")
+else if chr_code=height_offset then print_esc("ht")
+else print_esc("dp");
+last_item: case chr_code of
+ int_val: print_esc("lastpenalty");
+ dimen_val: print_esc("lastkern");
+ glue_val: print_esc("lastskip");
+ input_line_no_code: print_esc("inputlineno");
+ @/@<Cases of |last_item| for |print_cmd_chr|@>@/
+ pdftex_version_code: print_esc("pdftexversion");
+ luatex_version_code: print_esc("luatexversion");
+ pdf_last_obj_code: print_esc("pdflastobj");
+ pdf_last_xform_code: print_esc("pdflastxform");
+ pdf_last_ximage_code: print_esc("pdflastximage");
+ pdf_last_ximage_pages_code: print_esc("pdflastximagepages");
+ pdf_last_annot_code: print_esc("pdflastannot");
+ pdf_last_x_pos_code: print_esc("pdflastxpos");
+ pdf_last_y_pos_code: print_esc("pdflastypos");
+ pdf_retval_code: print_esc("pdfretval");
+ pdf_last_ximage_colordepth_code: print_esc("pdflastximagecolordepth");
+ random_seed_code: print_esc("pdfrandomseed");
+ pdf_last_link_code: print_esc("pdflastlink");
+ othercases print_esc("badness")
+ endcases;
+
+@ @<Fetch the |space_factor| or the |prev_depth|@>=
+if abs(mode)<>m then
+ begin print_err("Improper "); print_cmd_chr(set_aux,m);
+@.Improper \\spacefactor@>
+@.Improper \\prevdepth@>
+ help4("You can refer to \spacefactor only in horizontal mode;")@/
+ ("you can refer to \prevdepth only in vertical mode; and")@/
+ ("neither of these is meaningful inside \write. So")@/
+ ("I'm forgetting what you said and using zero instead.");
+ error;
+ if level<>tok_val then scanned_result(0)(dimen_val)
+ else scanned_result(0)(int_val);
+ end
+else if m=vmode then
+ begin cur_val:=prev_depth; cur_val_level:=dimen_val;
+ end
+else begin cur_val:=space_factor; cur_val_level:=int_val;
+ end
+
+@ @<Fetch the |dead_cycles| or the |insert_penalties|@>=
+begin if m=0 then cur_val:=dead_cycles
+@/@<Cases for `Fetch the |dead_cycles| or the |insert_penalties|'@>@/
+else cur_val:=insert_penalties;
+cur_val_level:=int_val;
+end
+
+@ @<Fetch a box dimension@>=
+begin scan_register_num;
+if box(cur_val)=null then cur_val:=0 @+else cur_val:=vmem(box(cur_val)+m).sc;
+cur_val_level:=dimen_val;
+end
+
+@ Inside an \.{\\output} routine, a user may wish to look at the page totals
+that were present at the moment when output was triggered.
+
+@d max_dimen==@'7777777777 {$2^{30}-1$}
+
+@<Fetch something on the |page_so_far|@>=
+begin if (page_contents=empty) and (not output_active) then
+ if m=0 then cur_val:=max_dimen@+else cur_val:=0
+else cur_val:=page_so_far[m];
+cur_val_level:=dimen_val;
+end
+
+@ @<Fetch the |prev_graf|@>=
+if mode=0 then scanned_result(0)(int_val) {|prev_graf=0| within \.{\\write}}
+else begin nest[nest_ptr]:=cur_list; p:=nest_ptr;
+ while abs(nest[p].mode_field)<>vmode do decr(p);
+ scanned_result(nest[p].pg_field)(int_val);
+ end
+
+@ @<Fetch the |par_shape| size@>=
+begin if m>par_shape_loc then @<Fetch a penalties array element@>
+else if par_shape_ptr=null then cur_val:=0
+else cur_val:=vinfo(par_shape_ptr);
+cur_val_level:=int_val;
+end
+
+@ Here is where \.{\\lastpenalty}, \.{\\lastkern}, and \.{\\lastskip} are
+implemented. The reference count for \.{\\lastskip} will be updated later.
+
+We also handle \.{\\inputlineno} and \.{\\badness} here, because they are
+legal in similar contexts.
+
+@<Fetch an item in the current node...@>=
+if m>=input_line_no_code then
+ if m>=eTeX_glue then @<Process an expression and |return|@>@;
+ else if m>=eTeX_dim then
+ begin case m of
+ @/@<Cases for fetching a dimension value@>@/
+ end; {there are no other cases}
+ cur_val_level:=dimen_val;
+ end
+ else begin case m of
+ input_line_no_code: cur_val:=line;
+ badness_code: cur_val:=last_badness;
+ pdftex_version_code: cur_val := pdftex_version;
+ luatex_version_code: cur_val := luatex_version;
+ pdf_last_obj_code: cur_val := pdf_last_obj;
+ pdf_last_xform_code: cur_val := pdf_last_xform;
+ pdf_last_ximage_code: cur_val := pdf_last_ximage;
+ pdf_last_ximage_pages_code: cur_val := pdf_last_ximage_pages;
+ pdf_last_annot_code: cur_val := pdf_last_annot;
+ pdf_last_x_pos_code: cur_val := pdf_last_x_pos;
+ pdf_last_y_pos_code: cur_val := pdf_last_y_pos;
+ pdf_retval_code: cur_val := pdf_retval;
+ pdf_last_ximage_colordepth_code: cur_val := pdf_last_ximage_colordepth;
+ random_seed_code: cur_val := random_seed;
+ pdf_last_link_code: cur_val := pdf_last_link;
+ @/@<Cases for fetching an integer value@>@/
+ end; {there are no other cases}
+ cur_val_level:=int_val;
+ end
+else begin if cur_chr=glue_val then cur_val:=zero_glue@+else cur_val:=0;
+ if cur_chr=last_node_type_code then
+ begin cur_val_level:=int_val;
+ if (tail=head)or(mode=0) then cur_val:=-1;
+ end
+ else cur_val_level:=cur_chr;
+ {TODO: check this thoroughly! The structural change to the
+ |is_char_node| macro was wreaking havoc here, and possibly elsewhere.}
+ if tail<>contrib_head and not is_char_node(tail)and(mode<>0) then
+ case cur_chr of
+ int_val: if type(tail)=penalty_node then cur_val:=penalty(tail);
+ dimen_val: if type(tail)=kern_node then cur_val:=width(tail);
+ glue_val: if type(tail)=glue_node then
+ begin cur_val:=glue_ptr(tail);
+ if subtype(tail)=mu_glue then cur_val_level:=mu_val;
+ end;
+ last_node_type_code:
+ cur_val := visible_last_node_type(tail);
+ end {there are no other cases}
+ else if (mode=vmode)and(tail=head) then
+ case cur_chr of
+ int_val: cur_val:=last_penalty;
+ dimen_val: cur_val:=last_kern;
+ glue_val: if last_glue<>max_halfword then cur_val:=last_glue;
+ last_node_type_code: cur_val:=last_node_type;
+ end; {there are no other cases}
+ end
+
+@ @<Fetch a font dimension@>=
+get_font_dimen
+
+@ @<Fetch a font integer@>=
+begin scan_font_ident;
+if m=0 then scanned_result(hyphen_char(cur_val))(int_val)
+else if m=1 then scanned_result(skew_char(cur_val))(int_val)
+else if m=no_lig_code then scanned_result(test_no_ligatures(cur_val))(int_val)
+else begin
+ n := cur_val;
+ scan_char_num;
+ k := cur_val;
+ case m of
+ lp_code_base: scanned_result(get_lp_code(n, k))(int_val);
+ rp_code_base: scanned_result(get_rp_code(n, k))(int_val);
+ ef_code_base: scanned_result(get_ef_code(n, k))(int_val);
+ tag_code: scanned_result(get_tag_code(n, k))(int_val);
+ end;
+end;
+end
+
+@ @<Fetch a register@>=
+begin scan_register_num;
+case m of
+int_val:cur_val:=count(cur_val);
+attr_val:cur_val:=attribute(cur_val);
+dimen_val:cur_val:=dimen(cur_val);
+glue_val: cur_val:=skip(cur_val);
+mu_val: cur_val:=mu_skip(cur_val);
+end; {there are no other cases}
+cur_val_level:=m;
+end
+
+@ @<Complain that \.{\\the} can't do this; give zero result@>=
+begin print_err("You can't use `"); print_cmd_chr(cur_cmd,cur_chr);
+@.You can't use x after ...@>
+print("' after "); print_esc("the");
+help1("I'm forgetting what you said and using zero instead.");
+error;
+if level<>tok_val then scanned_result(0)(dimen_val)
+else scanned_result(0)(int_val);
+end
+
+@ @<Complain that |texlib| can't do this; give zero result@>=
+begin print_err("You can't use `"); print_cmd_chr(cmd,m);
+print("' as tex library index");
+help1("I'm forgetting what you said and using zero instead.");
+error;
+if level<>tok_val then scanned_result(0)(dimen_val)
+else scanned_result(0)(int_val);
+end
+
+
+@ When a |glue_val| changes to a |dimen_val|, we use the width component
+of the glue; there is no need to decrease the reference count, since it
+has not yet been increased. When a |dimen_val| changes to an |int_val|,
+we use scaled points so that the value doesn't actually change. And when a
+|mu_val| changes to a |glue_val|, the value doesn't change either.
+
+@<Convert \(c)|cur_val| to a lower level@>=
+begin if cur_val_level=glue_val then cur_val:=width(cur_val)
+else if cur_val_level=mu_val then mu_error;
+decr(cur_val_level);
+end
+
+@ If |cur_val| points to a glue specification at this point, the reference
+count for the glue does not yet include the reference by |cur_val|.
+If |negative| is |true|, |cur_val_level| is known to be |<=mu_val|.
+
+@<Fix the reference count, if any, ...@>=
+if negative then
+ if cur_val_level>=glue_val then
+ begin cur_val:=new_spec(cur_val);
+ @<Negate all three glue components of |cur_val|@>;
+ end
+ else negate(cur_val)
+else if (cur_val_level>=glue_val)and(cur_val_level<=mu_val) then
+ add_glue_ref(cur_val)
+
+@ @<Negate all three...@>=
+begin negate(width(cur_val));
+negate(stretch(cur_val));
+negate(shrink(cur_val));
+end
+
+@ Our next goal is to write the |scan_int| procedure, which scans anything that
+\TeX\ treats as an integer. But first we might as well look at some simple
+applications of |scan_int| that have already been made inside of
+|scan_something_internal|.
+
+@
+@d dir_T=0
+@d dir_L=1
+@d dir_B=2
+@d dir_R=3
+@d dir_eq_end(#)==(#)
+@d dir_eq(#)==(#)=dir_eq_end
+@d dir_ne_end(#)==(#)
+@d dir_ne(#)==(#)<>dir_ne_end
+@d dir_opposite_end(#)==((#) mod 4)
+@d dir_opposite(#)==(((#)+2) mod 4)=dir_opposite_end
+@d dir_parallel_end(#)==((#) mod 2)
+@d dir_parallel(#)==((#) mod 2)=dir_parallel_end
+@d dir_orthogonal_end(#)==(# mod 2)
+@d dir_orthogonal(#)==((#) mod 2)<>dir_orthogonal_end
+@d dir_next_end(#)==((#) mod 4)
+@d dir_next(#)==(((#)+3) mod 4)=dir_next_end
+@d dir_prev_end(#)==((#) mod 4)
+@d dir_prev(#)==(((#)+1) mod 4)=dir_prev_end
+
+{box directions}
+@d dir_TL_=0
+@d dir_TR_=1
+@d dir_LT_=2
+@d dir_LB_=3
+@d dir_BL_=4
+@d dir_BR_=5
+@d dir_RT_=6
+@d dir_RB_=7
+
+{font directions}
+@d dir__LT= 0
+@d dir__LL= 1
+@d dir__LB= 2
+@d dir__LR= 3
+@d dir__RT= 4
+@d dir__RL= 5
+@d dir__RB= 6
+@d dir__RR= 7
+@d dir__TT= 8
+@d dir__TL= 9
+@d dir__TB=10
+@d dir__TR=11
+@d dir__BT=12
+@d dir__BL=13
+@d dir__BB=14
+@d dir__BR=15
+
+@d is_mirrored(#)==dir_opposite(dir_primary[#])(dir_tertiary[#])
+@d is_rotated(#)==dir_parallel(dir_secondary[#])(dir_tertiary[#])
+@d font_direction(#)==(# mod 16)
+@d box_direction(#)==(# div 4)
+
+@d scan_single_dir(#)==begin
+if scan_keyword("T") then #:=dir_T
+else if scan_keyword("L") then #:=dir_L
+else if scan_keyword("B") then #:=dir_B
+else if scan_keyword("R") then #:=dir_R
+else begin
+ print_err("Bad direction"); cur_val:=0;
+ goto exit;
+ end
+end
+
+@<Declare procedures that scan restricted classes of integers@>=
+procedure scan_direction;
+var d1,d2,d3: integer;
+begin
+get_x_token;
+if cur_cmd=assign_dir then begin
+ cur_val:=eqtb[cur_chr].int;
+ goto exit;
+ end
+else back_input;
+scan_single_dir(d1);
+scan_single_dir(d2);
+if dir_parallel(d1)(d2) then begin
+ print_err("Bad direction"); cur_val:=0;
+ goto exit;
+ end;
+scan_single_dir(d3);
+cur_val:=d1*8+dir_rearrange[d2]*4+d3;
+exit:
+end;
+
+@ It is nice to have routines that say what they do, so the original
+|scan_eight_bit_int| is superceded by |scan_register_num| and
+|scan_mark_num|. It may become split up even further in the future.
+
+@<Declare procedures that scan restricted classes of integers@>=
+procedure scan_register_num;
+begin scan_int;
+if (cur_val<0)or(cur_val>biggest_reg) then
+ begin print_err("Bad register code");
+@.Bad register code@>
+ help2("A register number must be between 0 and 65535.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+procedure scan_mark_num;
+begin scan_int;
+if (cur_val<0)or(cur_val>biggest_mark) then
+ begin print_err("Bad marks code");
+@.Bad marks code@>
+ help2("A marks class must be between 0 and 65535.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+
+@ @<Declare procedures that scan restricted classes of integers@>=
+procedure scan_char_num;
+begin scan_int;
+if (cur_val<0)or(cur_val>biggest_char) then
+ begin print_err("Bad character code");
+@.Bad character code@>
+ help2("A character number must be between 0 and biggest_char.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+
+@ While we're at it, we might as well deal with similar routines that
+will be needed later.
+
+@<Declare procedures that scan restricted classes of integers@>=
+procedure scan_four_bit_int;
+begin scan_int;
+if (cur_val<0)or(cur_val>15) then
+ begin print_err("Bad number");
+@.Bad number@>
+ help2("Since I expected to read a number between 0 and 15,")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+procedure scan_math_family_int;
+begin scan_int;
+if (cur_val<0)or(cur_val>255) then
+ begin print_err("Bad number");
+@.Bad number@>
+ help2("Since I expected to read a number between 0 and 255,")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+
+@ @<Declare procedures that scan restricted classes of integers@>=
+procedure scan_real_fifteen_bit_int;
+begin scan_int;
+if (cur_val<0)or(cur_val>@'77777) then
+ begin print_err("Bad mathchar");
+@.Bad mathchar@>
+ help2("A mathchar number must be between 0 and 32767.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+procedure scan_fifteen_bit_int;
+begin scan_int;
+if (cur_val<0)or(cur_val>@'77777) then
+ begin print_err("Bad mathchar");
+@.Bad mathchar@>
+ help2("A mathchar number must be between 0 and 32767.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+cur_val := ((cur_val div @"1000) * @"1000000) +
+ (((cur_val mod @"1000) div @"100) * @"10000) +
+ (cur_val mod @"100);
+end;
+procedure scan_big_fifteen_bit_int;
+begin scan_int;
+if (cur_val<0)or(cur_val>@"7FFFFFF) then
+ begin print_err("Bad extended mathchar");
+@.Bad mathchar@>
+ help2("An extended mathchar number must be between 0 and ""7FFFFFF.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+end;
+
+
+@ @<Declare procedures that scan restricted classes of integers@>=
+procedure scan_twenty_seven_bit_int;
+begin scan_int;
+if (cur_val<0)or(cur_val>@'777777777) then
+ begin print_err("Bad delimiter code");
+@.Bad delimiter code@>
+ help2("A numeric delimiter code must be between 0 and 2^{27}-1.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+cur_val1 := (((cur_val mod @"1000) div @"100) * @"10000) +
+ (cur_val mod @"100);
+cur_val := cur_val div @"1000;
+cur_val := ((cur_val div @"1000) * @"1000000) +
+ (((cur_val mod @"1000) div @"100) * @"10000) +
+ (cur_val mod @"100);
+end;
+
+procedure scan_fifty_one_bit_int;
+var iiii:integer;
+begin scan_int;
+if (cur_val<0)or(cur_val>@'777777777) then
+ begin print_err("Bad delimiter code");
+@.Bad delimiter code@>
+ help2("A numeric delimiter (first part) must be between 0 and 2^{27}-1.")
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+iiii:=cur_val;
+scan_int;
+if (cur_val<0)or(cur_val>@"FFFFFF) then
+ begin print_err("Bad delimiter code");
+@.Bad delimiter code@>
+help2("A numeric delimiter (second part) must be between 0 and 2^{24}-1.")@/
+ ("I changed this one to zero."); int_error(cur_val); cur_val:=0;
+ end;
+cur_val1:=cur_val;
+cur_val:=iiii;
+end;
+
+
+procedure scan_string_argument;
+var s:integer;
+begin
+scan_left_brace;
+get_x_token;
+while (cur_cmd<>right_brace) do
+ begin
+ if (cur_cmd=letter) or (cur_cmd=other_char) then begin
+ str_room(1); append_char(cur_chr);
+ end
+ else if (cur_cmd=spacer) then begin
+ str_room(1); append_char(" ");
+ end
+ else begin
+ print("Bad token appearing in string argument");
+ end;
+ get_x_token;
+ end;
+s:=make_string;
+if str_eq_str("mi",s) then s:="mi";
+if str_eq_str("mo",s) then s:="mo";
+if str_eq_str("mn",s) then s:="mn";
+cur_val:=s;
+end;
+
+@ An integer number can be preceded by any number of spaces and `\.+' or
+`\.-' signs. Then comes either a decimal constant (i.e., radix 10), an
+octal constant (i.e., radix 8, preceded by~\.\'), a hexadecimal constant
+(radix 16, preceded by~\."), an alphabetic constant (preceded by~\.\`), or
+an internal variable. After scanning is complete,
+|cur_val| will contain the answer, which must be at most
+$2^{31}-1=2147483647$ in absolute value. The value of |radix| is set to
+10, 8, or 16 in the cases of decimal, octal, or hexadecimal constants,
+otherwise |radix| is set to zero. An optional space follows a constant.
+
+@d octal_token=other_token+"'" {apostrophe, indicates an octal constant}
+@d hex_token=other_token+"""" {double quote, indicates a hex constant}
+@d alpha_token=other_token+"`" {reverse apostrophe, precedes alpha constants}
+@d point_token=other_token+"." {decimal point}
+@d continental_point_token=other_token+"," {decimal point, Eurostyle}
+
+@<Glob...@>=
+@!radix:small_number; {|scan_int| sets this to 8, 10, 16, or zero}
+
+@ We initialize the following global variables just in case |expand|
+comes into action before any of the basic scanning routines has assigned
+them a value.
+
+@<Set init...@>=
+cur_val:=0; cur_val_level:=int_val; radix:=0; cur_order:=0;
+
+@ The |scan_int| routine is used also to scan the integer part of a
+fraction; for example, the `\.3' in `\.{3.14159}' will be found by
+|scan_int|. The |scan_dimen| routine assumes that |cur_tok=point_token|
+after the integer part of such a fraction has been scanned by |scan_int|,
+and that the decimal point has been backed up to be scanned again.
+
+@p procedure scan_int; {sets |cur_val| to an integer}
+label done;
+var negative:boolean; {should the answer be negated?}
+@!m:integer; {|@t$2^{31}$@> div radix|, the threshold of danger}
+@!d:small_number; {the digit just scanned}
+@!vacuous:boolean; {have no digits appeared?}
+@!OK_so_far:boolean; {has an error message been issued?}
+begin radix:=0; OK_so_far:=true;@/
+@<Get the next non-blank non-sign token; set |negative| appropriately@>;
+if cur_tok=alpha_token then @<Scan an alphabetic character code into |cur_val|@>
+else if (cur_cmd>=min_internal)and(cur_cmd<=max_internal) then
+ scan_something_internal(int_val,false)
+else @<Scan a numeric constant@>;
+if negative then negate(cur_val);
+end;
+
+@ @<Get the next non-blank non-sign token...@>=
+negative:=false;
+repeat @<Get the next non-blank non-call token@>;
+if cur_tok=other_token+"-" then
+ begin negative := not negative; cur_tok:=other_token+"+";
+ end;
+until cur_tok<>other_token+"+"
+
+@ A space is ignored after an alphabetic character constant, so that
+such constants behave like numeric ones.
+
+@<Scan an alphabetic character code into |cur_val|@>=
+begin get_token; {suppress macro expansion}
+if cur_tok<cs_token_flag then
+ begin cur_val:=cur_chr;
+ if cur_cmd<=right_brace then
+ if cur_cmd=right_brace then incr(align_state)
+ else decr(align_state);
+ end
+else if cur_tok<cs_token_flag+null_cs then
+ cur_val:=cur_tok-cs_token_flag-active_base
+else begin {the value of a csname in this context is its name}
+ if single_letter(text(cur_tok-cs_token_flag)) then
+ cur_val:=pool_to_unichar(str_start_macro(text(cur_tok-cs_token_flag)))
+ else
+ cur_val:=too_big_char;
+end;
+if cur_val>biggest_char then
+ begin print_err("Improper alphabetic constant");
+@.Improper alphabetic constant@>
+ help2("A one-character control sequence belongs after a ` mark.")@/
+ ("So I'm essentially inserting \0 here.");
+ cur_val:="0"; back_error;
+ end
+else @<Scan an optional space@>;
+end
+
+@ @<Scan an optional space@>=
+begin get_x_token; if cur_cmd<>spacer then back_input;
+end
+
+@ @<Scan a numeric constant@>=
+begin radix:=10; m:=214748364;
+if cur_tok=octal_token then
+ begin radix:=8; m:=@'2000000000; get_x_token;
+ end
+else if cur_tok=hex_token then
+ begin radix:=16; m:=@'1000000000; get_x_token;
+ end;
+vacuous:=true; cur_val:=0;@/
+@<Accumulate the constant until |cur_tok| is not a suitable digit@>;
+if vacuous then @<Express astonishment that no number was here@>
+else if cur_cmd<>spacer then back_input;
+end
+
+@ @d infinity==@'17777777777 {the largest positive value that \TeX\ knows}
+@d zero_token=other_token+"0" {zero, the smallest digit}
+@d A_token=letter_token+"A" {the smallest special hex digit}
+@d other_A_token=other_token+"A" {special hex digit of type |other_char|}
+
+@<Accumulate the constant...@>=
+loop@+ begin if (cur_tok<zero_token+radix)and(cur_tok>=zero_token)and
+ (cur_tok<=zero_token+9) then d:=cur_tok-zero_token
+ else if radix=16 then
+ if (cur_tok<=A_token+5)and(cur_tok>=A_token) then d:=cur_tok-A_token+10
+ else if (cur_tok<=other_A_token+5)and(cur_tok>=other_A_token) then
+ d:=cur_tok-other_A_token+10
+ else goto done
+ else goto done;
+ vacuous:=false;
+ if (cur_val>=m)and((cur_val>m)or(d>7)or(radix<>10)) then
+ begin if OK_so_far then
+ begin print_err("Number too big");
+@.Number too big@>
+ help2("I can only go up to 2147483647='17777777777=""7FFFFFFF,")@/
+ ("so I'm using that number instead of yours.");
+ error; cur_val:=infinity; OK_so_far:=false;
+ end;
+ end
+ else cur_val:=cur_val*radix+d;
+ get_x_token;
+ end;
+done:
+
+@ @<Express astonishment...@>=
+begin print_err("Missing number, treated as zero");
+@.Missing number...@>
+help3("A number should have been here; I inserted `0'.")@/
+ ("(If you can't figure out why I needed to see a number,")@/
+ ("look up `weird error' in the index to The TeXbook.)");
+@:TeXbook}{\sl The \TeX book@>
+back_error;
+end
+
+@ The |scan_dimen| routine is similar to |scan_int|, but it sets |cur_val| to
+a |scaled| value, i.e., an integral number of sp. One of its main tasks
+is therefore to interpret the abbreviations for various kinds of units and
+to convert measurements to scaled points.
+
+There are three parameters: |mu| is |true| if the finite units must be
+`\.{mu}', while |mu| is |false| if `\.{mu}' units are disallowed;
+|inf| is |true| if the infinite units `\.{fil}', `\.{fill}', `\.{filll}'
+are permitted; and |shortcut| is |true| if |cur_val| already contains
+an integer and only the units need to be considered.
+
+The order of infinity that was found in the case of infinite glue is returned
+in the global variable |cur_order|.
+
+@<Glob...@>=
+@!cur_order:glue_ord; {order of infinity found by |scan_dimen|}
+
+@ Constructions like `\.{-\'77 pt}' are legal dimensions, so |scan_dimen|
+may begin with |scan_int|. This explains why it is convenient to use
+|scan_int| also for the integer part of a decimal fraction.
+
+Several branches of |scan_dimen| work with |cur_val| as an integer and
+with an auxiliary fraction |f|, so that the actual quantity of interest is
+$|cur_val|+|f|/2^{16}$. At the end of the routine, this ``unpacked''
+representation is put into the single word |cur_val|, which suddenly
+switches significance from |integer| to |scaled|.
+
+@d attach_fraction=88 {go here to pack |cur_val| and |f| into |cur_val|}
+@d attach_sign=89 {go here when |cur_val| is correct except perhaps for sign}
+@d scan_normal_dimen==scan_dimen(false,false,false)
+
+@p procedure scan_dimen(@!mu,@!inf,@!shortcut:boolean);
+ {sets |cur_val| to a dimension}
+label done, done1, done2, found, not_found, attach_fraction, attach_sign;
+var negative:boolean; {should the answer be negated?}
+@!f:integer; {numerator of a fraction whose denominator is $2^{16}$}
+@<Local variables for dimension calculations@>@;
+begin f:=0; arith_error:=false; cur_order:=normal; negative:=false;
+if not shortcut then
+ begin @<Get the next non-blank non-sign...@>;
+ if (cur_cmd>=min_internal)and(cur_cmd<=max_internal) then
+ @<Fetch an internal dimension and |goto attach_sign|,
+ or fetch an internal integer@>
+ else begin back_input;
+ if cur_tok=continental_point_token then cur_tok:=point_token;
+ if cur_tok<>point_token then scan_int
+ else begin radix:=10; cur_val:=0;
+ end;
+ if cur_tok=continental_point_token then cur_tok:=point_token;
+ if (radix=10)and(cur_tok=point_token) then @<Scan decimal fraction@>;
+ end;
+ end;
+if cur_val<0 then {in this case |f=0|}
+ begin negative := not negative; negate(cur_val);
+ end;
+@<Scan units and set |cur_val| to $x\cdot(|cur_val|+f/2^{16})$, where there
+ are |x| sp per unit; |goto attach_sign| if the units are internal@>;
+@<Scan an optional space@>;
+attach_sign: if arith_error or(abs(cur_val)>=@'10000000000) then
+ @<Report that this dimension is out of range@>;
+if negative then negate(cur_val);
+end;
+
+@ @<Fetch an internal dimension and |goto attach_sign|...@>=
+if mu then
+ begin scan_something_internal(mu_val,false);
+ @<Coerce glue to a dimension@>;
+ if cur_val_level=mu_val then goto attach_sign;
+ if cur_val_level<>int_val then mu_error;
+ end
+else begin scan_something_internal(dimen_val,false);
+ if cur_val_level=dimen_val then goto attach_sign;
+ end
+
+@ @<Local variables for dimension calculations@>=
+@!num,@!denom:1..65536; {conversion ratio for the scanned units}
+@!k,@!kk:small_number; {number of digits in a decimal fraction}
+@!p,@!q:pointer; {top of decimal digit stack}
+@!v:scaled; {an internal dimension}
+@!save_cur_val:integer; {temporary storage of |cur_val|}
+
+@ The following code is executed when |scan_something_internal| was
+called asking for |mu_val|, when we really wanted a ``mudimen'' instead
+of ``muglue.''
+
+@<Coerce glue to a dimension@>=
+if cur_val_level>=glue_val then
+ begin v:=width(cur_val); delete_glue_ref(cur_val); cur_val:=v;
+ end
+
+@ When the following code is executed, we have |cur_tok=point_token|, but this
+token has been backed up using |back_input|; we must first discard it.
+
+It turns out that a decimal point all by itself is equivalent to `\.{0.0}'.
+Let's hope people don't use that fact.
+
+@<Scan decimal fraction@>=
+begin k:=0; p:=null; get_token; {|point_token| is being re-scanned}
+loop@+ begin get_x_token;
+ if (cur_tok>zero_token+9)or(cur_tok<zero_token) then goto done1;
+ if k<17 then {digits for |k>=17| cannot affect the result}
+ begin q:=get_avail; link(q):=p; info(q):=cur_tok-zero_token;
+ p:=q; incr(k);
+ end;
+ end;
+done1: for kk:=k downto 1 do
+ begin dig[kk-1]:=info(p); q:=p; p:=link(p); free_avail(q);
+ end;
+f:=round_decimals(k);
+if cur_cmd<>spacer then back_input;
+end
+
+@ Now comes the harder part: At this point in the program, |cur_val| is a
+nonnegative integer and $f/2^{16}$ is a nonnegative fraction less than 1;
+we want to multiply the sum of these two quantities by the appropriate
+factor, based on the specified units, in order to produce a |scaled|
+result, and we want to do the calculation with fixed point arithmetic that
+does not overflow.
+
+@<Scan units and set |cur_val| to $x\cdot(|cur_val|+f/2^{16})$...@>=
+if inf then @<Scan for \(f)\.{fil} units; |goto attach_fraction| if found@>;
+@<Scan for \(u)units that are internal dimensions;
+ |goto attach_sign| with |cur_val| set if found@>;
+if mu then @<Scan for \(m)\.{mu} units and |goto attach_fraction|@>;
+if scan_keyword("true") then @<Adjust \(f)for the magnification ratio@>;
+@.true@>
+if scan_keyword("pt") then goto attach_fraction; {the easy case}
+@.pt@>
+@<Scan for \(a)all other units and adjust |cur_val| and |f| accordingly;
+ |goto done| in the case of scaled points@>;
+attach_fraction: if cur_val>=@'40000 then arith_error:=true
+else cur_val:=cur_val*unity+f;
+done:
+
+@ In traditional TeX, a specification like `\.{filllll}' or `\.{fill L L
+L}' will lead to two error messages (one for each additional keyword
+\.{"l"}).
+
+Not so for luatex, it just parses the construct in reverse.
+
+@<Scan for \(f)\.{fil} units...@>=
+if scan_keyword("filll") then begin cur_order:=filll; goto attach_fraction; end
+else if scan_keyword("fill") then begin cur_order:=fill; goto attach_fraction; end
+else if scan_keyword("fil") then begin cur_order:=fil; goto attach_fraction; end
+else if scan_keyword("fi") then begin cur_order:=sfi; goto attach_fraction; end
+
+@ @<Scan for \(u)units that are internal dimensions...@>=
+save_cur_val:=cur_val;
+@<Get the next non-blank non-call...@>;
+if (cur_cmd<min_internal)or(cur_cmd>max_internal) then back_input
+else begin if mu then
+ begin scan_something_internal(mu_val,false); @<Coerce glue...@>;
+ if cur_val_level<>mu_val then mu_error;
+ end
+ else scan_something_internal(dimen_val,false);
+ v:=cur_val; goto found;
+ end;
+if mu then goto not_found;
+if scan_keyword("em") then v:=(@<The em width for |cur_font|@>)
+@.em@>
+else if scan_keyword("ex") then v:=(@<The x-height for |cur_font|@>)
+@.ex@>
+else if scan_keyword("px") then v:=pdf_px_dimen
+@.px@>
+else goto not_found;
+@<Scan an optional space@>;
+found:cur_val:=nx_plus_y(save_cur_val,v,xn_over_d(v,f,@'200000));
+goto attach_sign;
+not_found:
+
+@ @<Scan for \(m)\.{mu} units and |goto attach_fraction|@>=
+if scan_keyword("mu") then goto attach_fraction
+@.mu@>
+else begin print_err("Illegal unit of measure ("); print("mu inserted)");
+@.Illegal unit of measure@>
+ help4("The unit of measurement in math glue must be mu.")@/
+ ("To recover gracefully from this error, it's best to")@/
+ ("delete the erroneous units; e.g., type `2' to delete")@/
+ ("two letters. (See Chapter 27 of The TeXbook.)");
+@:TeXbook}{\sl The \TeX book@>
+ error; goto attach_fraction;
+ end
+
+@ @<Adjust \(f)for the magnification ratio@>=
+begin prepare_mag;
+if mag<>1000 then
+ begin cur_val:=xn_over_d(cur_val,1000,mag);
+ f:=(1000*f+@'200000*remainder) div mag;
+ cur_val:=cur_val+(f div @'200000); f:=f mod @'200000;
+ end;
+end
+
+@ The necessary conversion factors can all be specified exactly as
+fractions whose numerator and denominator add to 32768 or less.
+According to the definitions here, $\rm2660\,dd\approx1000.33297\,mm$;
+this agrees well with the value $\rm1000.333\,mm$ cited by Bosshard
+@^Bosshard, Hans Rudolf@>
+in {\sl Technische Grundlagen zur Satzherstellung\/} (Bern, 1980).
+The Didot point has been newly standardized in 1978;
+it's now exactly $\rm 1\,nd=0.375\,mm$.
+Conversion uses the equation $0.375=21681/20320/72.27\cdot25.4$.
+The new Cicero follows the new Didot point; $\rm 1\,nc=12\,nd$. These
+would lead to the ratios $21681/20320$ and $65043/5080$, respectively.
+The closest approximations supported by the algorithm would be
+$11183/10481$ and $1370/107$. In order to maintain the
+relation $\rm 1\,nc=12\,nd$, we pick the ratio $685/642$ for $\rm nd$,
+however.
+
+@d set_conversion_end(#)== denom:=#; end
+@d set_conversion(#)==@+begin num:=#; set_conversion_end
+
+@<Scan for \(a)all other units and adjust |cur_val| and |f|...@>=
+if scan_keyword("in") then set_conversion(7227)(100)
+@.in@>
+else if scan_keyword("pc") then set_conversion(12)(1)
+@.pc@>
+else if scan_keyword("cm") then set_conversion(7227)(254)
+@.cm@>
+else if scan_keyword("mm") then set_conversion(7227)(2540)
+@.mm@>
+else if scan_keyword("bp") then set_conversion(7227)(7200)
+@.bp@>
+else if scan_keyword("dd") then set_conversion(1238)(1157)
+@.dd@>
+else if scan_keyword("cc") then set_conversion(14856)(1157)
+@.cc@>
+else if scan_keyword("nd") then set_conversion(685)(642)
+@.nd@>
+else if scan_keyword("nc") then set_conversion(1370)(107)
+@.nc@>
+else if scan_keyword("sp") then goto done
+@.sp@>
+else @<Complain about unknown unit and |goto done2|@>;
+cur_val:=xn_over_d(cur_val,num,denom);
+f:=(num*f+@'200000*remainder) div denom;@/
+cur_val:=cur_val+(f div @'200000); f:=f mod @'200000;
+done2:
+
+@ @<Complain about unknown unit...@>=
+begin print_err("Illegal unit of measure ("); print("pt inserted)");
+@.Illegal unit of measure@>
+help6("Dimensions can be in units of em, ex, in, pt, pc,")@/
+ ("cm, mm, dd, cc, nd, nc, bp, or sp; but yours is a new one!")@/
+ ("I'll assume that you meant to say pt, for printer's points.")@/
+ ("To recover gracefully from this error, it's best to")@/
+ ("delete the erroneous units; e.g., type `2' to delete")@/
+ ("two letters. (See Chapter 27 of The TeXbook.)");
+@:TeXbook}{\sl The \TeX book@>
+error; goto done2;
+end
+
+
+@ @<Report that this dimension is out of range@>=
+begin print_err("Dimension too large");
+@.Dimension too large@>
+help2("I can't work with sizes bigger than about 19 feet.")@/
+ ("Continue and I'll use the largest value I can.");@/
+error; cur_val:=max_dimen; arith_error:=false;
+end
+
+@ The final member of \TeX's value-scanning trio is |scan_glue|, which
+makes |cur_val| point to a glue specification. The reference count of that
+glue spec will take account of the fact that |cur_val| is pointing to~it.
+
+The |level| parameter should be either |glue_val| or |mu_val|.
+
+Since |scan_dimen| was so much more complex than |scan_int|, we might expect
+|scan_glue| to be even worse. But fortunately, it is very simple, since
+most of the work has already been done.
+
+@p procedure scan_glue(@!level:small_number);
+ {sets |cur_val| to a glue spec pointer}
+label exit;
+var negative:boolean; {should the answer be negated?}
+@!q:pointer; {new glue specification}
+@!mu:boolean; {does |level=mu_val|?}
+begin mu:=(level=mu_val); @<Get the next non-blank non-sign...@>;
+if (cur_cmd>=min_internal)and(cur_cmd<=max_internal) then
+ begin scan_something_internal(level,negative);
+ if cur_val_level>=glue_val then
+ begin if cur_val_level<>level then mu_error;
+ return;
+ end;
+ if cur_val_level=int_val then scan_dimen(mu,false,true)
+ else if level=mu_val then mu_error;
+ end
+else begin back_input; scan_dimen(mu,false,false);
+ if negative then negate(cur_val);
+ end;
+@<Create a new glue specification whose width is |cur_val|; scan for its
+ stretch and shrink components@>;
+exit:end;
+@#
+@<Declare procedures needed for expressions@>@;
+
+@ @<Create a new glue specification whose width is |cur_val|...@>=
+q:=new_spec(zero_glue); width(q):=cur_val;
+if scan_keyword("plus") then
+@.plus@>
+ begin scan_dimen(mu,true,false);
+ stretch(q):=cur_val; stretch_order(q):=cur_order;
+ end;
+if scan_keyword("minus") then
+@.minus@>
+ begin scan_dimen(mu,true,false);
+ shrink(q):=cur_val; shrink_order(q):=cur_order;
+ end;
+cur_val:=q
+
+@ Here's a similar procedure that returns a pointer to a rule node. This
+routine is called just after \TeX\ has seen \.{\\hrule} or \.{\\vrule};
+therefore |cur_cmd| will be either |hrule| or |vrule|. The idea is to store
+the default rule dimensions in the node, then to override them if
+`\.{height}' or `\.{width}' or `\.{depth}' specifications are
+found (in any order).
+
+@d default_rule=26214 {0.4\thinspace pt}
+
+@p function scan_rule_spec:pointer;
+label reswitch;
+var q:pointer; {the rule node being created}
+begin q:=new_rule; {|width|, |depth|, and |height| all equal |null_flag| now}
+if cur_cmd=vrule then begin
+ width(q):=default_rule;
+ rule_dir(q):=body_direction;
+ end
+else begin
+ height(q):=default_rule; depth(q):=0;
+ rule_dir(q):=text_direction;
+end;
+reswitch: if scan_keyword("width") then
+@.width@>
+ begin scan_normal_dimen; width(q):=cur_val; goto reswitch;
+ end;
+if scan_keyword("height") then
+@.height@>
+ begin scan_normal_dimen; height(q):=cur_val; goto reswitch;
+ end;
+if scan_keyword("depth") then
+@.depth@>
+ begin scan_normal_dimen; depth(q):=cur_val; goto reswitch;
+ end;
+scan_rule_spec:=q;
+end;
+
+@* \[27] Building token lists.
+The token lists for macros and for other things like \.{\\mark} and \.{\\output}
+and \.{\\write} are produced by a procedure called |scan_toks|.
+
+Before we get into the details of |scan_toks|, let's consider a much
+simpler task, that of converting the current string into a token list.
+The |str_toks| function does this; it classifies spaces as type |spacer|
+and everything else as type |other_char|.
+
+The token list created by |str_toks| begins at |link(temp_token_head)| and ends
+at the value |p| that is returned. (If |p=temp_token_head|, the list is empty.)
+
+|lua_str_toks| is almost identical, but it also escapes the three
+symbols that |lua| considers special while scanning a literal string
+
+@d unicode_incr(#)==if str_pool[#]>@"F0 then #:=#+4 else if str_pool[#]>@"E0
+ then #:=#+3 else if str_pool[#]>@"C0 then #:=#+2 else incr(#)
+
+
+@p @t\4@>@<Declare \eTeX\ procedures for token lists@>@;@/
+function lua_str_toks(@!b:pool_pointer):pointer;
+ {changes the string |str_pool[b..pool_ptr]| to a token list}
+var p:pointer; {tail of the token list}
+@!q:pointer; {new node being added to the token list via |store_new_token|}
+@!t:halfword; {token being appended}
+@!k:pool_pointer; {index into |str_pool|}
+begin
+p:=temp_token_head; link(p):=null; k:=b;
+while k<pool_ptr do
+ begin t:=pool_to_unichar(k);
+ if t=" " then t:=space_token
+ else
+ begin
+ if (t="\") or (t="""") or (t="'") or (t=10) or (t=13) then
+ fast_store_new_token(other_token+"\");
+ if (t=10) then
+ t:="n";
+ if (t=13) then
+ t:="r";
+ t:=other_token+t;
+ end;
+ fast_store_new_token(t);
+ unicode_incr(k);
+ end;
+pool_ptr:=b; lua_str_toks:=p;
+end;
+
+function str_toks(@!b:pool_pointer):pointer;
+ {changes the string |str_pool[b..pool_ptr]| to a token list}
+var p:pointer; {tail of the token list}
+@!q:pointer; {new node being added to the token list via |store_new_token|}
+@!t:halfword; {token being appended}
+@!k:pool_pointer; {index into |str_pool|}
+begin
+p:=temp_token_head; link(p):=null; k:=b;
+while k<pool_ptr do
+ begin t:=pool_to_unichar(k);
+ if t=" " then t:=space_token
+ else t:=other_token+t;
+ fast_store_new_token(t);
+ unicode_incr(k);
+ end;
+pool_ptr:=b; str_toks:=p;
+end;
+
+@ The main reason for wanting |str_toks| is the next function,
+|the_toks|, which has similar input/output characteristics.
+
+This procedure is supposed to scan something like `\.{\\skip\\count12}',
+i.e., whatever can follow `\.{\\the}', and it constructs a token list
+containing something like `\.{-3.0pt minus 0.5fill}'.
+
+@p function the_toks:pointer;
+label exit;
+var old_setting:0..max_selector; {holds |selector| setting}
+@!p,@!q,@!r:pointer; {used for copying a token list}
+@!b:pool_pointer; {base of temporary string}
+@!c:small_number; {value of |cur_chr|}
+begin @<Handle \.{\\unexpanded} or \.{\\detokenize} and |return|@>;@/
+get_x_token; scan_something_internal(tok_val,false);
+if cur_val_level>=ident_val then begin
+ @<Copy the token list@>;
+ the_toks:=p;
+ end
+else begin old_setting:=selector; selector:=new_string; b:=pool_ptr;
+ case cur_val_level of
+ int_val:print_int(cur_val);
+ attr_val:print_int(cur_val);
+ dir_val:print_dir(cur_val);
+ dimen_val:begin print_scaled(cur_val); print("pt");
+ end;
+ glue_val: begin print_spec(cur_val,"pt"); delete_glue_ref(cur_val);
+ end;
+ mu_val: begin print_spec(cur_val,"mu"); delete_glue_ref(cur_val);
+ end;
+ end; {there are no other cases}
+ selector:=old_setting; the_toks:=str_toks(b);
+ end;
+exit:end;
+
+function the_scanned_result:str_number;
+var old_setting:0..max_selector; {holds |selector| setting}
+begin
+old_setting:=selector; selector:=new_string;
+if cur_val_level>=ident_val then begin
+ if cur_val<>null then begin
+ show_token_list(link(cur_val),null,pool_size-pool_ptr);
+ the_scanned_result:=make_string;
+ end
+ else
+ the_scanned_result:="";
+ end
+else begin
+ case cur_val_level of
+ int_val:print_int(cur_val);
+ attr_val:print_int(cur_val);
+ dir_val:print_dir(cur_val);
+ dimen_val:begin print_scaled(cur_val); print("pt");
+ end;
+ glue_val: begin print_spec(cur_val,"pt"); delete_glue_ref(cur_val);
+ end;
+ mu_val: begin print_spec(cur_val,"mu"); delete_glue_ref(cur_val);
+ end;
+ end; {there are no other cases}
+ the_scanned_result:=make_string;
+ end;
+selector:=old_setting;
+end;
+
+@ @<Copy the token list@>=
+begin p:=temp_token_head; link(p):=null;
+if cur_val_level=ident_val then store_new_token(cs_token_flag+cur_val)
+else if cur_val<>null then
+ begin r:=link(cur_val); {do not copy the reference count}
+ while r<>null do
+ begin fast_store_new_token(info(r)); r:=link(r);
+ end;
+ end;
+end
+
+@ Here's part of the |expand| subroutine that we are now ready to complete:
+
+@p procedure ins_the_toks;
+var junk:pointer;
+begin junk:=the_toks; ins_list(link(temp_token_head));
+end;
+
+@ The primitives \.{\\number}, \.{\\romannumeral}, \.{\\string}, \.{\\meaning},
+\.{\\fontname}, and \.{\\jobname} are defined as follows.
+
+\eTeX\ adds \.{\\eTeXrevision} such that |job_name_code| remains last.
+
+\pdfTeX\ adds \.{\\eTeXrevision}, \.{\\pdftexrevision}, \.{\\pdftexbanner},
+\.{\\pdffontname}, \.{\\pdffontobjnum}, \.{\\pdffontsize}, and \.{\\pdfpageref}
+such that |job_name_code| remains last.
+
+@d number_code=0 {command code for \.{\\number}}
+@d roman_numeral_code=1 {command code for \.{\\romannumeral}}
+@d string_code=2 {command code for \.{\\string}}
+@d meaning_code=3 {command code for \.{\\meaning}}
+@d font_name_code=4 {command code for \.{\\fontname}}
+@d etex_code=5 {command code for \.{\\eTeXVersion}}
+@d omega_code=6 {command code for \.{\\OmegaVersion}}
+@d aleph_code=7 {command code for \.{\\AlephVersion}}
+@d format_name_code=8 {command code for \.{\\AlephVersion}}
+@d pdftex_first_expand_code = 9 {base for \pdfTeX's command codes}
+@d pdftex_revision_code = pdftex_first_expand_code + 0 {command code for \.{\\pdftexrevision}}
+@d pdftex_banner_code = pdftex_first_expand_code + 1 {command code for \.{\\pdftexbanner}}
+@d pdf_font_name_code = pdftex_first_expand_code + 2 {command code for \.{\\pdffontname}}
+@d pdf_font_objnum_code = pdftex_first_expand_code + 3 {command code for \.{\\pdffontobjnum}}
+@d pdf_font_size_code = pdftex_first_expand_code + 4 {command code for \.{\\pdffontsize}}
+@d pdf_page_ref_code = pdftex_first_expand_code + 5 {command code for \.{\\pdfpageref}}
+@d pdf_xform_name_code = pdftex_first_expand_code + 6 {command code for \.{\\pdfxformname}}
+@d left_margin_kern_code = pdftex_first_expand_code + 7 {command code for \.{\\leftmarginkern}}
+@d right_margin_kern_code = pdftex_first_expand_code + 8 {command code for \.{\\rightmarginkern}}
+@d pdf_creation_date_code = pdftex_first_expand_code + 9 {command code for \.{\\pdfcreationdate}}
+@d uniform_deviate_code = pdftex_first_expand_code + 10 {command code for \.{\\uniformdeviate}}
+@d normal_deviate_code = pdftex_first_expand_code + 11 {command code for \.{\\normaldeviate}}
+@d pdf_insert_ht_code = pdftex_first_expand_code + 12 {command code for \.{\\pdfinsertht}}
+@d pdf_ximage_bbox_code = pdftex_first_expand_code + 13 {command code for \.{\\pdfximagebbox}}
+@d lua_code = pdftex_first_expand_code + 14 {command code for \.{\\directlua}}
+@d lua_escape_string_code = pdftex_first_expand_code + 15 {command code for \.{\\luaescapestring}}
+@d pdf_colorstack_init_code = pdftex_first_expand_code + 16 {command code for \.{\\pdfcolorstackinit}}
+@d luatex_revision_code = pdftex_first_expand_code + 17 {command code for \.{\\luatexrevision}}
+@d luatex_date_code = pdftex_first_expand_code + 18 {command code for \.{\\luatexdate}}
+@d pdftex_convert_codes = pdftex_first_expand_code + 19 {end of \pdfTeX's command codes}
+@d job_name_code=pdftex_convert_codes {command code for \.{\\jobname}}
+
+
+@<Put each...@>=
+primitive("number",convert,number_code);@/
+@!@:number_}{\.{\\number} primitive@>
+primitive("romannumeral",convert,roman_numeral_code);@/
+@!@:roman_numeral_}{\.{\\romannumeral} primitive@>
+primitive("string",convert,string_code);@/
+@!@:string_}{\.{\\string} primitive@>
+primitive("meaning",convert,meaning_code);@/
+@!@:meaning_}{\.{\\meaning} primitive@>
+primitive("eTeXVersion",convert,etex_code);@/
+@!@:omega_version_}{\.{\\OmegaVersion} primitive@>
+primitive("OmegaVersion",convert,omega_code);@/
+@!@:omega_version_}{\.{\\OmegaVersion} primitive@>
+primitive("AlephVersion",convert,aleph_code);@/
+@!@:aleph_version_}{\.{\\AlephVersion} primitive@>
+primitive("fontname",convert,font_name_code);@/
+@!@:font_name_}{\.{\\fontname} primitive@>
+primitive("pdftexrevision",convert,pdftex_revision_code);@/
+@!@:pdftex_revision_}{\.{\\pdftexrevision} primitive@>
+primitive("luatexrevision",convert,luatex_revision_code);@/
+@!@:luatex_revision_}{\.{\\luatexrevision} primitive@>
+primitive("luatexdatestamp",convert,luatex_date_code);@/
+@!@:luatex_date_}{\.{\\luatexdatestamp} primitive@>
+primitive("pdftexbanner",convert,pdftex_banner_code);@/
+@!@:pdftex_banner_}{\.{\\pdftexbanner} primitive@>
+primitive("pdffontname",convert,pdf_font_name_code);@/
+@!@:pdf_font_name_}{\.{\\pdffontname} primitive@>
+primitive("pdffontobjnum",convert,pdf_font_objnum_code);@/
+@!@:pdf_font_objnum_}{\.{\\pdffontobjnum} primitive@>
+primitive("pdffontsize",convert,pdf_font_size_code);@/
+@!@:pdf_font_size_}{\.{\\pdffontsize} primitive@>
+primitive("pdfpageref",convert,pdf_page_ref_code);@/
+@!@:pdf_page_ref_}{\.{\\pdfpageref} primitive@>
+primitive("leftmarginkern",convert,left_margin_kern_code);@/
+@!@:left_margin_kern_}{\.{\\leftmarginkern} primitive@>
+primitive("rightmarginkern",convert,right_margin_kern_code);@/
+@!@:right_margin_kern_}{\.{\\rightmarginkern} primitive@>
+primitive("pdfxformname",convert,pdf_xform_name_code);@/
+@!@:pdf_xform_name_}{\.{\\pdfxformname} primitive@>
+primitive("pdfcreationdate",convert,pdf_creation_date_code);@/
+@!@:pdf_creation_date_}{\.{\\pdfcreationdate} primitive@>
+primitive("pdfuniformdeviate",convert,uniform_deviate_code);@/
+@!@:uniform_deviate_}{\.{\\pdfuniformdeviate} primitive@>
+primitive("pdfcolorstackinit",convert,pdf_colorstack_init_code);@/
+@!@:pdf_colorstack_init_}{\.{\\pdfcolorstackinit} primitive@>
+primitive("pdfnormaldeviate",convert,normal_deviate_code);@/
+@!@:normal_deviate_}{\.{\\pdfnormaldeviate} primitive@>
+primitive("directlua",convert,lua_code);@/
+@!@:lua_}{\.{\\directlua} primitive@>
+primitive("luaescapestring",convert,lua_escape_string_code);@/
+@!@:lua_}{\.{\\luaescapestring} primitive@>
+@#
+primitive("jobname",convert,job_name_code);@/
+@!@:job_name_}{\.{\\jobname} primitive@>
+primitive("formatname",convert,format_name_code);@/
+@!@:format_name_}{\.{\\formatname} primitive@>
+primitive("pdfinsertht",convert,pdf_insert_ht_code);@/
+@!@:pdf_insert_ht_}{\.{\\pdfinsertht} primitive@>
+primitive("pdfximagebbox",convert,pdf_ximage_bbox_code);@/
+@!@:pdf_ximage_bbox_}{\.{\\pdfximagebbox} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+convert: case chr_code of
+ number_code: print_esc("number");
+ roman_numeral_code: print_esc("romannumeral");
+ string_code: print_esc("string");
+ meaning_code: print_esc("meaning");
+ etex_code: print_esc("eTeXVersion");
+ omega_code: print_esc("OmegaVersion");
+ aleph_code: print_esc("AlephVersion");
+ font_name_code: print_esc("fontname");
+ pdftex_revision_code: print_esc("pdftexrevision");
+ luatex_revision_code: print_esc("luatexrevision");
+ luatex_date_code: print_esc("luatexdatestamp");
+ pdftex_banner_code: print_esc("pdftexbanner");
+ pdf_font_name_code: print_esc("pdffontname");
+ pdf_font_objnum_code: print_esc("pdffontobjnum");
+ pdf_font_size_code: print_esc("pdffontsize");
+ pdf_page_ref_code: print_esc("pdfpageref");
+ left_margin_kern_code: print_esc("leftmarginkern");
+ right_margin_kern_code: print_esc("rightmarginkern");
+ pdf_xform_name_code: print_esc("pdfxformname");
+ pdf_creation_date_code: print_esc("pdfcreationdate");
+ pdf_colorstack_init_code: print_esc("pdfcolorstackinit");
+ uniform_deviate_code: print_esc("pdfuniformdeviate");
+ normal_deviate_code: print_esc("pdfnormaldeviate");
+ pdf_insert_ht_code: print_esc("pdfinsertht");
+ pdf_ximage_bbox_code: print_esc("pdfximagebbox");
+ lua_code: print_esc("directlua");
+ lua_escape_string_code: print_esc("luaescapestring");
+ @/@<Cases of |convert| for |print_cmd_chr|@>@/
+ othercases print_esc("jobname")
+ endcases;
+
+@ The procedure |conv_toks| uses |str_toks| to insert the token list
+for |convert| functions into the scanner; `\.{\\outer}' control sequences
+are allowed to follow `\.{\\string}' and `\.{\\meaning}'.
+
+The extra temp string |u| is needed because |pdf_scan_ext_toks| incorporates
+any pending string in its output. In order to save such a pending string,
+we have to create a temporary string that is destroyed immediately after.
+
+@d save_cur_string==if str_start[str_ptr]<pool_ptr then u:=make_string
+@d restore_cur_string==if u<>0 then begin decr(str_ptr); u:=0; end
+
+@p procedure conv_toks;
+label exit;
+var old_setting:0..max_selector; {holds |selector| setting}
+p, q: pointer;
+@!c:number_code..job_name_code; {desired type of conversion}
+@!save_scanner_status:small_number; {|scanner_status| upon entry}
+@!save_def_ref: pointer; {|def_ref| upon entry, important if inside `\.{\\message}'}
+@!save_warning_index: pointer;
+@!bool: boolean; {temp boolean}
+@!i: integer; {first temp integer}
+@!j: integer; {second temp integer}
+@!b:pool_pointer; {base of temporary string}
+@!s: str_number; {first temp string}
+@!u: str_number; {third temp string}
+@!junk: pointer;
+begin
+c:=cur_chr;
+u:=0; { will become non-nil if a string is already being built}
+j:=0; i:=0;
+@<Scan the argument for command |c|@>;
+old_setting:=selector; selector:=new_string; b:=pool_ptr;
+@<Print the result of command |c|@>;
+selector:=old_setting; junk:=str_toks(b); ins_list(link(temp_token_head));
+exit:
+end;
+
+@ @<Scan the argument for command |c|@>=
+case c of
+number_code,roman_numeral_code: scan_int;
+string_code, meaning_code: begin save_scanner_status:=scanner_status;
+ scanner_status:=normal; get_token; scanner_status:=save_scanner_status;
+ end;
+etex_code: do_nothing;
+omega_code: do_nothing;
+aleph_code: do_nothing;
+font_name_code: scan_font_ident;
+pdftex_revision_code: do_nothing;
+luatex_revision_code: do_nothing;
+luatex_date_code: do_nothing;
+pdftex_banner_code: do_nothing;
+pdf_font_name_code, pdf_font_objnum_code, pdf_font_size_code: begin
+ scan_font_ident;
+ if cur_val = null_font then
+ pdf_error("font", "invalid font identifier");
+ if c <> pdf_font_size_code then begin
+ pdf_check_vf_cur_val;
+ if not font_used(cur_val) then
+ pdf_init_font_cur_val;
+ end;
+end;
+pdf_page_ref_code: begin
+ scan_int;
+ if cur_val <= 0 then
+ pdf_error("pageref", "invalid page number");
+end;
+left_margin_kern_code, right_margin_kern_code: begin
+ scan_int;
+ if (box(cur_val) = null) or (type(box(cur_val)) <> hlist_node) then
+ pdf_error("marginkern", "a non-empty hbox expected")
+end;
+pdf_xform_name_code: begin
+ scan_int;
+ pdf_check_obj(obj_type_xform, cur_val);
+end;
+pdf_creation_date_code:
+ begin
+ b := pool_ptr;
+ getcreationdate;
+ junk := str_toks(b);
+ ins_list(link(temp_token_head));
+ return;
+ end;
+job_name_code: if job_name=0 then open_log_file;
+pdf_colorstack_init_code:
+ begin
+ bool := scan_keyword("page");
+ if scan_keyword("direct") then
+ cur_val := direct_always
+ else
+ if scan_keyword("page") then
+ cur_val := direct_page
+ else
+ cur_val := set_origin;
+ save_scanner_status := scanner_status;
+ save_warning_index := warning_index;
+ save_def_ref := def_ref;
+ save_cur_string;
+ scan_pdf_ext_toks;
+ s := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ def_ref := save_def_ref;
+ warning_index := save_warning_index;
+ scanner_status := save_scanner_status;
+ cur_val := newcolorstack(s, cur_val, bool);
+ flush_str(s);
+ cur_val_level := int_val;
+ if cur_val < 0 then begin
+ print_err("Too many color stacks");
+@.Too many color stacks@>
+ help2("The number of color stacks is limited to 32768.")@/
+ ("I'll use the default color stack 0 here.");
+ error;
+ cur_val := 0;
+ restore_cur_string;
+ end;
+ end;
+uniform_deviate_code: scan_int;
+normal_deviate_code: do_nothing;
+lua_escape_string_code:
+ begin
+ u:=0;
+ { check if a string is already being built}
+ if str_start_macro(str_ptr)<pool_ptr then u:=make_string;
+ save_scanner_status := scanner_status;
+ save_def_ref := def_ref;
+ save_warning_index := warning_index;
+ scan_pdf_ext_toks;
+ s := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ def_ref := save_def_ref;
+ warning_index := save_warning_index;
+ scanner_status := save_scanner_status;
+ junk := lua_str_toks(str_start_macro(s));
+ ins_list(link(temp_token_head));
+ flush_str(s);
+ if u<>0 then begin decr(str_ptr); u:=0; end;
+ return;
+ end;
+lua_code:
+ begin
+ u:=0;
+ { check if a string is already being built}
+ if str_start_macro(str_ptr)<pool_ptr then u:=make_string;
+ save_scanner_status := scanner_status;
+ save_def_ref := def_ref;
+ save_warning_index := warning_index;
+ scan_register_num;
+ i := cur_val;
+ scan_pdf_ext_toks;
+ s := def_ref;
+ warning_index := save_warning_index;
+ def_ref := save_def_ref;
+ scanner_status := save_scanner_status;
+ luacstrings:=0;
+ luatokencall(i,s);
+ delete_token_ref(s);
+ if u<>0 then begin
+ if str_ptr=u+1 then
+ decr(str_ptr)
+ else begin {copy old string to the top location}
+ i:=0;
+ str_room(length(u));
+ while i<length(u) do
+ str_pool[pool_ptr+i]:=str_pool[str_start_macro(u)+i];
+ end;
+ end;
+ if luacstrings>0 then
+ lua_string_start;
+ return;
+ end;
+pdf_insert_ht_code: scan_register_num;
+pdf_ximage_bbox_code: begin
+ scan_int;
+ pdf_check_obj(obj_type_ximage, cur_val);
+ i := obj_data_ptr(cur_val);
+ scan_int;
+ j := cur_val;
+ if (j < 1) or (j > 4) then
+ pdf_error("pdfximagebbox", "invalid parameter");
+ end;
+@<Cases of `Scan the argument for command |c|'@>
+end {there are no other cases}
+
+@ @<Print the result of command |c|@>=
+case c of
+number_code: print_int(cur_val);
+roman_numeral_code: print_roman_int(cur_val);
+string_code:if cur_cs<>0 then sprint_cs(cur_cs)
+ else print(cur_chr);
+meaning_code: print_meaning;
+etex_code: print(eTeX_version_string);
+omega_code: print(Omega_version_string);
+aleph_code: print(Aleph_version_string);
+font_name_code: begin
+ append_string(font_name(cur_val));
+ if font_size(cur_val)<>font_dsize(cur_val) then
+ begin print(" at "); print_scaled(font_size(cur_val));
+ print("pt");
+ end;
+ end;
+pdftex_revision_code: print(pdftex_revision);
+luatex_revision_code: print(luatex_revision);
+luatex_date_code: print_int(luatex_date_info);
+pdftex_banner_code: print(pdftex_banner);
+pdf_font_name_code, pdf_font_objnum_code: begin
+ set_ff(cur_val);
+ if c = pdf_font_name_code then
+ print_int(obj_info(pdf_font_num(ff)))
+ else
+ print_int(pdf_font_num(ff));
+end;
+pdf_font_size_code: begin
+ print_scaled(font_size(cur_val));
+ print("pt");
+end;
+pdf_page_ref_code: print_int(get_obj(obj_type_page, cur_val, false));
+left_margin_kern_code: begin
+ p := list_ptr(box(cur_val));
+ if (p <> null) and (not is_char_node(p)) and
+ (type(p) = glue_node) and (subtype(p) = left_skip_code + 1) then
+ p := vlink(p);
+ if (p <> null) and (not is_char_node(p)) and
+ (type(p) = margin_kern_node) and (subtype(p) = left_side) then
+ print_scaled(width(p))
+ else
+ print("0");
+ print("pt");
+end;
+right_margin_kern_code: begin
+ q := list_ptr(box(cur_val));
+ p := null;
+ if q <> null then begin
+ p := prev_rightmost(q, null);
+ if (p <> null) and (not is_char_node(p)) and
+ (type(p) = glue_node) and (subtype(p) = right_skip_code + 1) then
+ p := prev_rightmost(q, p);
+ end;
+ if (p <> null) and (not is_char_node(p)) and
+ (type(p) = margin_kern_node) and (subtype(p) = right_side) then
+ print_scaled(width(p))
+ else
+ print("0");
+ print("pt");
+end;
+pdf_xform_name_code: print_int(obj_info(cur_val));
+pdf_colorstack_init_code: print_int(cur_val);
+uniform_deviate_code: print_int(unif_rand(cur_val));
+normal_deviate_code: print_int(norm_rand);
+pdf_insert_ht_code: begin
+ i := qi(cur_val);
+ p := page_ins_head;
+ while i >= subtype(vlink(p)) do
+ p := vlink(p);
+ if subtype(p) = i then
+ print_scaled(height(p))
+ else
+ print("0");
+ print("pt");
+end;
+pdf_ximage_bbox_code: begin
+ case j of
+ 1: print_scaled(epdf_orig_x(i));
+ 2: print_scaled(epdf_orig_y(i));
+ 3: print_scaled(epdf_orig_x(i) + image_width(i));
+ 4: print_scaled(epdf_orig_y(i) + image_height(i));
+ endcases;
+ print("pt");
+end;
+format_name_code: print(format_name);
+job_name_code: print(job_name);
+@/@<Cases of `Print the result of command |c|'@>@/
+end {there are no other cases}
+
+@
+@p function is_convert(c:halfword):boolean;
+begin
+ is_convert:=(c=convert);
+end;
+
+function the_convert_string (c:halfword):str_number;
+var old_setting:0..max_selector; {saved |selector| setting}
+ is_known:boolean;
+begin
+ old_setting:=selector;
+ selector:=new_string;
+ is_known:=true;
+ case c of
+ etex_code: print(eTeX_version_string);
+ omega_code: print(Omega_version_string);
+ aleph_code: print(Aleph_version_string);
+ pdftex_revision_code: print(pdftex_revision);
+ luatex_revision_code: print(luatex_revision);
+ luatex_date_code: print_int(luatex_date_info);
+ pdftex_banner_code: print(pdftex_banner);
+ normal_deviate_code: print_int(norm_rand);
+ format_name_code: print(format_name);
+ job_name_code: print(job_name);
+@/@<Cases of `Print the result of command |c|'@>@/
+ othercases is_known:=false
+ end;
+ if is_known then
+ the_convert_string := make_string
+ else
+ the_convert_string := 0;
+ selector:=old_setting;
+end;
+
+@ Now we can't postpone the difficulties any longer; we must bravely tackle
+|scan_toks|. This function returns a pointer to the tail of a new token
+list, and it also makes |def_ref| point to the reference count at the
+head of that list.
+
+There are two boolean parameters, |macro_def| and |xpand|. If |macro_def|
+is true, the goal is to create the token list for a macro definition;
+otherwise the goal is to create the token list for some other \TeX\
+primitive: \.{\\mark}, \.{\\output}, \.{\\everypar}, \.{\\lowercase},
+\.{\\uppercase}, \.{\\message}, \.{\\errmessage}, \.{\\write}, or
+\.{\\special}. In the latter cases a left brace must be scanned next; this
+left brace will not be part of the token list, nor will the matching right
+brace that comes at the end. If |xpand| is false, the token list will
+simply be copied from the input using |get_token|. Otherwise all expandable
+tokens will be expanded until unexpandable tokens are left, except that
+the results of expanding `\.{\\the}' are not expanded further.
+If both |macro_def| and |xpand| are true, the expansion applies
+only to the macro body (i.e., to the material following the first
+|left_brace| character).
+
+The value of |cur_cs| when |scan_toks| begins should be the |eqtb|
+address of the control sequence to display in ``runaway'' error
+messages.
+
+@p function scan_toks(@!macro_def,@!xpand:boolean):pointer;
+label found,done,done1,done2;
+var t:halfword; {token representing the highest parameter number}
+@!s:halfword; {saved token}
+@!p:pointer; {tail of the token list being built}
+@!q:pointer; {new node being added to the token list via |store_new_token|}
+@!unbalance:halfword; {number of unmatched left braces}
+@!hash_brace:halfword; {possible `\.{\#\{}' token}
+begin if macro_def then scanner_status:=defining
+@+else scanner_status:=absorbing;
+warning_index:=cur_cs; p:=get_avail; def_ref:=p; token_ref_count(def_ref):=0;
+p:=def_ref; hash_brace:=0; t:=zero_token;
+if macro_def then @<Scan and build the parameter part of the macro definition@>
+else scan_left_brace; {remove the compulsory left brace}
+@<Scan and build the body of the token list; |goto found| when finished@>;
+found: scanner_status:=normal;
+if hash_brace<>0 then store_new_token(hash_brace);
+scan_toks:=p;
+end;
+
+@ @<Scan and build the parameter part...@>=
+begin loop begin get_token; {set |cur_cmd|, |cur_chr|, |cur_tok|}
+ if cur_tok<right_brace_limit then goto done1;
+ if cur_cmd=mac_param then
+ @<If the next character is a parameter number, make |cur_tok|
+ a |match| token; but if it is a left brace, store
+ `|left_brace|, |end_match|', set |hash_brace|, and |goto done|@>;
+ store_new_token(cur_tok);
+ end;
+done1: store_new_token(end_match_token);
+if cur_cmd=right_brace then
+ @<Express shock at the missing left brace; |goto found|@>;
+done: end
+
+@ @<Express shock...@>=
+begin print_err("Missing { inserted"); incr(align_state);
+@.Missing \{ inserted@>
+help2("Where was the left brace? You said something like `\def\a}',")@/
+ ("which I'm going to interpret as `\def\a{}'."); error; goto found;
+end
+
+@ @<If the next character is a parameter number...@>=
+begin s:=match_token+cur_chr; get_token;
+if cur_cmd=left_brace then
+ begin hash_brace:=cur_tok;
+ store_new_token(cur_tok); store_new_token(end_match_token);
+ goto done;
+ end;
+if t=zero_token+9 then
+ begin print_err("You already have nine parameters");
+@.You already have nine...@>
+ help1("I'm going to ignore the # sign you just used."); error;
+ end
+else begin incr(t);
+ if cur_tok<>t then
+ begin print_err("Parameters must be numbered consecutively");
+@.Parameters...consecutively@>
+ help2("I've inserted the digit you should have used after the #.")@/
+ ("Type `1' to delete what you did use."); back_error;
+ end;
+ cur_tok:=s;
+ end;
+end
+
+@ @<Scan and build the body of the token list; |goto found| when finished@>=
+unbalance:=1;
+loop@+ begin if xpand then @<Expand the next part of the input@>
+ else get_token;
+ if cur_tok<right_brace_limit then
+ if cur_cmd<right_brace then incr(unbalance)
+ else begin decr(unbalance);
+ if unbalance=0 then goto found;
+ end
+ else if cur_cmd=mac_param then
+ if macro_def then @<Look for parameter number or \.{\#\#}@>;
+ store_new_token(cur_tok);
+ end
+
+@ Here we insert an entire token list created by |the_toks| without
+expanding it further.
+
+@<Expand the next part of the input@>=
+begin loop begin get_filtered_next;
+ if cur_cmd>=call then
+ if info(link(cur_chr))=protected_token then
+ begin cur_cmd:=relax; cur_chr:=no_expand_flag;
+ end;
+ if cur_cmd<=max_command then goto done2;
+ if cur_cmd<>the then expand
+ else begin q:=the_toks;
+ if link(temp_token_head)<>null then
+ begin link(p):=link(temp_token_head); p:=q;
+ end;
+ end;
+ end;
+done2: x_token
+end
+
+@ @<Look for parameter number...@>=
+begin s:=cur_tok;
+if xpand then get_x_token else get_token;
+if cur_cmd<>mac_param then
+ if (cur_tok<=zero_token)or(cur_tok>t) then
+ begin print_err("Illegal parameter number in definition of ");
+@.Illegal parameter number...@>
+ sprint_cs(warning_index);
+ help3("You meant to type ## instead of #, right?")@/
+ ("Or maybe a } was forgotten somewhere earlier, and things")@/
+ ("are all screwed up? I'm going to assume that you meant ##.");
+ back_error; cur_tok:=s;
+ end
+ else cur_tok:=out_param_token-"0"+cur_chr;
+end
+
+@ Another way to create a token list is via the \.{\\read} command. The
+sixteen files potentially usable for reading appear in the following
+global variables. The value of |read_open[n]| will be |closed| if
+stream number |n| has not been opened or if it has been fully read;
+|just_open| if an \.{\\openin} but not a \.{\\read} has been done;
+and |normal| if it is open and ready to read the next line.
+
+@d closed=2 {not open, or at end of file}
+@d just_open=1 {newly opened, first line not yet read}
+
+@<Glob...@>=
+@!read_file:array[0..15] of alpha_file; {used for \.{\\read}}
+@!read_open:array[0..16] of normal..closed; {state of |read_file[n]|}
+
+@ @<Set init...@>=
+for k:=0 to 16 do begin
+ read_open[k]:=closed;
+end;
+
+@ The |read_toks| procedure constructs a token list like that for any
+macro definition, and makes |cur_val| point to it. Parameter |r| points
+to the control sequence that will receive this token list.
+
+@p procedure read_toks(@!n:integer;@!r:pointer;@!j:halfword);
+label done;
+var p:pointer; {tail of the token list}
+@!q:pointer; {new node being added to the token list via |store_new_token|}
+@!s:integer; {saved value of |align_state|}
+@!m:small_number; {stream number}
+begin scanner_status:=defining; warning_index:=r;
+p:=get_avail; def_ref:=p; token_ref_count(def_ref):=0;
+p:=def_ref; {the reference count}
+store_new_token(end_match_token);
+if (n<0)or(n>15) then m:=16@+else m:=n;
+s:=align_state; align_state:=1000000; {disable tab marks, etc.}
+repeat @<Input and store tokens from the next line of the file@>;
+until align_state=1000000;
+cur_val:=def_ref; scanner_status:=normal; align_state:=s;
+end;
+
+@ @<Input and store tokens from the next line of the file@>=
+begin_file_reading; name:=m+1;
+if read_open[m]=closed then @<Input for \.{\\read} from the terminal@>
+else if read_open[m]=just_open then @<Input the first line of |read_file[m]|@>
+else @<Input the next line of |read_file[m]|@>;
+limit:=last;
+if end_line_char_inactive then decr(limit)
+else buffer[limit]:=end_line_char;
+first:=limit+1; loc:=start; state:=new_line;@/
+@<Handle \.{\\readline} and |goto done|@>;@/
+loop@+ begin get_token;
+ if cur_tok=0 then goto done;
+ {|cur_cmd=cur_chr=0| will occur at the end of the line}
+ if align_state<1000000 then {unmatched `\.\}' aborts the line}
+ begin repeat get_token; until cur_tok=0;
+ align_state:=1000000; goto done;
+ end;
+ store_new_token(cur_tok);
+ end;
+done: end_file_reading
+
+@ Here we input on-line into the |buffer| array, prompting the user explicitly
+if |n>=0|. The value of |n| is set negative so that additional prompts
+will not be given in the case of multi-line input.
+
+@<Input for \.{\\read} from the terminal@>=
+if interaction>nonstop_mode then
+ if n<0 then prompt_input("")
+ else begin wake_up_terminal;
+ print_ln; sprint_cs(r); prompt_input("="); n:=-1;
+ end
+else fatal_error("*** (cannot \read from terminal in nonstop modes)")
+@.cannot \\read@>
+
+@ The first line of a file must be treated specially, since |lua_input_ln|
+must be told not to start with |get|.
+@^system dependencies@>
+
+@<Input the first line of |read_file[m]|@>=
+begin if lua_input_ln(read_file[m],(m+1),false) then read_open[m]:=normal
+else begin lua_a_close_in(read_file[m],(m+1)); read_open[m]:=closed;
+ end;
+end
+
+@ An empty line is appended at the end of a |read_file|.
+@^empty line at end of file@>
+
+@<Input the next line of |read_file[m]|@>=
+begin if not lua_input_ln(read_file[m],(m+1),true) then
+ begin lua_a_close_in(read_file[m],(m+1)); read_open[m]:=closed;
+ if align_state<>1000000 then
+ begin runaway;
+ print_err("File ended within "); print_esc("read");
+@.File ended within \\read@>
+ help1("This \read has unbalanced braces.");
+ align_state:=1000000; error;
+ end;
+ end;
+end
+
+@* \[28] Conditional processing.
+We consider now the way \TeX\ handles various kinds of \.{\\if} commands.
+
+@d unless_code=32 {amount added for `\.{\\unless}' prefix}
+@#
+@d if_char_code=0 { `\.{\\if}' }
+@d if_cat_code=1 { `\.{\\ifcat}' }
+@d if_int_code=2 { `\.{\\ifnum}' }
+@d if_dim_code=3 { `\.{\\ifdim}' }
+@d if_odd_code=4 { `\.{\\ifodd}' }
+@d if_vmode_code=5 { `\.{\\ifvmode}' }
+@d if_hmode_code=6 { `\.{\\ifhmode}' }
+@d if_mmode_code=7 { `\.{\\ifmmode}' }
+@d if_inner_code=8 { `\.{\\ifinner}' }
+@d if_void_code=9 { `\.{\\ifvoid}' }
+@d if_hbox_code=10 { `\.{\\ifhbox}' }
+@d if_vbox_code=11 { `\.{\\ifvbox}' }
+@d ifx_code=12 { `\.{\\ifx}' }
+@d if_eof_code=13 { `\.{\\ifeof}' }
+@d if_true_code=14 { `\.{\\iftrue}' }
+@d if_false_code=15 { `\.{\\iffalse}' }
+@d if_case_code=16 { `\.{\\ifcase}' }
+@d if_primitive_code=21 { `\.{\\ifprimitive}' }
+
+@<Put each...@>=
+primitive("if",if_test,if_char_code);
+@!@:if_char_}{\.{\\if} primitive@>
+primitive("ifcat",if_test,if_cat_code);
+@!@:if_cat_code_}{\.{\\ifcat} primitive@>
+primitive("ifnum",if_test,if_int_code);
+@!@:if_int_}{\.{\\ifnum} primitive@>
+primitive("ifdim",if_test,if_dim_code);
+@!@:if_dim_}{\.{\\ifdim} primitive@>
+primitive("ifodd",if_test,if_odd_code);
+@!@:if_odd_}{\.{\\ifodd} primitive@>
+primitive("ifvmode",if_test,if_vmode_code);
+@!@:if_vmode_}{\.{\\ifvmode} primitive@>
+primitive("ifhmode",if_test,if_hmode_code);
+@!@:if_hmode_}{\.{\\ifhmode} primitive@>
+primitive("ifmmode",if_test,if_mmode_code);
+@!@:if_mmode_}{\.{\\ifmmode} primitive@>
+primitive("ifinner",if_test,if_inner_code);
+@!@:if_inner_}{\.{\\ifinner} primitive@>
+primitive("ifvoid",if_test,if_void_code);
+@!@:if_void_}{\.{\\ifvoid} primitive@>
+primitive("ifhbox",if_test,if_hbox_code);
+@!@:if_hbox_}{\.{\\ifhbox} primitive@>
+primitive("ifvbox",if_test,if_vbox_code);
+@!@:if_vbox_}{\.{\\ifvbox} primitive@>
+primitive("ifx",if_test,ifx_code);
+@!@:ifx_}{\.{\\ifx} primitive@>
+primitive("ifeof",if_test,if_eof_code);
+@!@:if_eof_}{\.{\\ifeof} primitive@>
+primitive("iftrue",if_test,if_true_code);
+@!@:if_true_}{\.{\\iftrue} primitive@>
+primitive("iffalse",if_test,if_false_code);
+@!@:if_false_}{\.{\\iffalse} primitive@>
+primitive("ifcase",if_test,if_case_code);
+@!@:if_case_}{\.{\\ifcase} primitive@>
+primitive("ifprimitive",if_test,if_primitive_code);
+@!@:if_primitive_}{\.{\\ifprimitive} primitive@>
+primitive("ifpdfprimitive",if_test,if_primitive_code);
+@!@:if_primitive_}{\.{\\ifpdfprimitive} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+if_test: begin if chr_code>=unless_code then print_esc("unless");
+case chr_code mod unless_code of
+ if_cat_code:print_esc("ifcat");
+ if_int_code:print_esc("ifnum");
+ if_dim_code:print_esc("ifdim");
+ if_odd_code:print_esc("ifodd");
+ if_vmode_code:print_esc("ifvmode");
+ if_hmode_code:print_esc("ifhmode");
+ if_mmode_code:print_esc("ifmmode");
+ if_inner_code:print_esc("ifinner");
+ if_void_code:print_esc("ifvoid");
+ if_hbox_code:print_esc("ifhbox");
+ if_vbox_code:print_esc("ifvbox");
+ ifx_code:print_esc("ifx");
+ if_eof_code:print_esc("ifeof");
+ if_true_code:print_esc("iftrue");
+ if_false_code:print_esc("iffalse");
+ if_case_code:print_esc("ifcase");
+ if_primitive_code:print_esc("ifprimitive");
+ @/@<Cases of |if_test| for |print_cmd_chr|@>@/
+ othercases print_esc("if")
+ endcases;
+end;
+
+@ Conditions can be inside conditions, and this nesting has a stack
+that is independent of the |save_stack|.
+
+Four global variables represent the top of the condition stack:
+|cond_ptr| points to pushed-down entries, if any; |if_limit| specifies
+the largest code of a |fi_or_else| command that is syntactically legal;
+|cur_if| is the name of the current type of conditional; and |if_line|
+is the line number at which it began.
+
+If no conditions are currently in progress, the condition stack has the
+special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
+Otherwise |cond_ptr| points to a two-word node; the |type|, |subtype|, and
+|link| fields of the first word contain |if_limit|, |cur_if|, and
+|cond_ptr| at the next level, and the second word contains the
+corresponding |if_line|.
+
+@d if_node==49
+@d if_node_size=2 {number of words in stack entry for conditionals}
+@d if_limit_subtype(#)==subtype(#+1)
+@d if_limit_type(#)==type(#+1)
+@d if_line_field(#)==vlink(#+1)
+@d if_code=1 {code for \.{\\if...} being evaluated}
+@d fi_code=2 {code for \.{\\fi}}
+@d else_code=3 {code for \.{\\else}}
+@d or_code=4 {code for \.{\\or}}
+
+@<Glob...@>=
+@!cond_ptr:pointer; {top of the condition stack}
+@!if_limit:normal..or_code; {upper bound on |fi_or_else| codes}
+@!cur_if:small_number; {type of conditional being worked on}
+@!if_line:integer; {line where that conditional began}
+
+@ @<Set init...@>=
+cond_ptr:=null; if_limit:=normal; cur_if:=0; if_line:=0;
+
+@ @<Put each...@>=
+primitive("fi",fi_or_else,fi_code);
+@!@:fi_}{\.{\\fi} primitive@>
+text(frozen_fi):="fi"; eqtb[frozen_fi]:=eqtb[cur_val];
+primitive("or",fi_or_else,or_code);
+@!@:or_}{\.{\\or} primitive@>
+primitive("else",fi_or_else,else_code);
+@!@:else_}{\.{\\else} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+fi_or_else: if chr_code=fi_code then print_esc("fi")
+ else if chr_code=or_code then print_esc("or")
+ else print_esc("else");
+
+@ When we skip conditional text, we keep track of the line number
+where skipping began, for use in error messages.
+
+@<Glob...@>=
+@!skip_line:integer; {skipping began here}
+
+@ Here is a procedure that ignores text until coming to an \.{\\or},
+\.{\\else}, or \.{\\fi} at level zero of $\.{\\if}\ldots\.{\\fi}$
+nesting. After it has acted, |cur_chr| will indicate the token that
+was found, but |cur_tok| will not be set (because this makes the
+procedure run faster).
+
+@p procedure pass_text;
+label done;
+var l:integer; {level of $\.{\\if}\ldots\.{\\fi}$ nesting}
+@!save_scanner_status:small_number; {|scanner_status| upon entry}
+begin save_scanner_status:=scanner_status; scanner_status:=skipping; l:=0;
+skip_line:=line;
+loop@+ begin get_filtered_next;
+ if cur_cmd=fi_or_else then
+ begin if l=0 then goto done;
+ if cur_chr=fi_code then decr(l);
+ end
+ else if cur_cmd=if_test then incr(l);
+ end;
+done: scanner_status:=save_scanner_status;
+if tracing_ifs>0 then show_cur_cmd_chr;
+end;
+
+@ When we begin to process a new \.{\\if}, we set |if_limit:=if_code|; then
+if\/ \.{\\or} or \.{\\else} or \.{\\fi} occurs before the current \.{\\if}
+condition has been evaluated, \.{\\relax} will be inserted.
+For example, a sequence of commands like `\.{\\ifvoid1\\else...\\fi}'
+would otherwise require something after the `\.1'.
+
+@<Push the condition stack@>=
+begin p:=new_node(if_node,0); vlink(p):=cond_ptr;
+if_limit_type(p):=if_limit;
+if_limit_subtype(p):=cur_if;
+if_line_field(p):=if_line;
+cond_ptr:=p; cur_if:=cur_chr; if_limit:=if_code; if_line:=line;
+end
+
+@ @<Pop the condition stack@>=
+begin if if_stack[in_open]=cond_ptr then if_warning;
+ {conditionals possibly not properly nested with files}
+p:=cond_ptr;
+if_line:=if_line_field(p);
+cur_if:=if_limit_subtype(p);
+if_limit:=if_limit_type(p);
+cond_ptr:=vlink(p);
+flush_node(p);
+end
+
+@ Here's a procedure that changes the |if_limit| code corresponding to
+a given value of |cond_ptr|.
+
+@p procedure change_if_limit(@!l:small_number;@!p:pointer);
+label exit;
+var q:pointer;
+begin if p=cond_ptr then if_limit:=l {that's the easy case}
+else begin q:=cond_ptr;
+ loop@+ begin if q=null then confusion("if");
+@:this can't happen if}{\quad if@>
+ if vlink(q)=p then
+ begin if_limit_type(q):=l; return;
+ end;
+ q:=vlink(q);
+ end;
+ end;
+exit:end;
+
+@ A condition is started when the |expand| procedure encounters
+an |if_test| command; in that case |expand| reduces to |conditional|,
+which is a recursive procedure.
+@^recursion@>
+
+@p procedure conditional;
+label exit,common_ending;
+var b:boolean; {is the condition true?}
+@!r:"<"..">"; {relation to be evaluated}
+@!m,@!n,@!s:integer; {to be tested against the second operand}
+@!p,@!q:pointer; {for traversing token lists in \.{\\ifx} tests}
+@!save_scanner_status:small_number; {|scanner_status| upon entry}
+@!save_cond_ptr:pointer; {|cond_ptr| corresponding to this conditional}
+@!this_if:small_number; {type of this conditional}
+@!is_unless:boolean; {was this if preceded by `\.{\\unless}' ?}
+begin b:= false; {default is false, just in case}
+if tracing_ifs>0 then if tracing_commands<=1 then show_cur_cmd_chr;
+@<Push the condition stack@>;@+save_cond_ptr:=cond_ptr;
+is_unless:=(cur_chr>=unless_code); this_if:=cur_chr mod unless_code;@/
+@<Either process \.{\\ifcase} or set |b| to the value of a boolean condition@>;
+if is_unless then b:=not b;
+if tracing_commands>1 then @<Display the value of |b|@>;
+if b then
+ begin change_if_limit(else_code,save_cond_ptr);
+ return; {wait for \.{\\else} or \.{\\fi}}
+ end;
+@<Skip to \.{\\else} or \.{\\fi}, then |goto common_ending|@>;
+common_ending: if cur_chr=fi_code then @<Pop the condition stack@>
+else if_limit:=fi_code; {wait for \.{\\fi}}
+exit:end;
+
+@ In a construction like `\.{\\if\\iftrue abc\\else d\\fi}', the first
+\.{\\else} that we come to after learning that the \.{\\if} is false is
+not the \.{\\else} we're looking for. Hence the following curious
+logic is needed.
+
+@ @<Skip to \.{\\else} or \.{\\fi}...@>=
+loop@+ begin pass_text;
+ if cond_ptr=save_cond_ptr then
+ begin if cur_chr<>or_code then goto common_ending;
+ print_err("Extra "); print_esc("or");
+@.Extra \\or@>
+ help1("I'm ignoring this; it doesn't match any \if.");
+ error;
+ end
+ else if cur_chr=fi_code then @<Pop the condition stack@>;
+ end
+
+@ @<Either process \.{\\ifcase} or set |b|...@>=
+case this_if of
+if_char_code, if_cat_code: @<Test if two characters match@>;
+if_int_code, if_dim_code: @<Test relation between integers or dimensions@>;
+if_odd_code: @<Test if an integer is odd@>;
+if_vmode_code: b:=(abs(mode)=vmode);
+if_hmode_code: b:=(abs(mode)=hmode);
+if_mmode_code: b:=(abs(mode)=mmode);
+if_inner_code: b:=(mode<0);
+if_void_code, if_hbox_code, if_vbox_code: @<Test box register status@>;
+ifx_code: @<Test if two tokens match@>;
+if_eof_code: begin scan_four_bit_int; b:=(read_open[cur_val]=closed);
+ end;
+if_true_code: b:=true;
+if_false_code: b:=false;
+@/@<Cases for |conditional|@>@/
+if_case_code: @<Select the appropriate case
+ and |return| or |goto common_ending|@>;
+if_primitive_code: begin
+ save_scanner_status:=scanner_status;
+ scanner_status:=normal;
+ get_filtered_next;
+ scanner_status:=save_scanner_status;
+ m := prim_lookup(text(cur_cs));
+ b :=((cur_cmd<>undefined_cs) and
+ (m<>undefined_primitive) and
+ (cur_cmd=get_prim_eq_type(m)) and
+ (cur_chr=get_prim_equiv(m)));
+ end;
+{there are no other cases, but for -Wall: }
+othercases
+ b:=false;
+endcases
+
+@ @<Display the value of |b|@>=
+begin begin_diagnostic;
+if b then print("{true}")@+else print("{false}");
+end_diagnostic(false);
+end
+
+@ Here we use the fact that |"<"|, |"="|, and |">"| are consecutive ASCII
+codes.
+@^ASCII code@>
+
+@<Test relation between integers or dimensions@>=
+begin if this_if=if_int_code then scan_int@+else scan_normal_dimen;
+n:=cur_val; @<Get the next non-blank non-call...@>;
+if (cur_tok>=other_token+"<")and(cur_tok<=other_token+">") then
+ r:=cur_tok-other_token
+else begin print_err("Missing = inserted for ");
+@.Missing = inserted@>
+ print_cmd_chr(if_test,this_if);
+ help1("I was expecting to see `<', `=', or `>'. Didn't.");
+ back_error; r:="=";
+ end;
+if this_if=if_int_code then scan_int@+else scan_normal_dimen;
+case r of
+"<": b:=(n<cur_val);
+"=": b:=(n=cur_val);
+">": b:=(n>cur_val);
+othercases b:=false; {can't happen}
+end;
+end
+
+@ @<Test if an integer is odd@>=
+begin scan_int; b:=odd(cur_val);
+end
+
+@ @<Test box register status@>=
+begin scan_register_num; p:=box(cur_val);
+if this_if=if_void_code then b:=(p=null)
+else if p=null then b:=false
+else if this_if=if_hbox_code then b:=(type(p)=hlist_node)
+else b:=(type(p)=vlist_node);
+end
+
+@ An active character will be treated as category 13 following
+\.{\\if\\noexpand} or following \.{\\ifcat\\noexpand}. We use the fact that
+active characters have the smallest tokens, among all control sequences.
+
+The |(biggest_char-number_active_chars)| part is needed because only the
+bottom two planes are present as active characters in |eqtb|.
+
+@d get_x_token_or_active_char==@t@>@;
+ begin get_x_token;
+ if cur_cmd=relax then if cur_chr=no_expand_flag then
+ begin cur_cmd:=active_char;
+ cur_chr:=cur_tok-cs_token_flag-active_base+(biggest_char-number_active_chars);
+ end;
+ end
+
+@<Test if two characters match@>=
+begin get_x_token_or_active_char;
+if (cur_cmd>active_char)or(cur_chr>biggest_char) then {not a character}
+ begin m:=relax; n:=too_big_char;
+ end
+else begin m:=cur_cmd; n:=cur_chr;
+ end;
+get_x_token_or_active_char;
+if (cur_cmd>active_char)or(cur_chr>biggest_char) then
+ begin cur_cmd:=relax; cur_chr:=too_big_char;
+ end;
+if this_if=if_char_code then b:=(n=cur_chr)@+else b:=(m=cur_cmd);
+end
+
+@ Note that `\.{\\ifx}' will declare two macros different if one is \\{long}
+or \\{outer} and the other isn't, even though the texts of the macros are
+the same.
+
+We need to reset |scanner_status|, since \.{\\outer} control sequences
+are allowed, but we might be scanning a macro definition or preamble.
+
+@<Test if two tokens match@>=
+begin save_scanner_status:=scanner_status; scanner_status:=normal;
+get_filtered_next; n:=cur_cs; p:=cur_cmd; q:=cur_chr;
+get_filtered_next; if cur_cmd<>p then b:=false
+else if cur_cmd<call then b:=(cur_chr=q)
+else @<Test if two macro texts match@>;
+scanner_status:=save_scanner_status;
+end
+
+@ Note also that `\.{\\ifx}' decides that macros \.{\\a} and \.{\\b} are
+different in examples like this:
+$$\vbox{\halign{\.{#}\hfil&\qquad\.{#}\hfil\cr
+ {}\\def\\a\{\\c\}&
+ {}\\def\\c\{\}\cr
+ {}\\def\\b\{\\d\}&
+ {}\\def\\d\{\}\cr}}$$
+
+@<Test if two macro texts match@>=
+begin p:=link(cur_chr); q:=link(equiv(n)); {omit reference counts}
+if p=q then b:=true
+else begin while (p<>null)and(q<>null) do
+ if info(p)<>info(q) then p:=null
+ else begin p:=link(p); q:=link(q);
+ end;
+ b:=((p=null)and(q=null));
+ end;
+end
+
+@ @<Select the appropriate case and |return| or |goto common_ending|@>=
+begin scan_int; n:=cur_val; {|n| is the number of cases to pass}
+if tracing_commands>1 then
+ begin begin_diagnostic; print("{case "); print_int(n); print_char("}");
+ end_diagnostic(false);
+ end;
+while n<>0 do
+ begin pass_text;
+ if cond_ptr=save_cond_ptr then
+ if cur_chr=or_code then decr(n)
+ else goto common_ending
+ else if cur_chr=fi_code then @<Pop the condition stack@>;
+ end;
+change_if_limit(or_code,save_cond_ptr);
+return; {wait for \.{\\or}, \.{\\else}, or \.{\\fi}}
+end
+
+@ The processing of conditionals is complete except for the following
+code, which is actually part of |expand|. It comes into play when
+\.{\\or}, \.{\\else}, or \.{\\fi} is scanned.
+
+@<Terminate the current conditional and skip to \.{\\fi}@>=
+begin if tracing_ifs>0 then if tracing_commands<=1 then show_cur_cmd_chr;
+if cur_chr>if_limit then
+ if if_limit=if_code then insert_relax {condition not yet evaluated}
+ else begin print_err("Extra "); print_cmd_chr(fi_or_else,cur_chr);
+@.Extra \\or@>
+@.Extra \\else@>
+@.Extra \\fi@>
+ help1("I'm ignoring this; it doesn't match any \if.");
+ error;
+ end
+else begin while cur_chr<>fi_code do pass_text; {skip to \.{\\fi}}
+ @<Pop the condition stack@>;
+ end;
+end
+
+@* \[29] File names.
+It's time now to fret about file names. Besides the fact that different
+operating systems treat files in different ways, we must cope with the
+fact that completely different naming conventions are used by different
+groups of people. The following programs show what is required for one
+particular operating system; similar routines for other systems are not
+difficult to devise.
+@^fingers@>
+@^system dependencies@>
+
+\TeX\ assumes that a file name has three parts: the name proper; its
+``extension''; and a ``file area'' where it is found in an external file
+system. The extension of an input file or a write file is assumed to be
+`\.{.tex}' unless otherwise specified; it is `\.{.log}' on the
+transcript file that records each run of \TeX; it is `\.{.tfm}' on the font
+metric files that describe characters in the fonts \TeX\ uses; it is
+`\.{.dvi}' on the output files that specify typesetting information; and it
+is `\.{.fmt}' on the format files written by \.{INITEX} to initialize \TeX.
+The file area can be arbitrary on input files, but files are usually
+output to the user's current area. If an input file cannot be
+found on the specified area, \TeX\ will look for it on a special system
+area; this special area is intended for commonly used input files like
+\.{webmac.tex}.
+
+Simple uses of \TeX\ refer only to file names that have no explicit
+extension or area. For example, a person usually says `\.{\\input} \.{paper}'
+or `\.{\\font\\tenrm} \.= \.{helvetica}' instead of `\.{\\input}
+\.{paper.new}' or `\.{\\font\\tenrm} \.= \.{<csd.knuth>test}'. Simple file
+names are best, because they make the \TeX\ source files portable;
+whenever a file name consists entirely of letters and digits, it should be
+treated in the same way by all implementations of \TeX. However, users
+need the ability to refer to other files in their environment, especially
+when responding to error messages concerning unopenable files; therefore
+we want to let them use the syntax that appears in their favorite
+operating system.
+
+The following procedures don't allow spaces to be part of
+file names; but some users seem to like names that are spaced-out.
+System-dependent changes to allow such things should probably
+be made with reluctance, and only when an entire file name that
+includes spaces is ``quoted'' somehow.
+
+@ In order to isolate the system-dependent aspects of file names, the
+@^system dependencies@>
+system-independent parts of \TeX\ are expressed in terms
+of three system-dependent
+procedures called |begin_name|, |more_name|, and |end_name|. In
+essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
+the system-independent driver program does the operations
+$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;|more_name|(c_n);
+\,|end_name|.$$
+These three procedures communicate with each other via global variables.
+Afterwards the file name will appear in the string pool as three strings
+called |cur_name|\penalty10000\hskip-.05em,
+|cur_area|, and |cur_ext|; the latter two are null (i.e.,
+|""|), unless they were explicitly specified by the user.
+
+Actually the situation is slightly more complicated, because \TeX\ needs
+to know when the file name ends. The |more_name| routine is a function
+(with side effects) that returns |true| on the calls |more_name|$(c_1)$,
+\dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
+returns |false|; or, it returns |true| and the token following $c_n$ is
+something like `\.{\\hbox}' (i.e., not a character). In other words,
+|more_name| is supposed to return |true| unless it is sure that the
+file name has been completely scanned; and |end_name| is supposed to be able
+to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
+whether $|more_name|(c_n)$ returned |true| or |false|.
+
+@<Glob...@>=
+@!cur_name:str_number; {name of file just scanned}
+@!cur_area:str_number; {file area just scanned, or \.{""}}
+@!cur_ext:str_number; {file extension just scanned, or \.{""}}
+
+@ The file names we shall deal with for illustrative purposes have the
+following structure: If the name contains `\.>' or `\.:', the file area
+consists of all characters up to and including the final such character;
+otherwise the file area is null. If the remaining file name contains
+`\..', the file extension consists of all such characters from the first
+remaining `\..' to the end, otherwise the file extension is null.
+@^system dependencies@>
+
+We can scan such file names easily by using two global variables that keep track
+of the occurrences of area and extension delimiters:
+
+@<Glob...@>=
+@!area_delimiter:pool_pointer; {the most recent `\.>' or `\.:', if any}
+@!ext_delimiter:pool_pointer; {the relevant `\..', if any}
+
+@ Input files that can't be found in the user's area may appear in a standard
+system area called |TEX_area|. Font metric files whose areas are not given
+explicitly are assumed to appear in a standard system area called
+|TEX_font_area|. $\Omega$'s compiled translation process files whose areas
+are not given explicitly are assumed to appear in a standard system area
+called |OMEGA_ocp_area|. These system area names will, of course, vary
+from place to place.
+@^system dependencies@>
+
+@d TEX_area=="TeXinputs:"
+@.TeXinputs@>
+@d TEX_font_area=="TeXfonts:"
+@.TeXfonts@>
+@d OMEGA_ocp_area=="OmegaOCPs:"
+@.OmegaOCPs@>
+
+@ Here now is the first of the system-dependent routines for file name scanning.
+@^system dependencies@>
+
+@p procedure begin_name;
+begin area_delimiter:=0; ext_delimiter:=0;
+end;
+
+@ And here's the second. The string pool might change as the file name is
+being scanned, since a new \.{\\csname} might be entered; therefore we keep
+|area_delimiter| and |ext_delimiter| relative to the beginning of the current
+string, instead of assigning an absolute address like |pool_ptr| to them.
+@^system dependencies@>
+
+@p function more_name(@!c:ASCII_code):boolean;
+begin if c=" " then more_name:=false
+else begin str_room(1); append_char(c); {contribute |c| to the current string}
+ if (c=">")or(c=":") then
+ begin area_delimiter:=cur_length; ext_delimiter:=0;
+ end
+ else if (c=".")and(ext_delimiter=0) then ext_delimiter:=cur_length;
+ more_name:=true;
+ end;
+end;
+
+@ The third.
+@^system dependencies@>
+
+@p procedure end_name;
+begin if str_ptr+3>(max_strings+string_offset) then
+ overflow("number of strings",max_strings-init_str_ptr);
+@:TeX capacity exceeded number of strings}{\quad number of strings@>
+if area_delimiter=0 then cur_area:=""
+else begin cur_area:=str_ptr;
+ str_start_macro(str_ptr+1):=str_start_macro(str_ptr)+area_delimiter; incr(str_ptr);
+ end;
+if ext_delimiter=0 then
+ begin cur_ext:=""; cur_name:=make_string;
+ end
+else begin cur_name:=str_ptr;
+ str_start_macro(str_ptr+1):=str_start_macro(str_ptr)+ext_delimiter-area_delimiter-1;
+ incr(str_ptr); cur_ext:=make_string;
+ end;
+end;
+
+@ Conversely, here is a routine that takes three strings and prints a file
+name that might have produced them. (The routine is system dependent, because
+some operating systems put the file area last instead of first.)
+@^system dependencies@>
+
+@<Basic printing...@>=
+procedure print_file_name(@!n,@!a,@!e:integer);
+begin slow_print(a); slow_print(n); slow_print(e);
+end;
+
+@ Another system-dependent routine is needed to convert three internal
+\TeX\ strings
+into the |nameoffile| value that is used to open files. The present code
+allows both lowercase and uppercase letters in the file name.
+@^system dependencies@>
+
+@d append_to_name(#)==begin c:=#; incr(k);
+ if k<=file_name_size then nameoffile[k]:=xchr[c];
+ end
+
+@p procedure pack_file_name(@!n,@!a,@!e:str_number);
+var k:integer; {number of positions filled in |nameoffile|}
+@!c: ASCII_code; {character being packed}
+@!j:pool_pointer; {index into |str_pool|}
+begin k:=0;
+for j:=str_start_macro(a) to str_start_macro(a+1)-1 do append_to_name(so(str_pool[j]));
+for j:=str_start_macro(n) to str_start_macro(n+1)-1 do append_to_name(so(str_pool[j]));
+for j:=str_start_macro(e) to str_start_macro(e+1)-1 do append_to_name(so(str_pool[j]));
+if k<=file_name_size then namelength:=k@+else namelength:=file_name_size;
+for k:=namelength+1 to file_name_size do nameoffile[k]:=' ';
+end;
+
+@ A messier routine is also needed, since format file names must be scanned
+before \TeX's string mechanism has been initialized. We shall use the
+global variable |TEX_format_default| to supply the text for default system areas
+and extensions related to format files.
+@^system dependencies@>
+
+@d format_default_length=20 {length of the |TEX_format_default| string}
+@d format_area_length=11 {length of its area part}
+@d format_ext_length=4 {length of its `\.{.fmt}' part}
+@d format_extension=".fmt" {the extension, as a \.{WEB} constant}
+
+@<Glob...@>=
+@!TEX_format_default:packed array[1..format_default_length] of char;
+
+@ @<Set init...@>=
+TEX_format_default:='TeXformats:plain.fmt';
+@.TeXformats@>
+@.plain@>
+@^system dependencies@>
+
+@ @<Check the ``constant'' values for consistency@>=
+if format_default_length>file_name_size then bad:=31;
+
+@ Here is the messy routine that was just mentioned. It sets |nameoffile|
+from the first |n| characters of |TEX_format_default|, followed by
+|buffer[a..b]|, followed by the last |format_ext_length| characters of
+|TEX_format_default|.
+
+We dare not give error messages here, since \TeX\ calls this routine before
+the |error| routine is ready to roll. Instead, we simply drop excess characters,
+since the error will be detected in another way when a strange file name
+isn't found.
+@^system dependencies@>
+
+@p procedure pack_buffered_name(@!n:integer;@!a,@!b:integer);
+var k:integer; {number of positions filled in |nameoffile|}
+@!c: ASCII_code; {character being packed}
+@!j:integer; {index into |buffer| or |TEX_format_default|}
+begin if n+b-a+1+format_ext_length>file_name_size then
+ b:=a+file_name_size-n-1-format_ext_length;
+k:=0;
+for j:=1 to n do append_to_name(TEX_format_default[j]);
+for j:=a to b do append_to_name(buffer[j]);
+for j:=format_default_length-format_ext_length+1 to format_default_length do
+ append_to_name(TEX_format_default[j]);
+if k<=file_name_size then namelength:=k@+else namelength:=file_name_size;
+for k:=namelength+1 to file_name_size do nameoffile[k]:=' ';
+end;
+
+@ Here is the only place we use |pack_buffered_name|. This part of the program
+becomes active when a ``virgin'' \TeX\ is trying to get going, just after
+the preliminary initialization, or when the user is substituting another
+format file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
+contains the first line of input in |buffer[loc..(last-1)]|, where
+|loc<last| and |buffer[loc]<>" "|.
+
+@<Declare the function called |open_fmt_file|@>=
+function open_fmt_file:boolean;
+label found,exit;
+var j:0..buf_size; {the first space after the format file name}
+begin j:=loc;
+if buffer[loc]="&" then
+ begin incr(loc); j:=loc; buffer[last]:=" ";
+ while buffer[j]<>" " do incr(j);
+ pack_buffered_name(0,loc,j-1); {try first without the system file area}
+ if w_open_in(fmt_file) then goto found;
+ pack_buffered_name(format_area_length,loc,j-1);
+ {now try the system format file area}
+ if w_open_in(fmt_file) then goto found;
+ wake_up_terminal;
+ wterm_ln('Sorry, I can''t find that format;',' will try PLAIN.');
+@.Sorry, I can't find...@>
+ update_terminal;
+ end;
+ {now pull out all the stops: try for the system \.{plain} file}
+pack_buffered_name(format_default_length-format_ext_length,1,0);
+if not w_open_in(fmt_file) then
+ begin wake_up_terminal;
+ wterm_ln('I can''t find the PLAIN format file!');
+@.I can't find PLAIN...@>
+@.plain@>
+ open_fmt_file:=false; return;
+ end;
+found:loc:=j; open_fmt_file:=true;
+exit:end;
+
+@ Operating systems often make it possible to determine the exact name (and
+possible version number) of a file that has been opened. The following routine,
+which simply makes a \TeX\ string from the value of |nameoffile|, should
+ideally be changed to deduce the full name of file~|f|, which is the file
+most recently opened, if it is possible to do this in a \PASCAL\ program.
+@^system dependencies@>
+
+This routine might be called after string memory has overflowed, hence
+we dare not use `|str_room|'.
+
+@d a_make_name_string(#)==make_name_string
+@d b_make_name_string(#)==make_name_string
+@d w_make_name_string(#)==make_name_string
+
+@p function make_name_string:str_number;
+var k:1..file_name_size; {index into |nameoffile|}
+begin if (pool_ptr+namelength>pool_size)or(str_ptr=max_strings)or
+ (cur_length>0) then
+ make_name_string:="?"
+else begin for k:=1 to namelength do append_char(nameoffile[k]);
+ make_name_string:=make_string;
+ end;
+end;
+
+@ Now let's consider the ``driver''
+routines by which \TeX\ deals with file names
+in a system-independent manner. First comes a procedure that looks for a
+file name in the input by calling |get_x_token| for the information.
+
+@p procedure scan_file_name;
+label done;
+begin name_in_progress:=true; begin_name;
+@<Get the next non-blank non-call...@>;
+loop@+begin if (cur_cmd>other_char)or(cur_chr>biggest_char) then {not a character}
+ begin back_input; goto done;
+ end;
+ if not more_name(cur_chr) then goto done;
+ get_x_token;
+ end;
+done: end_name; name_in_progress:=false;
+end;
+
+@ The global variable |name_in_progress| is used to prevent recursive
+use of |scan_file_name|, since the |begin_name| and other procedures
+communicate via global variables. Recursion would arise only by
+devious tricks like `\.{\\input\\input f}'; such attempts at sabotage
+must be thwarted. Furthermore, |name_in_progress| prevents \.{\\input}
+@^recursion@>
+from being initiated when a font size specification is being scanned.
+
+Another global variable, |job_name|, contains the file name that was first
+\.{\\input} by the user. This name is extended by `\.{.log}' and `\.{.dvi}'
+and `\.{.fmt}' in the names of \TeX's output files.
+
+@<Glob...@>=
+@!name_in_progress:boolean; {is a file name being scanned?}
+@!job_name:str_number; {principal file name}
+@!log_opened:boolean; {has the transcript file been opened?}
+
+@ Initially |job_name=0|; it becomes nonzero as soon as the true name is known.
+We have |job_name=0| if and only if the `\.{log}' file has not been opened,
+except of course for a short time just after |job_name| has become nonzero.
+
+@<Initialize the output...@>=
+job_name:=0; name_in_progress:=false; log_opened:=false;
+
+@ Here is a routine that manufactures the output file names, assuming that
+|job_name<>0|. It ignores and changes the current settings of |cur_area|
+and |cur_ext|.
+
+@d pack_cur_name==pack_file_name(cur_name,cur_area,cur_ext)
+
+@p procedure pack_job_name(@!s:str_number); {|s = ".log"|, |".dvi"|, or
+ |format_extension|}
+begin cur_area:=""; cur_ext:=s;
+cur_name:=job_name; pack_cur_name;
+end;
+
+@ If some trouble arises when \TeX\ tries to open a file, the following
+routine calls upon the user to supply another file name. Parameter~|s|
+is used in the error message to identify the type of file; parameter~|e|
+is the default extension if none is given. Upon exit from the routine,
+variables |cur_name|, |cur_area|, |cur_ext|, and |nameoffile| are
+ready for another attempt at file opening.
+
+@p procedure prompt_file_name(@!s,@!e:str_number);
+label done;
+var k:0..buf_size; {index into |buffer|}
+begin if interaction=scroll_mode then wake_up_terminal;
+if s="input file name" then print_err("I can't find file `")
+@.I can't find file x@>
+else print_err("I can't write on file `");
+@.I can't write on file x@>
+print_file_name(cur_name,cur_area,cur_ext); print("'.");
+if e=".tex" then show_context;
+print_nl("Please type another "); print(s);
+@.Please type...@>
+if interaction<scroll_mode then
+ fatal_error("*** (job aborted, file error in nonstop mode)");
+@.job aborted, file error...@>
+clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
+if cur_ext="" then cur_ext:=e;
+pack_cur_name;
+end;
+
+@ @<Scan file name in the buffer@>=
+begin begin_name; k:=first;
+while (buffer[k]=" ")and(k<last) do incr(k);
+loop@+ begin if k=last then goto done;
+ if not more_name(buffer[k]) then goto done;
+ incr(k);
+ end;
+done:end_name;
+end
+
+@ Here's an example of how these conventions are used. Whenever it is time to
+ship out a box of stuff, we shall use the macro |ensure_dvi_open|.
+
+@d ensure_dvi_open==if output_file_name=0 then
+ begin if job_name=0 then open_log_file;
+ pack_job_name(".dvi");
+ while not lua_b_open_out(dvi_file) do
+ prompt_file_name("file name for output",".dvi");
+ dvi_file:=name_file_pointer ;
+ output_file_name:=b_make_name_string(dvi_file);
+ end
+
+@<Glob...@>=
+@!dvi_file: byte_file; {the device-independent output goes here}
+@!output_file_name: str_number; {full name of the output file}
+@!log_name:str_number; {full name of the log file}
+
+@ @<Initialize the output...@>=output_file_name:=0;
+
+@ The |open_log_file| routine is used to open the transcript file and to help
+it catch up to what has previously been printed on the terminal.
+
+@p procedure open_log_file;
+var old_setting:0..max_selector; {previous |selector| setting}
+@!k:0..buf_size; {index into |months| and |buffer|}
+@!l:0..buf_size; {end of first input line}
+@!months:packed array [1..36] of char; {abbreviations of month names}
+begin old_setting:=selector;
+if job_name=0 then job_name:="texput";
+@.texput@>
+pack_job_name(".log");
+while not lua_a_open_out(addressof(log_file),0) do @<Try to get a different log file name@>;
+log_file := name_file_pointer;
+log_name:=a_make_name_string(log_file);
+selector:=log_only; log_opened:=true;
+if not callback_defined(start_run_callback) then begin
+ @<Print the banner line, including the date and time@>;
+ input_stack[input_ptr]:=cur_input; {make sure bottom level is in memory}
+ print_nl("**");
+@.**@>
+ l:=input_stack[0].limit_field; {last position of first line}
+ if buffer[l]=end_line_char then decr(l); { TODO: multichar endlinechar}
+ for k:=1 to l do print(buffer[k]);
+ print_ln; {now the transcript file contains the first line of input}
+ end
+else begin
+ flush_loggable_info;
+end;
+selector:=old_setting+2; {|log_only| or |term_and_log|}
+end;
+
+@ Sometimes |open_log_file| is called at awkward moments when \TeX\ is
+unable to print error messages or even to |show_context|.
+The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
+routine will not be invoked because |log_opened| will be false.
+
+The normal idea of |batch_mode| is that nothing at all should be written
+on the terminal. However, in the unusual case that
+no log file could be opened, we make an exception and allow
+an explanatory message to be seen.
+
+Incidentally, the program always refers to the log file as a `\.{transcript
+file}', because some systems cannot use the extension `\.{.log}' for
+this file.
+
+@<Try to get a different log file name@>=
+begin selector:=term_only;
+prompt_file_name("transcript file name",".log");
+end
+
+@ @<Print the banner...@>=
+begin wlog(banner);
+slow_print(format_ident); print(" ");
+print_int(day); print_char(" ");
+months:='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
+for k:=3*month-2 to 3*month do wlog(months[k]);
+print_char(" "); print_int(year); print_char(" ");
+print_two(time div 60); print_char(":"); print_two(time mod 60);
+end
+
+@ Let's turn now to the procedure that is used to initiate file reading
+when an `\.{\\input}' command is being processed.
+
+@p procedure start_input; {\TeX\ will \.{\\input} something}
+label done;
+var temp_str:str_number;
+begin scan_file_name; {set |cur_name| to desired file name}
+if cur_ext="" then cur_ext:=".tex";
+pack_cur_name;
+loop@+ begin begin_file_reading; {set up |cur_file| and new level of input}
+ if lua_a_open_in(cur_file,0) then goto done;
+ end_file_reading; {remove the level that didn't work}
+ prompt_file_name("input file name",".tex");
+ end;
+done:
+cur_file := name_file_pointer;
+name:=a_make_name_string(cur_file);
+if job_name=0 then
+ begin job_name:=cur_name; open_log_file;
+ end; {|open_log_file| doesn't |show_context|, so |limit|
+ and |loc| needn't be set to meaningful values yet}
+if tracefilenames then begin
+ if term_offset+length(name)>max_print_line-2 then print_ln
+ else if (term_offset>0)or(file_offset>0) then print_char(" ");
+ print_char("(");
+ slow_print(name);
+end;
+incr(open_parens);
+update_terminal;
+state:=new_line;
+if name=str_ptr-1 then {we can conserve string pool space now}
+ begin flush_string; name:=cur_name;
+ end;
+@<Read the first line of the new file@>;
+end;
+
+@ Here we have to remember to tell the |lua_input_ln| routine not to
+start with a |get|. If the file is empty, it is considered to
+contain a single blank line.
+@^system dependencies@>
+@^empty line at end of file@>
+
+@<Read the first line...@>=
+begin line:=1;
+if lua_input_ln(cur_file,0,false) then do_nothing;
+firm_up_the_line;
+if end_line_char_inactive then decr(limit)
+else buffer[limit]:=end_line_char;
+first:=limit+1; loc:=start;
+end
+
+@* \[30] Font metric data and OCPS.
+\TeX\ gets its knowledge about fonts from font metric files, also called
+\.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
+but other programs know about them too.
+@:TFM files}{\.{TFM} files@>
+@^font metric files@>
+
+@ When the user defines \.{\\font\\f}, say, \TeX\ assigns an internal number
+to the user's font~\.{\\f}. Adding this number to |font_id_base| gives the
+|eqtb| location of a ``frozen'' control sequence that will always select
+the font.
+
+@<Types...@>=
+@!internal_font_number=integer; {|font| in a |char_node|}
+@!font_index=integer; {index into |font_info|}
+
+@ @<Glob...@>=
+@!font_bytes:integer;
+
+@ \TeX\ always knows at least one font, namely the null font. It has no
+characters, and its seven parameters are all equal to zero.
+
+@<Initialize table...@>=
+create_null_font;
+font_bytes:=0;
+
+@ @<Put each...@>=
+primitive("nullfont",set_font,null_font);
+@!@:null_font_}{\.{\\nullfont} primitive@>
+text(frozen_null_font):="nullfont"; eqtb[frozen_null_font]:=eqtb[cur_val];
+
+@ @<The em width for |cur_font|@>=quad(cur_font)
+
+@ @<The x-height for |cur_font|@>=x_height(cur_font)
+
+@ Before we forget about the format of these tables, let's deal with two
+of \TeX's basic scanning routines related to font information.
+
+@<Declare procedures that scan font-related stuff@>=
+procedure scan_font_ident;
+var f:internal_font_number;
+@!m:halfword;
+begin @<Get the next non-blank non-call...@>;
+if (cur_cmd=def_font) or (cur_cmd=letterspace_font) then f:=cur_font
+else if cur_cmd=set_font then begin
+ f:=cur_chr;
+ set_font_touched(f,1);
+ end
+else if cur_cmd=def_family then begin
+ m:=cur_chr; scan_math_family_int; f:=equiv(m+cur_val);
+ set_font_touched(f,1);
+ end
+else begin print_err("Missing font identifier");
+@.Missing font identifier@>
+ help2("I was looking for a control sequence whose")@/
+ ("current meaning has been defined by \font.");
+ back_error; f:=null_font;
+ end;
+cur_val:=f;
+end;
+
+@ The following routine is used to implement `\.{\\fontdimen} |n| |f|'.
+The boolean parameter |writing| is set |true| if the calling program
+intends to change the parameter value.
+
+@<Declare procedures that scan font-related stuff@>=
+procedure set_font_dimen;forward;
+procedure get_font_dimen;forward;
+
+@ @p
+procedure set_font_dimen;
+label exit;
+var f:internal_font_number;
+@!n:integer; {the parameter number}
+begin scan_int; n:=cur_val; scan_font_ident; f:=cur_val;
+ if n<=0 then
+ @<Issue a font parameter error message, and return@>
+ else begin
+ if n>font_params(f) then
+ if font_touched(f) then @<Issue a font parameter error message, and return@>
+ else @<Increase the number of parameters in the font@>;
+ end;
+ scan_optional_equals; scan_normal_dimen;
+ set_font_param(f,n,cur_val);
+exit:
+end;
+@#
+procedure get_font_dimen;
+label exit;
+var f:internal_font_number;
+@!n:integer; {the parameter number}
+begin scan_int; n:=cur_val; scan_font_ident; f:=cur_val;
+ cur_val:=0; { initialize return value }
+ if n<=0 then
+ @<Issue a font parameter error message, and return@>
+ else begin
+ if n>font_params(f) then
+ if font_touched(f) then @<Issue a font parameter error message, and return@>
+ else @<Increase the number of parameters in the font@>;
+ end;
+ cur_val:=font_param(f,n);
+exit:
+ scanned_result(cur_val)(dimen_val);
+end;
+
+@ @<Issue a font parameter error message, and return@>=
+begin print_err("Font "); print_esc(font_id_text(f));
+ print(" has only "); print_int(font_params(f));
+ print(" fontdimen parameters");
+@.Font x has only...@>
+ help2("To increase the number of font parameters, you must")@/
+ ("use \fontdimen immediately after the \font is loaded.");
+ error;
+ return;
+end
+
+@ @<Increase the number of parameters...@>=
+begin repeat
+ set_font_param(f,(font_params(f)+1),0);
+until n=font_params(f);
+end
+
+
+@ When \TeX\ wants to typeset a character that doesn't exist, the
+character node is not created; thus the output routine can assume
+that characters exist when it sees them. The following procedure
+prints a warning message unless the user has suppressed it.
+
+@p procedure char_warning(@!f:internal_font_number;@!c:integer);
+var old_setting: integer; {saved value of |tracing_online|}
+begin if tracing_lost_chars>0 then
+ begin old_setting:=tracing_online;
+ if tracing_lost_chars>1 then tracing_online:=1;
+ begin begin_diagnostic;
+ print_nl("Missing character: There is no ");
+@.Missing character@>
+ print(c); print(" (");
+ print_int(c); print(") in font ");
+ print_font_name(f);
+ print_char("!"); end_diagnostic(false);
+ end;
+ tracing_online:=old_setting;
+ end;
+end;
+
+@
+@<Types...@>=
+@!active_index=0..active_mem_size;
+
+@
+@d active_ocp(#)==active_info[#].hh.b0
+@d active_counter(#)==active_info[#].hh.b1
+@d active_lstack_no(#)==active_info[#+1].sc
+
+@<Glob...@>=
+@!active_info:array[active_index] of memory_word;
+@!active_min_ptr:active_index; {first unused word of |active_info|}
+@!active_max_ptr:active_index; {last unused word of |active_info|}
+@!active_real:active_index;
+@!holding:array[active_index] of ocp_list_index;
+
+@
+@<Initialize table...@>=
+active_min_ptr:=0;
+active_real:=0;
+
+@
+@p
+function is_last_ocp(llstack_no:scaled; counter:integer):integer;
+begin
+active_min_ptr:=equiv(ocp_active_min_ptr_base);
+active_max_ptr:=equiv(ocp_active_max_ptr_base);
+active_real:=active_min_ptr;
+while (active_real < active_max_ptr) and
+ (active_lstack_no(active_real) < llstack_no) do begin
+ active_real:=active_real+2;
+ end;
+while (active_real < active_max_ptr) and
+ (active_lstack_no(active_real) = llstack_no) and
+ (active_counter(active_real) <= counter) do begin
+ active_real:=active_real+2;
+ end;
+is_last_ocp := (active_real=active_max_ptr);
+end;
+
+procedure print_active_ocps;
+var i:integer;
+begin
+print_nl("Active ocps: [");
+i:=active_min_ptr;
+while i<active_max_ptr do begin
+ print("(");
+ print_scaled(active_lstack_no(i));
+ print(",");
+ print_int(active_counter(i));
+ print(",");
+ print_esc(ocp_id_text(active_ocp(i)));
+ print(")");
+ if i<>(active_max_ptr-2) then print(",");
+ i:=i+2;
+ end;
+print("]");
+end;
+
+procedure add_ocp_stack(min_index:integer; min_value:scaled);
+var p:ocp_lstack_index;
+ llstack_no:scaled;
+ counter:integer;
+ m:scaled;
+begin
+m:=min_value; { TH: whatever this is ..}
+p:=ocp_list_lstack(holding[min_index]);
+llstack_no:=ocp_list_lstack_no(holding[min_index]);
+counter:=0;
+while not (is_null_ocp_lstack(p)) do begin
+ active_ocp(active_max_ptr):=ocp_lstack_ocp(p);
+ active_counter(active_max_ptr):=counter;
+ active_lstack_no(active_max_ptr):=llstack_no;
+ p:=ocp_lstack_lnext(p);
+ active_max_ptr:=active_max_ptr+2;
+ incr(counter); {no overflow problem}
+ end;
+end;
+
+procedure active_compile;
+var i:integer;
+ min_index:integer;
+ min_stack_ocp:scaled;
+ old_min:scaled;
+ max_active:integer;
+ stack_value:scaled;
+begin
+active_min_ptr:=active_max_ptr;
+min_stack_ocp:=ocp_maxint;
+max_active:=equiv(ocp_active_number_base)-1;
+min_index:=max_active; {TH I hope ... }
+for i:=max_active downto 0 do begin
+ holding[i]:=ocp_list_list[equiv(ocp_active_base+i)];
+ stack_value:=ocp_list_lstack_no(holding[i]);
+ if stack_value<min_stack_ocp then begin
+ min_index:=i;
+ min_stack_ocp:=stack_value;
+ end;
+ end;
+while min_stack_ocp<ocp_maxint do begin
+ add_ocp_stack(min_index, min_stack_ocp);
+ old_min:=min_stack_ocp;
+ min_stack_ocp:=ocp_maxint;
+ for i:=max_active downto 0 do begin
+ stack_value:=ocp_list_lstack_no(holding[i]);
+ while old_min=stack_value do begin
+ holding[i]:=ocp_list_lnext(holding[i]);
+ stack_value:=ocp_list_lstack_no(holding[i]);
+ end;
+ if stack_value<min_stack_ocp then begin
+ min_index:=i;
+ min_stack_ocp:=stack_value;
+ end;
+ end;
+ end;
+end;
+
+@ Here we begin the \.{OCP} file handling.
+
+@<Glob...@>=
+@!ocp_file:byte_file;
+
+@ So that is what \.{OCP} files hold.
+
+When the user defines \.{\\ocp\\f}, say, \TeX\ assigns an internal number
+to the user's ocp~\.{\\f}. Adding this number to |ocp_id_base| gives the
+|eqtb| location of a ``frozen'' control sequence that will always select
+the ocp.
+
+@<Types...@>=
+@!internal_ocp_number=ocp_base..ocp_biggest;
+@!ocp_index=integer;
+
+@ Here now is the array of ocp arrays.
+
+@<Glob...@>=
+@!ocp_ptr:internal_ocp_number; {largest internal ocp number in use}
+@!ocp_buffer:^real_eight_bits; {byte buffer for ocp files}
+@!ocp_size:integer; {total size of the ocp file}
+@!ocp_cur:integer; {index into |ocp_buffer|}
+
+@ @<Set init...@>=
+ocp_buffer:=0; ocp_size:=0; ocp_cur:=0;
+
+@ Besides the arrays just enumerated, we have two directory arrays that
+make it easy to get at the individual entries in |ocp_info|.
+The beginning of the info for the |j|-th state in the |i|-th ocp is at
+location |ocp_info[ocp_state_base[i]+j]| and the |k|-th entry is in
+location |ocp_info[ocp_info[ocp_state_base[i]+j]+k]|.
+(These formulas assume that |min_quarterword| has already been
+added to |i|, |j| and |k|, since $\Omega$ stores its quarterwords that way.)
+
+@d ocp_info_end(#)==#]
+@d ocp_info(#)==ocp_tables[#,ocp_info_end
+@d offset_ocp_file_size=0
+@d offset_ocp_name=1
+@d offset_ocp_area=offset_ocp_name+1
+@d offset_ocp_external=offset_ocp_area+1
+@d offset_ocp_external_arg=offset_ocp_external+1
+@d offset_ocp_input=offset_ocp_external_arg+1
+@d offset_ocp_output=offset_ocp_input+1
+@d offset_ocp_no_tables=offset_ocp_output+1
+@d offset_ocp_no_states=offset_ocp_no_tables+1
+@d offset_ocp_table_base=offset_ocp_no_states+1
+@d offset_ocp_state_base=offset_ocp_table_base+1
+@d offset_ocp_info=offset_ocp_state_base+1
+@d ocp_file_size(#)==ocp_info(#)(offset_ocp_file_size)
+@d ocp_name(#)==ocp_info(#)(offset_ocp_name)
+@d ocp_area(#)==ocp_info(#)(offset_ocp_area)
+@d ocp_external(#)==ocp_info(#)(offset_ocp_external)
+@d ocp_external_arg(#)==ocp_info(#)(offset_ocp_external_arg)
+@d ocp_input(#)==ocp_info(#)(offset_ocp_input)
+@d ocp_output(#)==ocp_info(#)(offset_ocp_output)
+@d ocp_no_tables(#)==ocp_info(#)(offset_ocp_no_tables)
+@d ocp_no_states(#)==ocp_info(#)(offset_ocp_no_states)
+@d ocp_table_base(#)==ocp_info(#)(offset_ocp_table_base)
+@d ocp_state_base(#)==ocp_info(#)(offset_ocp_state_base)
+
+@ $\Omega$ always knows at least one ocp, namely the null ocp.
+It does nothing.
+
+@<Initialize table...@>=
+ocp_ptr:=null_ocp;
+allocate_ocp_table(null_ocp,17);
+ocp_file_size(null_ocp):=17;
+ocp_name(null_ocp):="nullocp"; ocp_area(null_ocp):="";
+ocp_external(null_ocp):=0; ocp_external_arg(null_ocp):=0;
+ocp_input(null_ocp):=1; ocp_output(null_ocp):=1;
+ocp_no_tables(null_ocp):=0;
+ocp_no_states(null_ocp):=1;
+ocp_table_base(f):=offset_ocp_info;
+ocp_state_base(f):=offset_ocp_info;
+ocp_info(null_ocp)(offset_ocp_info) := offset_ocp_info+2; {number of entries}
+ocp_info(null_ocp)(offset_ocp_info+1) := offset_ocp_info+5; {number of entries}
+ocp_info(null_ocp)(offset_ocp_info+2) := 23; {|OTP_LEFT_START|}
+ocp_info(null_ocp)(offset_ocp_info+3) := 3; {|OTP_RIGHT_CHAR|}
+ocp_info(null_ocp)(offset_ocp_info+4) := 36; {|OTP_STOP|}
+
+
+@ @<Put each...@>=
+primitive("nullocp", set_ocp, null_ocp);
+text(frozen_null_ocp) := "nullocp";
+eqtb[frozen_null_ocp] := eqtb[cur_val];
+geq_define(ocp_active_number_base, data, 0);
+geq_define(ocp_active_min_ptr_base, data, 0);
+geq_define(ocp_active_max_ptr_base, data, 0);
+
+@ Of course we want to define macros that suppress the detail of how ocp
+information is actually packed, so that we don't have to write things like
+$$\hbox{|ocp_info[k+ocp_info[j+ocp_state_base[i]]]|}$$
+too often. The \.{WEB} definitions here make |ocp_state_entry(i)(j)(k)|
+(|ocp_table_entry(i)(j)(k)|) the |k|-th word in the |j|-th state (table)
+of the |i|-th ocp.
+@^inner loop@>
+
+@d ocp_state_end(#)==#]
+@d ocp_state_one(#)==#*2]+ocp_state_end
+@d ocp_state_entry(#)==ocp_tables[#,ocp_tables[#,ocp_state_base(#)+ocp_state_one
+
+@d ocp_state_no_end(#)==#*2+1]
+@d ocp_state_no(#)==ocp_tables[#,ocp_state_base(#)+ocp_state_no_end
+
+@d ocp_table_end(#)==#]
+@d ocp_table_one(#)==#*2]+ocp_table_end
+@d ocp_table_entry(#)==ocp_tables[#,ocp_tables[#,ocp_table_base(#)+ocp_table_one
+
+@d ocp_table_no_end(#)==#*2+1]
+@d ocp_table_no(#)==ocp_tables[#,ocp_table_base(#)+ocp_table_no_end
+
+@ $\Omega$ checks the information of a \.{OCP} file for validity as the
+file is being read in, so that no further checks will be needed when
+typesetting is going on. The somewhat tedious subroutine that does this
+is called |read_ocp_info|. It has three parameters: the user ocp
+identifier~|u|, and the file name and area strings |nom| and |aire|.
+
+The subroutine opens and closes a global file variable called |ocp_file|.
+It returns the value of the internal ocp number that was just loaded.
+If an error is detected, an error message is issued and no ocp
+information is stored; |null_ocp| is returned in this case.
+
+@d bad_ocp=11 {label for |read_ocp_info|}
+@d ocp_abort(#)==begin print("OCP file error (");
+ print(#); print(")"); print_ln; goto bad_ocp end
+ {do this when the \.{OCP} data is wrong}
+
+@p function read_ocp_info(@!u:pointer;@!nom,@!aire,@!ext:str_number;
+ @!external_ocp:boolean)
+ :internal_ocp_number; {input a \.{OCP} file}
+label done,bad_ocp,not_found;
+var
+@!file_opened:boolean; {was |ocp_file| successfully opened?}
+@!k:integer;
+@!res:boolean;
+@!callback_id:integer;
+@!fnam:str_number;
+@!f:internal_ocp_number; {the new ocp's number}
+@!g:internal_ocp_number; {the number to return}
+@!ocpword:integer;
+@!ocpmem_run_ptr:ocp_index;
+@!ocp_length,real_ocp_length:integer; {length of ocp file}
+@!previous_address:ocp_index;
+@!temp_ocp_input:integer;
+@!temp_ocp_output:integer;
+@!temp_ocp_no_tables:integer;
+@!temp_ocp_no_states:integer;
+@!i,new_offset,room_for_tables,room_for_states:integer;
+begin g:=null_ocp; f:=null_ocp;@/
+@<Read and check the ocp data; |ocp_abort| if the \.{OCP} file is
+ malformed; if there's no room for this ocp, say so and |goto
+ done|; otherwise |incr(ocp_ptr)| and |goto done|@>;
+bad_ocp: @<Report that the ocp won't be loaded@>;
+done:
+ocp_name(f):=nom; ocp_area(f):=aire;
+read_ocp_info:=g;
+end;
+
+@ $\Omega$ does not give precise details about why it
+rejects a particular \.{OCP} file.
+
+@d start_ocp_error_message==print_err("Translation process ");
+ sprint_cs(u); print_char("="); print_file_name(nom,aire,"");
+
+@<Report that the ocp won't be loaded@>=
+start_ocp_error_message;
+@.Translation process x=xx not loadable...@>
+if file_opened then print(" not loadable: Bad ocp file")
+else print(" not loadable: ocp file not found");
+help2("I wasn't able to read the data for this ocp,")@/
+("so I will ignore the ocp specification.");
+error
+
+@ @<Read and check the ocp data...@>=
+if external_ocp then
+ @<Check |ocp_file| exists@>
+else begin
+ @<Open |ocp_file| for input@>;
+ @<Read the {\.{OCP}} file@>;
+ end;
+
+@ @<Check |ocp_file| exists@>=
+begin
+file_opened:=false;
+pack_file_name(nom,aire,ext);
+b_test_in;
+if namelength=0 then ocp_abort("opening file");
+f :=ocp_ptr+1;
+allocate_ocp_table(f,13);
+ocp_file_size(f):=13;
+for i:=1 to namelength do begin
+ append_char(nameoffile[i]);
+ end;
+ocp_external(f):=make_string;
+scan_string_argument;
+ocp_external_arg(f):=cur_val;
+ocp_name(f):=""; ocp_area(f):="";
+ocp_state_base(f):=0; ocp_table_base(f):=0;
+ocp_input(f):=1; ocp_output(f):=1;
+ocp_info(f)(offset_ocp_info):=0;
+ocp_ptr:=f; g:=f;
+goto done;
+end
+
+@ @<Open |ocp_file| for input@>=
+file_opened:=false;
+pack_file_name(nom,aire,".ocp");
+if ocp_buffer<>0 then libcfree(ocp_buffer);
+ocp_cur:=0; ocp_buffer:=0; ocp_size:=0;
+callback_id:=callback_defined(find_ocp_file_callback);
+if callback_id>0 then begin
+ res := run_callback(callback_id,'S->s',stringcast(nameoffile+1), addressof(fnam));
+ if (res)and(fnam<>0)and(length(fnam)>0) then begin
+ @<Fixup |nameoffile| after callback@>;
+ end;
+ end;
+callback_id:=callback_defined(read_ocp_file_callback);
+if callback_id>0 then begin
+ res := run_callback(callback_id,'S->bSd',stringcast(nameoffile+1),
+ addressof(file_opened), addressof(ocp_buffer),addressof(ocp_size));
+ if not res then ocp_abort("callback error");
+ if not file_opened then ocp_abort("opening file");
+ if not ocp_size then ocp_abort("checking size");
+ end
+else begin
+ if not ocp_open_in(ocp_file) then ocp_abort("opening file");
+ file_opened:=true;
+ res := read_ocp_file(ocp_file,addressof(ocp_buffer),addressof(ocp_size));
+ b_close(ocp_file);
+ if not ocp_size then ocp_abort("checking size");
+ if not res then ocp_abort("reading file");
+end
+
+
+@ Note: A malformed \.{OCP} file might be shorter than it claims to be;
+thus |eof(ocp_file)| might be true when |read_ocp_info| refers to
+|ocp_file^| or when it says |get(ocp_file)|. If such circumstances
+cause system error messages, you will have to defeat them somehow,
+for example by defining |ocpget| to be `\ignorespaces|begin get(ocp_file);|
+|if eof(ocp_file) then ocp_abort; end|\unskip'.
+@^system dependencies@>
+
+@d add_to_ocp_info(#)==begin ocp_tables[f,ocpmem_run_ptr]:=#;
+ incr(ocpmem_run_ptr);
+ end
+@d ocpget==incr(ocp_cur)
+@d ocpbyte==ocp_buffer[ocp_cur]
+@d ocp_read(#)==begin ocpword:=ocpbyte;
+ if ocpword>127 then ocp_abort("checking first octet");
+ ocpget; ocpword:=ocpword*@'400+ocpbyte;
+ ocpget; ocpword:=ocpword*@'400+ocpbyte;
+ ocpget; ocpword:=ocpword*@'400+ocpbyte;
+ #:=ocpword;
+ end
+@d ocp_read_all(#)==begin ocpget; ocp_read(#); end
+@d ocp_read_info==begin ocp_read_all(ocpword);
+ add_to_ocp_info(ocpword);
+ end
+
+@ @<Read the {\.{OCP}} file@>=
+begin
+f :=ocp_ptr+1;
+ocpmem_run_ptr:=offset_ocp_info;
+ocp_read(ocp_length);
+real_ocp_length:=ocp_length-7;
+ocp_read_all(temp_ocp_input);
+ocp_read_all(temp_ocp_output);
+ocp_read_all(temp_ocp_no_tables);
+ocp_read_all(room_for_tables);
+ocp_read_all(temp_ocp_no_states);
+ocp_read_all(room_for_states);
+if real_ocp_length <>
+ (temp_ocp_no_tables + room_for_tables +
+ temp_ocp_no_states + room_for_states) then
+ ocp_abort("checking size");
+real_ocp_length:=real_ocp_length+12+
+ temp_ocp_no_states+temp_ocp_no_tables;
+allocate_ocp_table(f,real_ocp_length);
+ocp_external(f):=0;
+ocp_external_arg(f):=0;
+ocp_file_size(f):=real_ocp_length;
+ocp_input(f):=temp_ocp_input;
+ocp_output(f):=temp_ocp_output;
+ocp_no_tables(f):=temp_ocp_no_tables;
+ocp_no_states(f):=temp_ocp_no_states;
+ocp_table_base(f):=ocpmem_run_ptr;
+if ocp_no_tables(f) <> 0 then begin
+ previous_address:=ocpmem_run_ptr+2*(ocp_no_tables(f));
+ for i:=1 to ocp_no_tables(f) do begin
+ add_to_ocp_info(previous_address);
+ ocp_read_all(new_offset);
+ add_to_ocp_info(new_offset);
+ previous_address:=previous_address+new_offset;
+ end
+ end;
+if room_for_tables <> 0 then begin
+ for i:=1 to room_for_tables do begin
+ ocp_read_info;
+ end
+ end;
+ocp_state_base(f):=ocpmem_run_ptr;
+if ocp_no_states(f) <> 0 then begin
+ previous_address:=ocpmem_run_ptr+2*(ocp_no_states(f));
+ for i:=1 to ocp_no_states(f) do begin
+ add_to_ocp_info(previous_address);
+ ocp_read_all(new_offset);
+ add_to_ocp_info(new_offset);
+ previous_address:=previous_address+new_offset;
+ end;
+ end;
+if room_for_states <> 0 then begin
+ for i:=1 to room_for_states do begin
+ ocp_read_info;
+ end
+ end;
+ocp_ptr:=f; g:=f;
+goto done;
+end
+
+@ Before we forget about the format of these tables, let's deal with
+$\Omega$'s basic scanning routine related to ocp information.
+
+@<Declare procedures that scan ocp-related stuff@>=
+procedure scan_ocp_ident;
+var f:internal_ocp_number;
+begin @<Get the next non-blank non-call...@>;
+if cur_cmd=set_ocp then f:=cur_chr
+else begin print_err("Missing ocp identifier");
+@.Missing ocp identifier@>
+ help2("I was looking for a control sequence whose")@/
+ ("current meaning has been defined by \ocp.");
+ back_error; f:=null_ocp;
+ end;
+cur_val:=f;
+end;
+
+
+@ Here we begin the \.{OCP} list handling.
+
+
+@<Types...@>=
+@!internal_ocp_list_number=ocp_list_base..ocp_list_biggest;
+@!ocp_list_index=integer; {index into |ocp_list_info|}
+@!ocp_lstack_index=integer; {index into |ocp_lstack_info|}
+
+@ Here now is the array of ocp arrays.
+@d ocp_list_lnext(#)==ocp_list_info[#].hh.b0
+@d ocp_list_lstack(#)==ocp_list_info[#].hh.b1
+@d ocp_list_lstack_no(#)==ocp_list_info[#+1].sc
+@d ocp_lstack_lnext(#)==ocp_lstack_info[#].hh.b0
+@d ocp_lstack_ocp(#)==ocp_lstack_info[#].hh.b1
+@d make_null_ocp_list==make_ocp_list_node(0,ocp_maxint,0)
+@d is_null_ocp_list(#)==ocp_list_lstack_no(#)=ocp_maxint
+@d make_null_ocp_lstack==0
+@d is_null_ocp_lstack(#)==#=0
+@d add_before_op=1
+@d add_after_op=2
+@d remove_before_op=3
+@d remove_after_op=4
+
+@<Glob...@>=
+@!ocp_list_info:array[ocp_list_index] of memory_word;
+ {the big collection of ocp list data}
+@!ocp_listmem_ptr:ocp_list_index; {first unused word of |ocp_list_info|}
+@!ocp_listmem_run_ptr:ocp_list_index; {temp unused word of |ocp_list_info|}
+@!ocp_lstack_info:array[ocp_lstack_index] of memory_word;
+ {the big collection of ocp lstack data}
+@!ocp_lstackmem_ptr:ocp_lstack_index; {first unused word of |ocp_lstack_info|}
+@!ocp_lstackmem_run_ptr:ocp_lstack_index; {temp unused word of |ocp_lstack_info|}
+@!ocp_list_ptr:internal_ocp_list_number; {largest internal ocp list number in use}
+@!ocp_list_list:array[internal_ocp_list_number] of ocp_list_index;
+
+@
+@<Initialize table...@>=
+ocp_listmem_ptr:=2;
+ocp_list_lstack(0):=0;
+ocp_list_lstack_no(0):=ocp_maxint;
+ocp_list_lnext(0):=0;
+ocp_list_ptr:=null_ocp_list;
+ocp_list_list[null_ocp_list]:=0;
+ocp_lstackmem_ptr:=1;
+
+@ $\Omega$ always knows at least one ocp list, namely the null ocp list.
+
+@ @<Put each...@>=
+primitive("nullocplist", set_ocp_list, null_ocp_list);
+text(frozen_null_ocp_list) := "nullocplist";
+eqtb[frozen_null_ocp_list] := eqtb[cur_val];
+
+@ @p function make_ocp_list_node(llstack:ocp_lstack_index;
+ llstack_no:scaled;
+ llnext:ocp_list_index):ocp_list_index;
+var p:ocp_list_index;
+begin
+p:=ocp_listmem_run_ptr;
+ocp_list_lstack(p):=llstack;
+ocp_list_lstack_no(p):=llstack_no;
+ocp_list_lnext(p):=llnext;
+ocp_listmem_run_ptr:=ocp_listmem_run_ptr+2;
+if ocp_listmem_run_ptr>=ocp_list_size then
+ overflow("ocp_list_size",ocp_list_size);
+make_ocp_list_node:=p;
+end;
+
+function make_ocp_lstack_node(locp:internal_ocp_number;
+ llnext:ocp_lstack_index) : ocp_lstack_index;
+var p:ocp_lstack_index;
+begin
+p:=ocp_lstackmem_run_ptr;
+ocp_lstack_ocp(p):=locp;
+ocp_lstack_lnext(p):=llnext;
+incr(ocp_lstackmem_run_ptr);
+if ocp_lstackmem_run_ptr>=ocp_stack_size then
+ overflow("ocp_stack_size",ocp_stack_size);
+make_ocp_lstack_node:=p;
+end;
+
+function copy_ocp_lstack(llstack:ocp_lstack_index):ocp_lstack_index;
+var result:ocp_lstack_index;
+begin
+if is_null_ocp_lstack(llstack) then
+ result:=make_null_ocp_lstack
+else
+ result:=make_ocp_lstack_node(ocp_lstack_ocp(llstack),
+ copy_ocp_lstack(ocp_lstack_lnext(llstack)));
+copy_ocp_lstack:=result;
+end;
+
+function copy_ocp_list(list:ocp_list_index):ocp_list_index;
+var result:ocp_list_index;
+begin
+if is_null_ocp_list(list) then
+ result:=make_null_ocp_list
+else
+ result:=make_ocp_list_node(copy_ocp_lstack(ocp_list_lstack(list)),
+ ocp_list_lstack_no(list),
+ copy_ocp_list(ocp_list_lnext(list)));
+copy_ocp_list:=result;
+end;
+
+function ocp_ensure_lstack(list:ocp_list_index; llstack_no:scaled):
+ ocp_list_index;
+var p:ocp_list_index;
+ q:ocp_list_index;
+begin
+p:=list;
+if is_null_ocp_list(p) then begin
+ ocp_list_lstack_no(p) := llstack_no;
+ ocp_list_lnext(p) := make_null_ocp_list;
+ end
+else if ocp_list_lstack_no(p) > llstack_no then begin
+ ocp_list_lnext(p):=
+ make_ocp_list_node(ocp_list_lstack(p),
+ ocp_list_lstack_no(p),
+ ocp_list_lnext(p));
+ ocp_list_lstack(p):=0;
+ ocp_list_lstack_no(p):=llstack_no;
+ end
+else begin
+ q:=ocp_list_lnext(p);
+ while (not (is_null_ocp_list(q))) and
+ ocp_list_lstack_no(q) <= llstack_no do begin
+ p:=q; q:=ocp_list_lnext(q);
+ end;
+ if ocp_list_lstack_no(p) < llstack_no then begin
+ ocp_list_lnext(p) := make_ocp_list_node(0, llstack_no, q);
+ p := ocp_list_lnext(p);
+ end;
+ end;
+ocp_ensure_lstack := p;
+end;
+
+procedure ocp_apply_add(list_entry:ocp_list_index;
+ lbefore:boolean;
+ locp:internal_ocp_number);
+var p:ocp_lstack_index;
+ q:ocp_lstack_index;
+begin
+p := ocp_list_lstack(list_entry);
+if lbefore or (p=0) then begin
+ ocp_list_lstack(list_entry) := make_ocp_lstack_node(locp, p);
+ end
+else begin
+ q:=ocp_lstack_lnext(p);
+ while q<>0 do begin
+ p:=q; q:=ocp_lstack_lnext(q);
+ end;
+ ocp_lstack_lnext(p):=make_ocp_lstack_node(locp,0);
+ end;
+end;
+
+procedure ocp_apply_remove(list_entry:ocp_list_index;
+ lbefore:boolean);
+var p:ocp_lstack_index;
+ q:ocp_lstack_index;
+ r:ocp_lstack_index;
+begin
+p := ocp_list_lstack(list_entry);
+if p=0 then begin
+ print_err("warning: stack entry already empty"); print_ln
+ end
+else begin
+ q := ocp_lstack_lnext(p);
+ if lbefore or (q=0) then
+ ocp_list_lstack(list_entry) := q
+ else begin
+ r:=ocp_lstack_lnext(q);
+ while r <> 0 do begin
+ p:=q; q:=r; r:=ocp_lstack_lnext(r);
+ end;
+ ocp_lstack_lnext(p) := 0;
+ end
+ end;
+end;
+
+procedure scan_scaled; {sets |cur_val| to a scaled value}
+label done, done1, done2, found, not_found, attach_fraction;
+var negative:boolean; {should the answer be negated?}
+@!f:integer; {numerator of a fraction whose denominator is $2^{16}$}
+@!k,@!kk:small_number; {number of digits in a decimal fraction}
+@!p,@!q:pointer; {top of decimal digit stack}
+begin f:=0; arith_error:=false; negative:=false;
+@<Get the next non-blank non-sign...@>;
+back_input;
+if cur_tok=continental_point_token then cur_tok:=point_token;
+if cur_tok<>point_token then scan_int
+else begin radix:=10; cur_val:=0;
+ end;
+if cur_tok=continental_point_token then cur_tok:=point_token;
+if (radix=10)and(cur_tok=point_token) then @<Scan decimal fraction@>;
+if cur_val<0 then {in this case |f=0|}
+ begin negative := not negative; negate(cur_val);
+ end;
+if cur_val>@'40000 then arith_error:=true
+else cur_val := cur_val*unity +f;
+if arith_error or(abs(cur_val)>=@'10000000000) then
+begin print_err("Stack number too large"); error;
+end;
+if negative then negate(cur_val);
+end;
+
+procedure print_ocp_lstack(lstack_entry:ocp_lstack_index);
+var p:ocp_lstack_index;
+begin
+p:=lstack_entry;
+while (p<>0) do begin
+ print_esc(ocp_id_text(ocp_lstack_ocp(p)));
+ p:=ocp_lstack_lnext(p);
+ if (p<>0) then print(",");
+ end;
+end;
+
+procedure print_ocp_list(list_entry:ocp_list_index);
+var p:ocp_list_index;
+begin
+print("["); p:=list_entry;
+while not (is_null_ocp_list(p)) do begin
+ print("(");
+ print_scaled(ocp_list_lstack_no(p));
+ print(" : ");
+ print_ocp_lstack(ocp_list_lstack(p));
+ print(")");
+ p:=ocp_list_lnext(p);
+ if not (is_null_ocp_list(p)) then print(", ");
+ end;
+print("]");
+end;
+
+function scan_ocp_list: ocp_list_index;
+var llstack_no:scaled;
+ lop:quarterword;
+ lstack_entry:ocp_list_index;
+ other_list:ocp_list_index;
+ ocp_ident:internal_ocp_number;
+ result:ocp_list_index;
+begin
+get_r_token;
+if cur_cmd = set_ocp_list then
+ result := copy_ocp_list(ocp_list_list[cur_chr])
+else if cur_cmd <> ocp_list_op then begin
+ print_err("Bad ocp list specification");
+@.Bad ocp list specification@>
+ help1("I was looking for a ocp list specification.");
+ error;
+ result := make_null_ocp_list;
+ end
+else begin
+ lop:=cur_chr;
+ scan_scaled; llstack_no:=cur_val;
+ if (llstack_no<=0) or (llstack_no>=ocp_maxint) then begin
+ print_err("Stack numbers must be between 0 and 4096 (exclusive)");
+ error;
+ result := make_null_ocp_list;
+ end
+ else begin
+ if lop <= add_after_op then begin
+ scan_ocp_ident; ocp_ident:=cur_val;
+ end;
+ other_list:=scan_ocp_list;
+ lstack_entry:=ocp_ensure_lstack(other_list, llstack_no);
+ if lop <= add_after_op then
+ ocp_apply_add(lstack_entry, (lop=add_before_op), ocp_ident)
+ else
+ ocp_apply_remove(lstack_entry, (lop=remove_before_op));
+ result:=other_list;
+ end;
+ end;
+scan_ocp_list:=result;
+end;
+
+function read_ocp_list: internal_ocp_list_number;
+var f:internal_ocp_list_number;
+ g:internal_ocp_list_number;
+begin
+g:=null_ocp_list;
+f:=ocp_list_ptr+1;
+ocp_listmem_run_ptr:=ocp_listmem_ptr;
+ocp_lstackmem_run_ptr:=ocp_lstackmem_ptr;
+ocp_list_list[f]:=scan_ocp_list;
+ocp_list_ptr:=f;
+ocp_listmem_ptr:=ocp_listmem_run_ptr;
+ocp_lstackmem_ptr:=ocp_lstackmem_run_ptr;
+g:=f;
+read_ocp_list:=g;
+end;
+
+procedure scan_ocp_list_ident;
+var f:internal_ocp_list_number;
+begin @<Get the next non-blank non-call...@>;
+if cur_cmd=set_ocp_list then f:=cur_chr
+else begin print_err("Missing ocp list identifier");
+@.Missing ocp list identifier@>
+ help2("I was looking for a control sequence whose")@/
+ ("current meaning has been defined by \ocplist.");
+ back_error; f:=null_ocp_list;
+ end;
+cur_val:=f;
+end;
+
+
+@* \[31] Device-independent file format.
+The most important output produced by a run of \TeX\ is the ``device
+independent'' (\.{DVI}) file that specifies where characters and rules
+are to appear on printed pages. The form of these files was designed by
+David R. Fuchs in 1979. Almost any reasonable typesetting device can be
+@^Fuchs, David Raymond@>
+@:DVI_files}{\.{DVI} files@>
+driven by a program that takes \.{DVI} files as input, and dozens of such
+\.{DVI}-to-whatever programs have been written. Thus, it is possible to
+print the output of \TeX\ on many different kinds of equipment, using \TeX\
+as a device-independent ``front end.''
+
+A \.{DVI} file is a stream of 8-bit bytes, which may be regarded as a
+series of commands in a machine-like language. The first byte of each command
+is the operation code, and this code is followed by zero or more bytes
+that provide parameters to the command. The parameters themselves may consist
+of several consecutive bytes; for example, the `|set_rule|' command has two
+parameters, each of which is four bytes long. Parameters are usually
+regarded as nonnegative integers; but four-byte-long parameters,
+and shorter parameters that denote distances, can be
+either positive or negative. Such parameters are given in two's complement
+notation. For example, a two-byte-long distance parameter has a value between
+$-2^{15}$ and $2^{15}-1$. As in \.{TFM} files, numbers that occupy
+more than one byte position appear in BigEndian order.
+
+A \.{DVI} file consists of a ``preamble,'' followed by a sequence of one
+or more ``pages,'' followed by a ``postamble.'' The preamble is simply a
+|pre| command, with its parameters that define the dimensions used in the
+file; this must come first. Each ``page'' consists of a |bop| command,
+followed by any number of other commands that tell where characters are to
+be placed on a physical page, followed by an |eop| command. The pages
+appear in the order that \TeX\ generated them. If we ignore |nop| commands
+and \\{fnt\_def} commands (which are allowed between any two commands in
+the file), each |eop| command is immediately followed by a |bop| command,
+or by a |post| command; in the latter case, there are no more pages in the
+file, and the remaining bytes form the postamble. Further details about
+the postamble will be explained later.
+
+Some parameters in \.{DVI} commands are ``pointers.'' These are four-byte
+quantities that give the location number of some other byte in the file;
+the first byte is number~0, then comes number~1, and so on. For example,
+one of the parameters of a |bop| command points to the previous |bop|;
+this makes it feasible to read the pages in backwards order, in case the
+results are being directed to a device that stacks its output face up.
+Suppose the preamble of a \.{DVI} file occupies bytes 0 to 99. Now if the
+first page occupies bytes 100 to 999, say, and if the second
+page occupies bytes 1000 to 1999, then the |bop| that starts in byte 1000
+points to 100 and the |bop| that starts in byte 2000 points to 1000. (The
+very first |bop|, i.e., the one starting in byte 100, has a pointer of~$-1$.)
+
+@ The \.{DVI} format is intended to be both compact and easily interpreted
+by a machine. Compactness is achieved by making most of the information
+implicit instead of explicit. When a \.{DVI}-reading program reads the
+commands for a page, it keeps track of several quantities: (a)~The current
+font |f| is an integer; this value is changed only
+by \\{fnt} and \\{fnt\_num} commands. (b)~The current position on the page
+is given by two numbers called the horizontal and vertical coordinates,
+|h| and |v|. Both coordinates are zero at the upper left corner of the page;
+moving to the right corresponds to increasing the horizontal coordinate, and
+moving down corresponds to increasing the vertical coordinate. Thus, the
+coordinates are essentially Cartesian, except that vertical directions are
+flipped; the Cartesian version of |(h,v)| would be |(h,-v)|. (c)~The
+current spacing amounts are given by four numbers |w|, |x|, |y|, and |z|,
+where |w| and~|x| are used for horizontal spacing and where |y| and~|z|
+are used for vertical spacing. (d)~There is a stack containing
+|(h,v,w,x,y,z)| values; the \.{DVI} commands |push| and |pop| are used to
+change the current level of operation. Note that the current font~|f| is
+not pushed and popped; the stack contains only information about
+positioning.
+
+The values of |h|, |v|, |w|, |x|, |y|, and |z| are signed integers having up
+to 32 bits, including the sign. Since they represent physical distances,
+there is a small unit of measurement such that increasing |h| by~1 means
+moving a certain tiny distance to the right. The actual unit of
+measurement is variable, as explained below; \TeX\ sets things up so that
+its \.{DVI} output is in sp units, i.e., scaled points, in agreement with
+all the |scaled| dimensions in \TeX's data structures.
+
+@ Here is a list of all the commands that may appear in a \.{DVI} file. Each
+command is specified by its symbolic name (e.g., |bop|), its opcode byte
+(e.g., 139), and its parameters (if any). The parameters are followed
+by a bracketed number telling how many bytes they occupy; for example,
+`|p[4]|' means that parameter |p| is four bytes long.
+
+\yskip\hang|set_char_0| 0. Typeset character number~0 from font~|f|
+such that the reference point of the character is at |(h,v)|. Then
+increase |h| by the width of that character. Note that a character may
+have zero or negative width, so one cannot be sure that |h| will advance
+after this command; but |h| usually does increase.
+
+\yskip\hang\\{set\_char\_1} through \\{set\_char\_127} (opcodes 1 to 127).
+Do the operations of |set_char_0|; but use the character whose number
+matches the opcode, instead of character~0.
+
+\yskip\hang|set1| 128 |c[1]|. Same as |set_char_0|, except that character
+number~|c| is typeset. \TeX82 uses this command for characters in the
+range |128<=c<256|.
+
+\yskip\hang|@!set2| 129 |c[2]|. Same as |set1|, except that |c|~is two
+bytes long, so it is in the range |0<=c<65536|. \TeX82 never uses this
+command, but it should come in handy for extensions of \TeX\ that deal
+with oriental languages.
+@^oriental characters@>@^Chinese characters@>@^Japanese characters@>
+
+\yskip\hang|@!set3| 130 |c[3]|. Same as |set1|, except that |c|~is three
+bytes long, so it can be as large as $2^{24}-1$. Not even the Chinese
+language has this many characters, but this command might prove useful
+in some yet unforeseen extension.
+
+\yskip\hang|@!set4| 131 |c[4]|. Same as |set1|, except that |c|~is four
+bytes long. Imagine that.
+
+\yskip\hang|set_rule| 132 |a[4]| |b[4]|. Typeset a solid black rectangle
+of height~|a| and width~|b|, with its bottom left corner at |(h,v)|. Then
+set |h:=h+b|. If either |a<=0| or |b<=0|, nothing should be typeset. Note
+that if |b<0|, the value of |h| will decrease even though nothing else happens.
+See below for details about how to typeset rules so that consistency with
+\MF\ is guaranteed.
+
+\yskip\hang|@!put1| 133 |c[1]|. Typeset character number~|c| from font~|f|
+such that the reference point of the character is at |(h,v)|. (The `put'
+commands are exactly like the `set' commands, except that they simply put out a
+character or a rule without moving the reference point afterwards.)
+
+\yskip\hang|@!put2| 134 |c[2]|. Same as |set2|, except that |h| is not changed.
+
+\yskip\hang|@!put3| 135 |c[3]|. Same as |set3|, except that |h| is not changed.
+
+\yskip\hang|@!put4| 136 |c[4]|. Same as |set4|, except that |h| is not changed.
+
+\yskip\hang|put_rule| 137 |a[4]| |b[4]|. Same as |set_rule|, except that
+|h| is not changed.
+
+\yskip\hang|nop| 138. No operation, do nothing. Any number of |nop|'s
+may occur between \.{DVI} commands, but a |nop| cannot be inserted between
+a command and its parameters or between two parameters.
+
+\yskip\hang|bop| 139 $c_0[4]$ $c_1[4]$ $\ldots$ $c_9[4]$ $p[4]$. Beginning
+of a page: Set |(h,v,w,x,y,z):=(0,0,0,0,0,0)| and set the stack empty. Set
+the current font |f| to an undefined value. The ten $c_i$ parameters hold
+the values of \.{\\count0} $\ldots$ \.{\\count9} in \TeX\ at the time
+\.{\\shipout} was invoked for this page; they can be used to identify
+pages, if a user wants to print only part of a \.{DVI} file. The parameter
+|p| points to the previous |bop| in the file; the first
+|bop| has $p=-1$.
+
+\yskip\hang|eop| 140. End of page: Print what you have read since the
+previous |bop|. At this point the stack should be empty. (The \.{DVI}-reading
+programs that drive most output devices will have kept a buffer of the
+material that appears on the page that has just ended. This material is
+largely, but not entirely, in order by |v| coordinate and (for fixed |v|) by
+|h|~coordinate; so it usually needs to be sorted into some order that is
+appropriate for the device in question.)
+
+\yskip\hang|push| 141. Push the current values of |(h,v,w,x,y,z)| onto the
+top of the stack; do not change any of these values. Note that |f| is
+not pushed.
+
+\yskip\hang|pop| 142. Pop the top six values off of the stack and assign
+them respectively to |(h,v,w,x,y,z)|. The number of pops should never
+exceed the number of pushes, since it would be highly embarrassing if the
+stack were empty at the time of a |pop| command.
+
+\yskip\hang|right1| 143 |b[1]|. Set |h:=h+b|, i.e., move right |b| units.
+The parameter is a signed number in two's complement notation, |-128<=b<128|;
+if |b<0|, the reference point moves left.
+
+\yskip\hang|right2| 144 |b[2]|. Same as |right1|, except that |b| is a
+two-byte quantity in the range |-32768<=b<32768|.
+
+\yskip\hang|right3| 145 |b[3]|. Same as |right1|, except that |b| is a
+three-byte quantity in the range |@t$-2^{23}$@><=b<@t$2^{23}$@>|.
+
+\yskip\hang|right4| 146 |b[4]|. Same as |right1|, except that |b| is a
+four-byte quantity in the range |@t$-2^{31}$@><=b<@t$2^{31}$@>|.
+
+\yskip\hang|w0| 147. Set |h:=h+w|; i.e., move right |w| units. With luck,
+this parameterless command will usually suffice, because the same kind of motion
+will occur several times in succession; the following commands explain how
+|w| gets particular values.
+
+\yskip\hang|w1| 148 |b[1]|. Set |w:=b| and |h:=h+b|. The value of |b| is a
+signed quantity in two's complement notation, |-128<=b<128|. This command
+changes the current |w|~spacing and moves right by |b|.
+
+\yskip\hang|@!w2| 149 |b[2]|. Same as |w1|, but |b| is two bytes long,
+|-32768<=b<32768|.
+
+\yskip\hang|@!w3| 150 |b[3]|. Same as |w1|, but |b| is three bytes long,
+|@t$-2^{23}$@><=b<@t$2^{23}$@>|.
+
+\yskip\hang|@!w4| 151 |b[4]|. Same as |w1|, but |b| is four bytes long,
+|@t$-2^{31}$@><=b<@t$2^{31}$@>|.
+
+\yskip\hang|x0| 152. Set |h:=h+x|; i.e., move right |x| units. The `|x|'
+commands are like the `|w|' commands except that they involve |x| instead
+of |w|.
+
+\yskip\hang|x1| 153 |b[1]|. Set |x:=b| and |h:=h+b|. The value of |b| is a
+signed quantity in two's complement notation, |-128<=b<128|. This command
+changes the current |x|~spacing and moves right by |b|.
+
+\yskip\hang|@!x2| 154 |b[2]|. Same as |x1|, but |b| is two bytes long,
+|-32768<=b<32768|.
+
+\yskip\hang|@!x3| 155 |b[3]|. Same as |x1|, but |b| is three bytes long,
+|@t$-2^{23}$@><=b<@t$2^{23}$@>|.
+
+\yskip\hang|@!x4| 156 |b[4]|. Same as |x1|, but |b| is four bytes long,
+|@t$-2^{31}$@><=b<@t$2^{31}$@>|.
+
+\yskip\hang|down1| 157 |a[1]|. Set |v:=v+a|, i.e., move down |a| units.
+The parameter is a signed number in two's complement notation, |-128<=a<128|;
+if |a<0|, the reference point moves up.
+
+\yskip\hang|@!down2| 158 |a[2]|. Same as |down1|, except that |a| is a
+two-byte quantity in the range |-32768<=a<32768|.
+
+\yskip\hang|@!down3| 159 |a[3]|. Same as |down1|, except that |a| is a
+three-byte quantity in the range |@t$-2^{23}$@><=a<@t$2^{23}$@>|.
+
+\yskip\hang|@!down4| 160 |a[4]|. Same as |down1|, except that |a| is a
+four-byte quantity in the range |@t$-2^{31}$@><=a<@t$2^{31}$@>|.
+
+\yskip\hang|y0| 161. Set |v:=v+y|; i.e., move down |y| units. With luck,
+this parameterless command will usually suffice, because the same kind of motion
+will occur several times in succession; the following commands explain how
+|y| gets particular values.
+
+\yskip\hang|y1| 162 |a[1]|. Set |y:=a| and |v:=v+a|. The value of |a| is a
+signed quantity in two's complement notation, |-128<=a<128|. This command
+changes the current |y|~spacing and moves down by |a|.
+
+\yskip\hang|@!y2| 163 |a[2]|. Same as |y1|, but |a| is two bytes long,
+|-32768<=a<32768|.
+
+\yskip\hang|@!y3| 164 |a[3]|. Same as |y1|, but |a| is three bytes long,
+|@t$-2^{23}$@><=a<@t$2^{23}$@>|.
+
+\yskip\hang|@!y4| 165 |a[4]|. Same as |y1|, but |a| is four bytes long,
+|@t$-2^{31}$@><=a<@t$2^{31}$@>|.
+
+\yskip\hang|z0| 166. Set |v:=v+z|; i.e., move down |z| units. The `|z|' commands
+are like the `|y|' commands except that they involve |z| instead of |y|.
+
+\yskip\hang|z1| 167 |a[1]|. Set |z:=a| and |v:=v+a|. The value of |a| is a
+signed quantity in two's complement notation, |-128<=a<128|. This command
+changes the current |z|~spacing and moves down by |a|.
+
+\yskip\hang|@!z2| 168 |a[2]|. Same as |z1|, but |a| is two bytes long,
+|-32768<=a<32768|.
+
+\yskip\hang|@!z3| 169 |a[3]|. Same as |z1|, but |a| is three bytes long,
+|@t$-2^{23}$@><=a<@t$2^{23}$@>|.
+
+\yskip\hang|@!z4| 170 |a[4]|. Same as |z1|, but |a| is four bytes long,
+|@t$-2^{31}$@><=a<@t$2^{31}$@>|.
+
+\yskip\hang|fnt_num_0| 171. Set |f:=0|. Font 0 must previously have been
+defined by a \\{fnt\_def} instruction, as explained below.
+
+\yskip\hang\\{fnt\_num\_1} through \\{fnt\_num\_63} (opcodes 172 to 234). Set
+|f:=1|, \dots, \hbox{|f:=63|}, respectively.
+
+\yskip\hang|fnt1| 235 |k[1]|. Set |f:=k|. \TeX82 uses this command for font
+numbers in the range |64<=k<256|.
+
+\yskip\hang|@!fnt2| 236 |k[2]|. Same as |fnt1|, except that |k|~is two
+bytes long, so it is in the range |0<=k<65536|. \TeX82 never generates this
+command, but large font numbers may prove useful for specifications of
+color or texture, or they may be used for special fonts that have fixed
+numbers in some external coding scheme.
+
+\yskip\hang|@!fnt3| 237 |k[3]|. Same as |fnt1|, except that |k|~is three
+bytes long, so it can be as large as $2^{24}-1$.
+
+\yskip\hang|@!fnt4| 238 |k[4]|. Same as |fnt1|, except that |k|~is four
+bytes long; this is for the really big font numbers (and for the negative ones).
+
+\yskip\hang|xxx1| 239 |k[1]| |x[k]|. This command is undefined in
+general; it functions as a $(k+2)$-byte |nop| unless special \.{DVI}-reading
+programs are being used. \TeX82 generates |xxx1| when a short enough
+\.{\\special} appears, setting |k| to the number of bytes being sent. It
+is recommended that |x| be a string having the form of a keyword followed
+by possible parameters relevant to that keyword.
+
+\yskip\hang|@!xxx2| 240 |k[2]| |x[k]|. Like |xxx1|, but |0<=k<65536|.
+
+\yskip\hang|@!xxx3| 241 |k[3]| |x[k]|. Like |xxx1|, but |0<=k<@t$2^{24}$@>|.
+
+\yskip\hang|xxx4| 242 |k[4]| |x[k]|. Like |xxx1|, but |k| can be ridiculously
+large. \TeX82 uses |xxx4| when sending a string of length 256 or more.
+
+\yskip\hang|fnt_def1| 243 |k[1]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<256|; font definitions will be explained shortly.
+
+\yskip\hang|@!fnt_def2| 244 |k[2]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<65536|.
+
+\yskip\hang|@!fnt_def3| 245 |k[3]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<@t$2^{24}$@>|.
+
+\yskip\hang|@!fnt_def4| 246 |k[4]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |@t$-2^{31}$@><=k<@t$2^{31}$@>|.
+
+\yskip\hang|pre| 247 |i[1]| |num[4]| |den[4]| |mag[4]| |k[1]| |x[k]|.
+Beginning of the preamble; this must come at the very beginning of the
+file. Parameters |i|, |num|, |den|, |mag|, |k|, and |x| are explained below.
+
+\yskip\hang|post| 248. Beginning of the postamble, see below.
+
+\yskip\hang|post_post| 249. Ending of the postamble, see below.
+
+\yskip\noindent Commands 250--255 are undefined at the present time.
+
+@ @d set_char_0=0 {typeset character 0 and move right}
+@d set1=128 {typeset a character and move right}
+@d set_rule=132 {typeset a rule and move right}
+@d put1==133 {typeset a character without moving}
+@d put_rule=137 {typeset a rule}
+@d nop=138 {no operation}
+@d bop=139 {beginning of page}
+@d eop=140 {ending of page}
+@d push=141 {save the current positions}
+@d pop=142 {restore previous positions}
+@d right1==143 {move right}
+@d right4==146 {move right, 4 bytes}
+@d w0=147 {move right by |w|}
+@d w1=148 {move right and set |w|}
+@d x0=152 {move right by |x|}
+@d x1=153 {move right and set |x|}
+@d down1=157 {move down}
+@d down4=160 {move down, 4 bytes}
+@d y0=161 {move down by |y|}
+@d y1=162 {move down and set |y|}
+@d z0=166 {move down by |z|}
+@d z1=167 {move down and set |z|}
+@d fnt_num_0=171 {set current font to 0}
+@d fnt1=235 {set current font}
+@d xxx1=239 {extension to \.{DVI} primitives}
+@d xxx4=242 {potentially long extension to \.{DVI} primitives}
+@d fnt_def1=243 {define the meaning of a font number}
+@d pre=247 {preamble}
+@d post=248 {postamble beginning}
+@d post_post=249 {postamble ending}
+
+@ The preamble contains basic information about the file as a whole. As
+stated above, there are six parameters:
+$$\hbox{|@!i[1]| |@!num[4]| |@!den[4]| |@!mag[4]| |@!k[1]| |@!x[k]|.}$$
+The |i| byte identifies \.{DVI} format; currently this byte is always set
+to~2. (The value |i=3| is currently used for an extended format that
+allows a mixture of right-to-left and left-to-right typesetting.
+Some day we will set |i=4|, when \.{DVI} format makes another
+incompatible change---perhaps in the year 2048.)
+
+The next two parameters, |num| and |den|, are positive integers that define
+the units of measurement; they are the numerator and denominator of a
+fraction by which all dimensions in the \.{DVI} file could be multiplied
+in order to get lengths in units of $10^{-7}$ meters. Since $\rm 7227{pt} =
+254{cm}$, and since \TeX\ works with scaled points where there are $2^{16}$
+sp in a point, \TeX\ sets
+$|num|/|den|=(254\cdot10^5)/(7227\cdot2^{16})=25400000/473628672$.
+@^sp@>
+
+The |mag| parameter is what \TeX\ calls \.{\\mag}, i.e., 1000 times the
+desired magnification. The actual fraction by which dimensions are
+multiplied is therefore $|mag|\cdot|num|/1000|den|$. Note that if a \TeX\
+source document does not call for any `\.{true}' dimensions, and if you
+change it only by specifying a different \.{\\mag} setting, the \.{DVI}
+file that \TeX\ creates will be completely unchanged except for the value
+of |mag| in the preamble and postamble. (Fancy \.{DVI}-reading programs allow
+users to override the |mag|~setting when a \.{DVI} file is being printed.)
+
+Finally, |k| and |x| allow the \.{DVI} writer to include a comment, which is not
+interpreted further. The length of comment |x| is |k|, where |0<=k<256|.
+
+@d id_byte=2 {identifies the kind of \.{DVI} files described here}
+
+@ Font definitions for a given font number |k| contain further parameters
+$$\hbox{|c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.}$$
+The four-byte value |c| is the check sum that \TeX\ found in the \.{TFM}
+file for this font; |c| should match the check sum of the font found by
+programs that read this \.{DVI} file.
+@^check sum@>
+
+Parameter |s| contains a fixed-point scale factor that is applied to
+the character widths in font |k|; font dimensions in \.{TFM} files and
+other font files are relative to this quantity, which is called the
+``at size'' elsewhere in this documentation. The value of |s| is
+always positive and less than $2^{27}$. It is given in the same units
+as the other \.{DVI} dimensions, i.e., in sp when \TeX82 has made the
+file. Parameter |d| is similar to |s|; it is the ``design size,'' and
+(like~|s|) it is given in \.{DVI} units. Thus, font |k| is to be used
+at $|mag|\cdot s/1000d$ times its normal size.
+
+The remaining part of a font definition gives the external name of the font,
+which is an ASCII string of length |a+l|. The number |a| is the length
+of the ``area'' or directory, and |l| is the length of the font name itself;
+the standard local system font area is supposed to be used when |a=0|.
+The |n| field contains the area in its first |a| bytes.
+
+Font definitions must appear before the first use of a particular font number.
+Once font |k| is defined, it must not be defined again; however, we
+shall see below that font definitions appear in the postamble as well as
+in the pages, so in this sense each font number is defined exactly twice,
+if at all. Like |nop| commands, font definitions can
+appear before the first |bop|, or between an |eop| and a |bop|.
+
+@ Sometimes it is desirable to make horizontal or vertical rules line up
+precisely with certain features in characters of a font. It is possible to
+guarantee the correct matching between \.{DVI} output and the characters
+generated by \MF\ by adhering to the following principles: (1)~The \MF\
+characters should be positioned so that a bottom edge or left edge that is
+supposed to line up with the bottom or left edge of a rule appears at the
+reference point, i.e., in row~0 and column~0 of the \MF\ raster. This
+ensures that the position of the rule will not be rounded differently when
+the pixel size is not a perfect multiple of the units of measurement in
+the \.{DVI} file. (2)~A typeset rule of height $a>0$ and width $b>0$
+should be equivalent to a \MF-generated character having black pixels in
+precisely those raster positions whose \MF\ coordinates satisfy
+|0<=x<@t$\alpha$@>b| and |0<=y<@t$\alpha$@>a|, where $\alpha$ is the number
+of pixels per \.{DVI} unit.
+@:METAFONT}{\MF@>
+@^alignment of rules with characters@>
+@^rules aligning with characters@>
+
+@ The last page in a \.{DVI} file is followed by `|post|'; this command
+introduces the postamble, which summarizes important facts that \TeX\ has
+accumulated about the file, making it possible to print subsets of the data
+with reasonable efficiency. The postamble has the form
+$$\vbox{\halign{\hbox{#\hfil}\cr
+ |post| |p[4]| |num[4]| |den[4]| |mag[4]| |l[4]| |u[4]| |s[2]| |t[2]|\cr
+ $\langle\,$font definitions$\,\rangle$\cr
+ |post_post| |q[4]| |i[1]| 223's$[{\G}4]$\cr}}$$
+Here |p| is a pointer to the final |bop| in the file. The next three
+parameters, |num|, |den|, and |mag|, are duplicates of the quantities that
+appeared in the preamble.
+
+Parameters |l| and |u| give respectively the height-plus-depth of the tallest
+page and the width of the widest page, in the same units as other dimensions
+of the file. These numbers might be used by a \.{DVI}-reading program to
+position individual ``pages'' on large sheets of film or paper; however,
+the standard convention for output on normal size paper is to position each
+page so that the upper left-hand corner is exactly one inch from the left
+and the top. Experience has shown that it is unwise to design \.{DVI}-to-printer
+software that attempts cleverly to center the output; a fixed position of
+the upper left corner is easiest for users to understand and to work with.
+Therefore |l| and~|u| are often ignored.
+
+Parameter |s| is the maximum stack depth (i.e., the largest excess of
+|push| commands over |pop| commands) needed to process this file. Then
+comes |t|, the total number of pages (|bop| commands) present.
+
+The postamble continues with font definitions, which are any number of
+\\{fnt\_def} commands as described above, possibly interspersed with |nop|
+commands. Each font number that is used in the \.{DVI} file must be defined
+exactly twice: Once before it is first selected by a \\{fnt} command, and once
+in the postamble.
+
+@ The last part of the postamble, following the |post_post| byte that
+signifies the end of the font definitions, contains |q|, a pointer to the
+|post| command that started the postamble. An identification byte, |i|,
+comes next; this currently equals~2, as in the preamble.
+
+The |i| byte is followed by four or more bytes that are all equal to
+the decimal number 223 (i.e., @'337 in octal). \TeX\ puts out four to seven of
+these trailing bytes, until the total length of the file is a multiple of
+four bytes, since this works out best on machines that pack four bytes per
+word; but any number of 223's is allowed, as long as there are at least four
+of them. In effect, 223 is a sort of signature that is added at the very end.
+@^Fuchs, David Raymond@>
+
+This curious way to finish off a \.{DVI} file makes it feasible for
+\.{DVI}-reading programs to find the postamble first, on most computers,
+even though \TeX\ wants to write the postamble last. Most operating
+systems permit random access to individual words or bytes of a file, so
+the \.{DVI} reader can start at the end and skip backwards over the 223's
+until finding the identification byte. Then it can back up four bytes, read
+|q|, and move to byte |q| of the file. This byte should, of course,
+contain the value 248 (|post|); now the postamble can be read, so the
+\.{DVI} reader can discover all the information needed for typesetting the
+pages. Note that it is also possible to skip through the \.{DVI} file at
+reasonably high speed to locate a particular page, if that proves
+desirable. This saves a lot of time, since \.{DVI} files used in production
+jobs tend to be large.
+
+Unfortunately, however, standard \PASCAL\ does not include the ability to
+@^system dependencies@>
+access a random position in a file, or even to determine the length of a file.
+Almost all systems nowadays provide the necessary capabilities, so \.{DVI}
+format has been designed to work most efficiently with modern operating systems.
+But if \.{DVI} files have to be processed under the restrictions of standard
+\PASCAL, one can simply read them from front to back, since the necessary
+header information is present in the preamble and in the font definitions.
+(The |l| and |u| and |s| and |t| parameters, which appear only in the
+postamble, are ``frills'' that are handy but not absolutely necessary.)
+
+@* \[32] Shipping pages out.
+After considering \TeX's eyes and stomach, we come now to the bowels.
+@^bowels@>
+
+The |ship_out| procedure is given a pointer to a box; its mission is
+to describe that box in \.{DVI} form, outputting a ``page'' to |dvi_file|.
+The \.{DVI} coordinates $(h,v)=(0,0)$ should correspond to the upper left
+corner of the box being shipped.
+
+Since boxes can be inside of boxes inside of boxes, the main work of
+|ship_out| is done by two mutually recursive routines, |hlist_out|
+and |vlist_out|, which traverse the hlists and vlists inside of horizontal
+and vertical boxes.
+
+As individual pages are being processed, we need to accumulate
+information about the entire set of pages, since such statistics must be
+reported in the postamble. The global variables |total_pages|, |max_v|,
+|max_h|, |max_push|, and |last_bop| are used to record this information.
+
+The variable |doing_leaders| is |true| while leaders are being output.
+The variable |dead_cycles| contains the number of times an output routine
+has been initiated since the last |ship_out|.
+
+A few additional global variables are also defined here for use in
+|vlist_out| and |hlist_out|. They could have been local variables, but
+that would waste stack space when boxes are deeply nested, since the
+values of these variables are not needed during recursive calls.
+@^recursion@>
+
+@<Glob...@>=
+@!total_pages:integer; {the number of pages that have been shipped out}
+@!max_v:scaled; {maximum height-plus-depth of pages shipped so far}
+@!max_h:scaled; {maximum width of pages shipped so far}
+@!max_push:integer; {deepest nesting of |push| commands encountered so far}
+@!last_bop:integer; {location of previous |bop| in the \.{DVI} output}
+@!dead_cycles:integer; {recent outputs that didn't ship anything out}
+@!doing_leaders:boolean; {are we inside a leader box?}
+@#
+@!c,@!f:integer; {character and font in current |char_node|}
+@!oval,@!ocmd:integer; {used by |out_cmd| for generating
+ |set|, |fnt| and |fnt_def| commands}
+@!rule_ht,@!rule_dp,@!rule_wd:scaled; {size of current rule being output}
+@!g:pointer; {current glue specification}
+@!lq,@!lr:integer; {quantities used in calculations for leaders}
+
+@ @<Set init...@>=
+total_pages:=0; max_v:=0; max_h:=0; max_push:=0; last_bop:=-1;
+doing_leaders:=false; dead_cycles:=0; cur_s:=-1;
+
+@ The \.{DVI} bytes are output to a buffer instead of being written directly
+to the output file. This makes it possible to reduce the overhead of
+subroutine calls, thereby measurably speeding up the computation, since
+output of \.{DVI} bytes is part of \TeX's inner loop. And it has another
+advantage as well, since we can change instructions in the buffer in order to
+make the output more compact. For example, a `|down2|' command can be
+changed to a `|y2|', thereby making a subsequent `|y0|' command possible,
+saving two bytes.
+
+The output buffer is divided into two parts of equal size; the bytes found
+in |dvi_buf[0..half_buf-1]| constitute the first half, and those in
+|dvi_buf[half_buf..dvi_buf_size-1]| constitute the second. The global
+variable |dvi_ptr| points to the position that will receive the next
+output byte. When |dvi_ptr| reaches |dvi_limit|, which is always equal
+to one of the two values |half_buf| or |dvi_buf_size|, the half buffer that
+is about to be invaded next is sent to the output and |dvi_limit| is
+changed to its other value. Thus, there is always at least a half buffer's
+worth of information present, except at the very beginning of the job.
+
+Bytes of the \.{DVI} file are numbered sequentially starting with 0;
+the next byte to be generated will be number |dvi_offset+dvi_ptr|.
+A byte is present in the buffer only if its number is |>=dvi_gone|.
+
+@<Types...@>=
+@!dvi_index=0..dvi_buf_size; {an index into the output buffer}
+
+@ Some systems may find it more efficient to make |dvi_buf| a |packed|
+array, since output of four bytes at once may be facilitated.
+@^system dependencies@>
+
+@<Glob...@>=
+@!dvi_buf:array[dvi_index] of real_eight_bits; {buffer for \.{DVI} output}
+@!half_buf:dvi_index; {half of |dvi_buf_size|}
+@!dvi_limit:dvi_index; {end of the current half buffer}
+@!dvi_ptr:dvi_index; {the next available buffer address}
+@!dvi_offset:integer; {|dvi_buf_size| times the number of times the
+ output buffer has been fully emptied}
+@!dvi_gone:integer; {the number of bytes already output to |dvi_file|}
+
+@ Initially the buffer is all in one piece; we will output half of it only
+after it first fills up.
+
+@<Set init...@>=
+half_buf:=dvi_buf_size div 2; dvi_limit:=dvi_buf_size; dvi_ptr:=0;
+dvi_offset:=0; dvi_gone:=0;
+
+@ The actual output of |dvi_buf[a..b]| to |dvi_file| is performed by calling
+|write_dvi(a,b)|. For best results, this procedure should be optimized to
+run as fast as possible on each particular system, since it is part of
+\TeX's inner loop. It is safe to assume that |a| and |b+1| will both be
+multiples of 4 when |write_dvi(a,b)| is called; therefore it is possible on
+many machines to use efficient methods to pack four bytes per word and to
+output an array of words with one system call.
+@^system dependencies@>
+@^inner loop@>
+@^defecation@>
+
+@p procedure write_dvi(@!a,@!b:dvi_index);
+var k:dvi_index;
+begin for k:=a to b do write(dvi_file,dvi_buf[k]);
+end;
+
+@ To put a byte in the buffer without paying the cost of invoking a procedure
+each time, we use the macro |dvi_out|.
+
+@d dvi_out(#)==@+begin dvi_buf[dvi_ptr]:=#; incr(dvi_ptr);
+ if dvi_ptr=dvi_limit then dvi_swap;
+ end
+
+@p procedure dvi_swap; {outputs half of the buffer}
+begin if dvi_limit=dvi_buf_size then
+ begin write_dvi(0,half_buf-1); dvi_limit:=half_buf;
+ dvi_offset:=dvi_offset+dvi_buf_size; dvi_ptr:=0;
+ end
+else begin write_dvi(half_buf,dvi_buf_size-1); dvi_limit:=dvi_buf_size;
+ end;
+dvi_gone:=dvi_gone+half_buf;
+end;
+
+@ Here is how we clean out the buffer when \TeX\ is all through; |dvi_ptr|
+will be a multiple of~4.
+
+@<Empty the last bytes out of |dvi_buf|@>=
+if dvi_limit=half_buf then write_dvi(half_buf,dvi_buf_size-1);
+if dvi_ptr>0 then write_dvi(0,dvi_ptr-1)
+
+@ The |dvi_four| procedure outputs four bytes in two's complement notation,
+without risking arithmetic overflow.
+
+@p procedure dvi_four(@!x:integer);
+begin if x>=0 then dvi_out(x div @'100000000)
+else begin x:=x+@'10000000000;
+ x:=x+@'10000000000;
+ dvi_out((x div @'100000000) + 128);
+ end;
+x:=x mod @'100000000; dvi_out(x div @'200000);
+x:=x mod @'200000; dvi_out(x div @'400);
+dvi_out(x mod @'400);
+end;
+
+@ A mild optimization of the output is performed by the |dvi_pop|
+routine, which issues a |pop| unless it is possible to cancel a
+`|push| |pop|' pair. The parameter to |dvi_pop| is the byte address
+following the old |push| that matches the new |pop|.
+
+@p procedure dvi_pop(@!l:integer);
+begin if (l=dvi_offset+dvi_ptr)and(dvi_ptr>0) then decr(dvi_ptr)
+else dvi_out(pop);
+end;
+
+@ Here's a procedure that outputs a font definition. $\Omega$ allows
+more than 256 different fonts per job, so the right font definition
+command must be selected.
+
+@d Incr_Decr(#) == #
+@d Incr(#) == #:=#+Incr_Decr {increase a variable}
+@d Decr(#) == #:=#-Incr_Decr {decrease a variable}
+
+@d dvi_debug_out(#)==begin
+dvi_out(#);
+end
+
+@d out_cmd ==
+begin
+if (oval<@"100)and(oval>=0) then begin
+ if (ocmd<>set1)or(oval>127) then
+ if (ocmd=fnt1)and(oval<64) then Incr(oval)(fnt_num_0) @+ else dvi_debug_out(ocmd);
+ end
+else
+ begin if (oval<@"10000)and(oval>=0) then dvi_debug_out(ocmd+1) @+ else @;
+ begin if (oval<@"1000000)and(oval>=0) then dvi_debug_out(ocmd+2) @+ else @;
+ begin dvi_debug_out(ocmd+3);
+ if oval>=0 then dvi_debug_out(oval div @"1000000)
+ else begin Incr(oval)(@"40000000); Incr(oval)(@"40000000);
+ dvi_debug_out((oval div @"1000000) + 128); oval:=oval mod @"1000000;
+ end;
+ dvi_debug_out(oval div @"10000); oval:=oval mod @"10000;
+ end;
+ dvi_debug_out(oval div @"10000); oval:=oval mod @"10000;
+ end;
+ dvi_debug_out(oval div @"100); oval:=oval mod @"100;
+ end;
+dvi_debug_out(oval)
+end
+
+@p procedure dvi_font_def(@!f:internal_font_number);
+var k:pool_pointer; {index into |str_pool|}
+fa:^packed_ASCII_code;
+begin
+oval:=f-font_base-1; ocmd:= fnt_def1; out_cmd;@/
+dvi_out(font_check_0(f));
+dvi_out(font_check_1(f));
+dvi_out(font_check_2(f));
+dvi_out(font_check_3(f));@/
+dvi_four(font_size(f));
+dvi_four(font_dsize(f));@/
+dvi_out(strlen(font_area(f)));
+dvi_out(strlen(font_name(f)));
+@<Output the font name whose internal number is |f|@>;
+end;
+
+@ @<Output the font name whose internal number is |f|@>=
+fa := get_font_name(f); k := 0;
+while fa[k]<>0 do begin dvi_out(fa[k]); incr(k); end;
+fa := get_font_area(f); k := 0;
+while fa[k]<>0 do begin dvi_out(fa[k]); incr(k); end
+
+@ Versions of \TeX\ intended for small computers might well choose to omit
+the ideas in the next few parts of this program, since it is not really
+necessary to optimize the \.{DVI} code by making use of the |w0|, |x0|,
+|y0|, and |z0| commands. Furthermore, the algorithm that we are about to
+describe does not pretend to give an optimum reduction in the length
+of the \.{DVI} code; after all, speed is more important than compactness.
+But the method is surprisingly effective, and it takes comparatively little
+time.
+
+We can best understand the basic idea by first considering a simpler problem
+that has the same essential characteristics. Given a sequence of digits,
+say $3\,1\,4\,1\,5\,9\,2\,6\,5\,3\,5\,8\,9$, we want to assign subscripts
+$d$, $y$, or $z$ to each digit so as to maximize the number of ``$y$-hits''
+and ``$z$-hits''; a $y$-hit is an instance of two appearances of the same
+digit with the subscript $y$, where no $y$'s intervene between the two
+appearances, and a $z$-hit is defined similarly. For example, the sequence
+above could be decorated with subscripts as follows:
+$$3_z\,1_y\,4_d\,1_y\,5_y\,9_d\,2_d\,6_d\,5_y\,3_z\,5_y\,8_d\,9_d.$$
+There are three $y$-hits ($1_y\ldots1_y$ and $5_y\ldots5_y\ldots5_y$) and
+one $z$-hit ($3_z\ldots3_z$); there are no $d$-hits, since the two appearances
+of $9_d$ have $d$'s between them, but we don't count $d$-hits so it doesn't
+matter how many there are. These subscripts are analogous to the \.{DVI}
+commands called \\{down}, $y$, and $z$, and the digits are analogous to
+different amounts of vertical motion; a $y$-hit or $z$-hit corresponds to
+the opportunity to use the one-byte commands |y0| or |z0| in a \.{DVI} file.
+
+\TeX's method of assigning subscripts works like this: Append a new digit,
+say $\delta$, to the right of the sequence. Now look back through the
+sequence until one of the following things happens: (a)~You see
+$\delta_y$ or $\delta_z$, and this was the first time you encountered a
+$y$ or $z$ subscript, respectively. Then assign $y$ or $z$ to the new
+$\delta$; you have scored a hit. (b)~You see $\delta_d$, and no $y$
+subscripts have been encountered so far during this search. Then change
+the previous $\delta_d$ to $\delta_y$ (this corresponds to changing a
+command in the output buffer), and assign $y$ to the new $\delta$; it's
+another hit. (c)~You see $\delta_d$, and a $y$ subscript has been seen
+but not a $z$. Change the previous $\delta_d$ to $\delta_z$ and assign
+$z$ to the new $\delta$. (d)~You encounter both $y$ and $z$ subscripts
+before encountering a suitable $\delta$, or you scan all the way to the
+front of the sequence. Assign $d$ to the new $\delta$; this assignment may
+be changed later.
+
+The subscripts $3_z\,1_y\,4_d\ldots\,$ in the example above were, in fact,
+produced by this procedure, as the reader can verify. (Go ahead and try it.)
+
+@ In order to implement such an idea, \TeX\ maintains a stack of pointers
+to the \\{down}, $y$, and $z$ commands that have been generated for the
+current page. And there is a similar stack for \\{right}, |w|, and |x|
+commands. These stacks are called the down stack and right stack, and their
+top elements are maintained in the variables |down_ptr| and |right_ptr|.
+
+Each entry in these stacks contains four fields: The |width| field is
+the amount of motion down or to the right; the |location| field is the
+byte number of the \.{DVI} command in question (including the appropriate
+|dvi_offset|); the |vlink| field points to the next item below this one
+on the stack; and the |vinfo| field encodes the options for possible change
+in the \.{DVI} command.
+
+@d movement_node=48
+@d movement_node_size=3 {number of words per entry in the down and right stacks}
+@d location(#)==vmem(#+1).int {\.{DVI} byte number for a movement command}
+
+@<Glob...@>=
+@!down_ptr,@!right_ptr:pointer; {heads of the down and right stacks}
+
+@ @<Set init...@>=
+down_ptr:=null; right_ptr:=null;
+
+@ Here is a subroutine that produces a \.{DVI} command for some specified
+downward or rightward motion. It has two parameters: |w| is the amount
+of motion, and |o| is either |down1| or |right1|. We use the fact that
+the command codes have convenient arithmetic properties: |y1-down1=w1-right1|
+and |z1-down1=x1-right1|.
+
+@d dvi_set(#)==oval:=#; ocmd:=set1; out_cmd
+@d dvi_put(#)==oval:=#; ocmd:=put1; out_cmd
+@d dvi_set_rule_end(#)==dvi_four(#)
+@d dvi_set_rule(#)==dvi_out(set_rule); dvi_four(#); dvi_set_rule_end
+@d dvi_put_rule_end(#)==dvi_four(#)
+@d dvi_put_rule(#)==dvi_out(put_rule); dvi_four(#); dvi_put_rule_end
+@d dvi_right(#)==dvi_out(right4); dvi_four(#);
+@d dvi_left(#)==dvi_out(right4); dvi_four(-#);
+@d dvi_down(#)==dvi_out(down4); dvi_four(#);
+@d dvi_up(#)==dvi_out(down4); dvi_four(-#);
+
+@p procedure movement(@!w:scaled;@!o:eight_bits);
+label exit,found,not_found,2,1;
+var mstate:small_number; {have we seen a |y| or |z|?}
+@!p,@!q:pointer; {current and top nodes on the stack}
+@!k:integer; {index into |dvi_buf|, modulo |dvi_buf_size|}
+begin
+case box_direction(dvi_direction) of
+ dir_TL_: begin
+ end;
+ dir_TR_: begin
+ if o=right1 then negate(w);
+ end;
+ dir_LT_: begin
+ if o=right1 then o:=down1
+ else o:=right1;
+ end;
+ dir_LB_: begin
+ if o=right1 then begin
+ o:=down1; negate(w);
+ end
+ else o:=right1;
+ end;
+ dir_BL_: begin
+ if o=down1 then negate(w);
+ end;
+ dir_BR_: begin
+ negate(w);
+ end;
+ dir_RT_: begin
+ if o=right1 then o:=down1
+ else begin o:=right1; negate(w);
+ end;
+ end;
+ dir_RB_: begin
+ if o=right1 then o:=down1 else o:=right1;
+ negate(w);
+ end;
+ end;
+if false then begin
+q:=new_node(movement_node,0); {new node for the top of the stack}
+width(q):=w; location(q):=dvi_offset+dvi_ptr;
+if o=down1 then
+ begin vlink(q):=down_ptr; down_ptr:=q;
+ end
+else begin vlink(q):=right_ptr; right_ptr:=q;
+ end;
+@<Look at the other stack entries until deciding what sort of \.{DVI} command
+ to generate; |goto found| if node |p| is a ``hit''@>;
+end;
+@<Generate a |down| or |right| command for |w| and |return|@>;
+found: @<Generate a |y0| or |z0| command in order to reuse a previous
+ appearance of~|w|@>;
+exit:end;
+
+@ The |vinfo| fields in the entries of the down stack or the right stack
+have six possible settings: |y_here| or |z_here| mean that the \.{DVI}
+command refers to |y| or |z|, respectively (or to |w| or |x|, in the
+case of horizontal motion); |yz_OK| means that the \.{DVI} command is
+\\{down} (or \\{right}) but can be changed to either |y| or |z| (or
+to either |w| or |x|); |y_OK| means that it is \\{down} and can be changed
+to |y| but not |z|; |z_OK| is similar; and |d_fixed| means it must stay
+\\{down}.
+
+The four settings |yz_OK|, |y_OK|, |z_OK|, |d_fixed| would not need to
+be distinguished from each other if we were simply solving the
+digit-subscripting problem mentioned above. But in \TeX's case there is
+a complication because of the nested structure of |push| and |pop|
+commands. Suppose we add parentheses to the digit-subscripting problem,
+redefining hits so that $\delta_y\ldots \delta_y$ is a hit if all $y$'s between
+the $\delta$'s are enclosed in properly nested parentheses, and if the
+parenthesis level of the right-hand $\delta_y$ is deeper than or equal to
+that of the left-hand one. Thus, `(' and `)' correspond to `|push|'
+and `|pop|'. Now if we want to assign a subscript to the final 1 in the
+sequence
+$$2_y\,7_d\,1_d\,(\,8_z\,2_y\,8_z\,)\,1$$
+we cannot change the previous $1_d$ to $1_y$, since that would invalidate
+the $2_y\ldots2_y$ hit. But we can change it to $1_z$, scoring a hit
+since the intervening $8_z$'s are enclosed in parentheses.
+
+The program below removes movement nodes that are introduced after a |push|,
+before it outputs the corresponding |pop|.
+
+@d y_here=1 {|vinfo| when the movement entry points to a |y| command}
+@d z_here=2 {|vinfo| when the movement entry points to a |z| command}
+@d yz_OK=3 {|vinfo| corresponding to an unconstrained \\{down} command}
+@d y_OK=4 {|vinfo| corresponding to a \\{down} that can't become a |z|}
+@d z_OK=5 {|vinfo| corresponding to a \\{down} that can't become a |y|}
+@d d_fixed=6 {|vinfo| corresponding to a \\{down} that can't change}
+
+@ When the |movement| procedure gets to the label |found|, the value of
+|vinfo(p)| will be either |y_here| or |z_here|. If it is, say, |y_here|,
+the procedure generates a |y0| command (or a |w0| command), and marks
+all |vinfo| fields between |q| and |p| so that |y| is not OK in that range.
+
+@<Generate a |y0| or |z0| command...@>=
+vinfo(q):=vinfo(p);
+if vinfo(q)=y_here then
+ begin dvi_out(o+y0-down1); {|y0| or |w0|}
+ while vlink(q)<>p do
+ begin q:=vlink(q);
+ case vinfo(q) of
+ yz_OK: vinfo(q):=z_OK;
+ y_OK: vinfo(q):=d_fixed;
+ othercases do_nothing
+ endcases;
+ end;
+ end
+else begin dvi_out(o+z0-down1); {|z0| or |x0|}
+ while vlink(q)<>p do
+ begin q:=vlink(q);
+ case vinfo(q) of
+ yz_OK: vinfo(q):=y_OK;
+ z_OK: vinfo(q):=d_fixed;
+ othercases do_nothing
+ endcases;
+ end;
+ end
+
+@ @<Generate a |down| or |right|...@>=
+if abs(w)>=@'40000000 then
+ begin dvi_out(o+3); {|down4| or |right4|}
+ dvi_four(w); return;
+ end;
+if abs(w)>=@'100000 then
+ begin dvi_out(o+2); {|down3| or |right3|}
+ if w<0 then w:=w+@'100000000;
+ dvi_out(w div @'200000); w:=w mod @'200000; goto 2;
+ end;
+if abs(w)>=@'200 then
+ begin dvi_out(o+1); {|down2| or |right2|}
+ if w<0 then w:=w+@'200000;
+ goto 2;
+ end;
+dvi_out(o); {|down1| or |right1|}
+if w<0 then w:=w+@'400;
+goto 1;
+2: dvi_out(w div @'400);
+1: dvi_out(w mod @'400); return
+
+@ As we search through the stack, we are in one of three states,
+|y_seen|, |z_seen|, or |none_seen|, depending on whether we have
+encountered |y_here| or |z_here| nodes. These states are encoded as
+multiples of 6, so that they can be added to the |info| fields for quick
+decision-making.
+@^inner loop@>
+
+@d none_seen=0 {no |y_here| or |z_here| nodes have been encountered yet}
+@d y_seen=6 {we have seen |y_here| but not |z_here|}
+@d z_seen=12 {we have seen |z_here| but not |y_here|}
+
+@<Look at the other stack entries until deciding...@>=
+p:=vlink(q); mstate:=none_seen;
+while p<>null do
+ begin if width(p)=w then @<Consider a node with matching width;
+ |goto found| if it's a hit@>
+ else case mstate+vinfo(p) of
+ none_seen+y_here: mstate:=y_seen;
+ none_seen+z_here: mstate:=z_seen;
+ y_seen+z_here,z_seen+y_here: goto not_found;
+ othercases do_nothing
+ endcases;
+ p:=vlink(p);
+ end;
+not_found:
+
+@ We might find a valid hit in a |y| or |z| byte that is already gone
+from the buffer. But we can't change bytes that are gone forever; ``the
+moving finger writes, $\ldots\,\,$.''
+
+@<Consider a node with matching width...@>=
+case mstate+vinfo(p) of
+none_seen+yz_OK,none_seen+y_OK,z_seen+yz_OK,z_seen+y_OK:@t@>@;@/
+ if location(p)<dvi_gone then goto not_found
+ else @<Change buffered instruction to |y| or |w| and |goto found|@>;
+none_seen+z_OK,y_seen+yz_OK,y_seen+z_OK:@t@>@;@/
+ if location(p)<dvi_gone then goto not_found
+ else @<Change buffered instruction to |z| or |x| and |goto found|@>;
+none_seen+y_here,none_seen+z_here,y_seen+z_here,z_seen+y_here: goto found;
+othercases do_nothing
+endcases
+
+@ @<Change buffered instruction to |y| or |w| and |goto found|@>=
+begin k:=location(p)-dvi_offset;
+if k<0 then k:=k+dvi_buf_size;
+dvi_buf[k]:=dvi_buf[k]+y1-down1;
+vinfo(p):=y_here; goto found;
+end
+
+@ @<Change buffered instruction to |z| or |x| and |goto found|@>=
+begin k:=location(p)-dvi_offset;
+if k<0 then k:=k+dvi_buf_size;
+dvi_buf[k]:=dvi_buf[k]+z1-down1;
+vinfo(p):=z_here; goto found;
+end
+
+@ In case you are wondering when all the movement nodes are removed from
+\TeX's memory, the answer is that they are recycled just before
+|hlist_out| and |vlist_out| finish outputting a box. This restores the
+down and right stacks to the state they were in before the box was output,
+except that some |vinfo|'s may have become more restrictive.
+
+@p procedure prune_movements(@!l:integer);
+ {delete movement nodes with |location>=l|}
+label done,exit;
+var p:pointer; {node being deleted}
+begin while down_ptr<>null do
+ begin if location(down_ptr)<l then goto done;
+ p:=down_ptr; down_ptr:=vlink(p); flush_node(p);
+ end;
+done: while right_ptr<>null do
+ begin if location(right_ptr)<l then return;
+ p:=right_ptr; right_ptr:=vlink(p); flush_node(p);
+ end;
+exit:end;
+
+@ The actual distances by which we want to move might be computed as the
+sum of several separate movements. For example, there might be several
+glue nodes in succession, or we might want to move right by the width of
+some box plus some amount of glue. More importantly, the baselineskip
+distances are computed in terms of glue together with the depth and
+height of adjacent boxes, and we want the \.{DVI} file to lump these
+three quantities together into a single motion.
+
+Therefore, \TeX\ maintains two pairs of global variables: |dvi_h| and |dvi_v|
+are the |h| and |v| coordinates corresponding to the commands actually
+output to the \.{DVI} file, while |cur_h| and |cur_v| are the coordinates
+corresponding to the current state of the output routines. Coordinate
+changes will accumulate in |cur_h| and |cur_v| without being reflected
+in the output, until such a change becomes necessary or desirable; we
+can call the |movement| procedure whenever we want to make |dvi_h=cur_h|
+or |dvi_v=cur_v|.
+
+The current font reflected in the \.{DVI} output is called |dvi_f|;
+there is no need for a `\\{cur\_f}' variable.
+
+The depth of nesting of |hlist_out| and |vlist_out| is called |cur_s|;
+this is essentially the depth of |push| commands in the \.{DVI} output.
+
+@d synch_h==if cur_h<>dvi_h then
+ begin movement(cur_h-dvi_h,right1); dvi_h:=cur_h;
+ end
+@d synch_v==if cur_v<>dvi_v then
+ begin movement(cur_v-dvi_v,down1); dvi_v:=cur_v;
+ end
+
+@<Glob...@>=
+@!dvi_h,@!dvi_v:scaled; {a \.{DVI} reader program thinks we are here}
+@!cur_h,@!cur_v:scaled; {\TeX\ thinks we are here}
+@!dvi_f:internal_font_number; {the current font}
+@!cur_s:integer; {current depth of output box nesting, initially $-1$}
+
+@ @<Calculate DVI page dimensions and margins@>=
+if page_width > 0 then
+ cur_page_width := page_width
+else
+ cur_page_width := width(p) + 2*(h_offset + one_inch);
+if page_height > 0 then
+ cur_page_height := page_height
+else
+ cur_page_height := height(p) + depth(p) + 2*(v_offset + one_inch);
+if page_bottom_offset <> 0 then
+ cur_bottom_offset := page_bottom_offset
+else
+ cur_bottom_offset := 2*one_inch;
+if page_right_offset <> 0 then
+ cur_right_offset := page_right_offset
+else
+ cur_right_offset := 2*one_inch
+
+
+@ @<Initialize variables as |ship_out| begins@>=
+dvi_h:=0; dvi_v:=0; cur_h:=0; cur_v:=0; dvi_f:=null_font;
+@<Calculate DVI page dimensions and margins@>;
+ensure_dvi_open;
+if total_pages=0 then
+ begin dvi_out(pre); dvi_out(id_byte); {output the preamble}
+@^preamble of \.{DVI} file@>
+ dvi_four(25400000); dvi_four(473628672); {conversion ratio for sp}
+ prepare_mag; dvi_four(mag); {magnification factor is frozen}
+ old_setting:=selector; selector:=new_string;
+ print(" LuaTeX output "); print_int(year); print_char(".");
+ print_two(month); print_char("."); print_two(day);
+ print_char(":"); print_two(time div 60);
+ print_two(time mod 60);
+ selector:=old_setting; dvi_out(cur_length);
+ for s:=str_start_macro(str_ptr) to pool_ptr-1 do dvi_out(so(str_pool[s]));
+ pool_ptr:=str_start_macro(str_ptr); {flush the current string}
+ end
+
+@ When |hlist_out| is called, its duty is to output the box represented
+by the |hlist_node| pointed to by |temp_ptr|. The reference point of that
+box has coordinates |(cur_h,cur_v)|.
+
+Similarly, when |vlist_out| is called, its duty is to output the box represented
+by the |vlist_node| pointed to by |temp_ptr|. The reference point of that
+box has coordinates |(cur_h,cur_v)|.
+@^recursion@>
+
+@p procedure@?vlist_out; forward; {|hlist_out| and |vlist_out| are mutually
+ recursive}
+
+@ The recursive procedures |hlist_out| and |vlist_out| each have local variables
+|save_h| and |save_v| to hold the values of |dvi_h| and |dvi_v| just before
+entering a new level of recursion. In effect, the values of |save_h| and
+|save_v| on \TeX's run-time stack correspond to the values of |h| and |v|
+that a \.{DVI}-reading program will push onto its coordinate stack.
+
+@d move_past=13 {go to this label when advancing past glue or a rule}
+@d fin_rule=14 {go to this label to finish processing a rule}
+@d next_p=15 {go to this label when finished with node |p|}
+
+@p @t\4@>@<Declare procedures needed in |hlist_out|, |vlist_out|@>@t@>@/
+procedure hlist_out; {output an |hlist_node| box}
+label move_past, fin_rule, next_p;
+var base_line: scaled; {the baseline coordinate for this box}
+c_wd,c_ht,c_dp: scaled;
+ {the real width, height and depth of the character}
+edge_v: scaled;
+edge_h: scaled;
+effective_horizontal: scaled;
+basepoint_horizontal: scaled;
+basepoint_vertical: scaled;
+saving_h: scaled;
+saving_v: scaled;
+save_direction: integer;
+dir_ptr,dir_tmp:pointer;
+dvi_dir_h,dvi_dir_ptr,dvi_temp_ptr:integer;
+@!left_edge: scaled; {the left coordinate for this box}
+@!save_h,@!save_v: scaled; {what |dvi_h| and |dvi_v| should pop to}
+@!this_box: pointer; {pointer to containing box}
+@!g_order: glue_ord; {applicable order of infinity for glue}
+@!g_sign: normal..shrinking; {selects type of glue}
+@!p,q:pointer; {current position in the hlist}
+@!save_loc:integer; {\.{DVI} byte location upon entry}
+@!leader_box:pointer; {the leader box being replicated}
+@!leader_wd:scaled; {width of leader box being replicated}
+@!lx:scaled; {extra space between leader boxes}
+@!outer_doing_leaders:boolean; {were we doing leaders?}
+@!edge:scaled; {right edge of sub-box or leader space}
+@!glue_temp:real; {glue value before rounding}
+@!cur_glue:real; {glue seen so far}
+@!cur_g:scaled; {rounded equivalent of |cur_glue| times the glue ratio}
+begin cur_g:=0; cur_glue:=float_constant(0);
+this_box:=temp_ptr; g_order:=glue_order(this_box);
+g_sign:=glue_sign(this_box); p:=list_ptr(this_box);
+save_direction:=dvi_direction;
+dvi_direction:=box_dir(this_box);
+@<DIR: Initialize |dir_ptr| for |ship_out|@>;
+saving_h:=dvi_h; saving_v:=dvi_v;
+incr(cur_s);
+if cur_s>0 then dvi_out(push);
+if cur_s>max_push then max_push:=cur_s;
+save_loc:=dvi_offset+dvi_ptr; base_line:=cur_v; left_edge:=cur_h;
+while p<>null do @<Output node |p| for |hlist_out| and move to the next node,
+ maintaining the condition |cur_v=base_line|@>;
+cur_h:=saving_h; cur_v:=saving_v;
+synch_h; synch_v;
+prune_movements(save_loc);
+if cur_s>0 then dvi_pop(save_loc);
+decr(cur_s);
+dvi_direction:=save_direction;
+@<DIR: Reset |dir_ptr|@>;
+end;
+
+@ This is a cacheing attempt
+
+@d charinfo_width(#)==#.ci_wd
+@d charinfo_height(#)==#.ci_ht
+@d charinfo_depth(#)==#.ci_dp
+
+@<Types...@>=
+charinfo_short = packed record@;@/
+ @!ci_wd:scaled;
+ @!ci_ht:scaled;
+ @!ci_dp:scaled;
+ end;
+
+@ @<Glob...@>=
+ci:charinfo_short;
+
+@ We ought to give special care to the efficiency of one part of |hlist_out|,
+since it belongs to \TeX's inner loop. When a |char_node| is encountered,
+we save a little time by processing several nodes in succession until
+reaching a non-|char_node|. The program uses the fact that |set_char_0=0|.
+@^inner loop@>
+
+@<Output node |p| for |hlist_out|...@>=
+if is_char_node(p) then
+ begin synch_h; synch_v;
+ repeat f:=font(p); c:=character(p);
+ ci := char_info_short(f,c);
+ if f<>dvi_f then @<Change font |dvi_f| to |f|@>;
+ if is_rotated(dvi_direction) then begin
+ c_ht:=charinfo_width(ci) div 2;
+ c_wd:=charinfo_height(ci)+charinfo_depth(ci);
+ c_dp:=0;
+ end
+ else begin
+ c_ht:=charinfo_height(ci);
+ c_dp:=charinfo_depth(ci);
+ c_wd:=charinfo_width(ci);
+ end;
+ cur_h:=cur_h+c_wd;
+ if (font_natural_dir(f)<>-1) then begin
+ case font_direction(dvi_direction) of
+ dir__LT,dir__LB: begin
+ dvi_set(c);
+ end;
+ dir__RT,dir__RB: begin
+ dvi_put(c);
+ dvi_left(c_wd);
+ end;
+ dir__TL,dir__TR: begin
+ dvi_put(c);
+ dvi_down(c_wd);
+ end;
+ dir__BL,dir__BR: begin
+ dvi_put(c);
+ dvi_up(c_wd);
+ end;
+ dir__LL,dir__LR: begin
+ dvi_put(c);
+ dvi_right(c_wd);
+ end;
+ dir__RL,dir__RR: begin
+ dvi_put(c);
+ dvi_left(c_wd);
+ end;
+ dir__TT,dir__TB: begin
+ dvi_put(c);
+ dvi_down(c_wd);
+ end;
+ dir__BT,dir__BB: begin
+ dvi_put(c);
+ dvi_up(c_wd);
+ end;
+ end;
+ end else begin
+ case font_direction(dvi_direction) of
+ dir__LT: begin
+ dvi_set(c);
+ end;
+ dir__LB: begin
+ dvi_down(c_ht);
+ dvi_set(c);
+ dvi_up(c_ht);
+ end;
+ dir__RT: begin
+ dvi_left(c_wd);
+ dvi_put(c);
+ end;
+ dir__RB: begin
+ dvi_left(c_wd);
+ dvi_down(c_ht);
+ dvi_put(c);
+ dvi_up(c_ht);
+ end;
+ dir__TL: begin
+ dvi_down(c_wd);
+ dvi_left(c_ht);
+ dvi_put(c);
+ dvi_right(c_ht);
+ end;
+ dir__TR: begin
+ dvi_down(c_wd);
+ dvi_left(c_dp);
+ dvi_put(c);
+ dvi_right(c_dp);
+ end;
+ dir__BL: begin
+ dvi_left(c_ht);
+ dvi_put(c);
+ dvi_right(c_ht);
+ dvi_up(c_wd);
+ end;
+ dir__BR: begin
+ dvi_left(c_dp);
+ dvi_put(c);
+ dvi_right(c_dp);
+ dvi_up(c_wd);
+ end;
+ dir__LL,dir__LR: begin
+ dvi_down(c_ht);
+ dvi_put(c);
+ dvi_up(c_ht);
+ dvi_right(c_wd);
+ end;
+ dir__RL,dir__RR: begin
+ dvi_left(c_wd);
+ dvi_down(c_ht);
+ dvi_put(c);
+ dvi_up(c_ht);
+ end;
+ dir__TT,dir__TB: begin
+ dvi_down(c_wd);
+ dvi_left(c_ht);
+ dvi_put(c);
+ dvi_right(c_ht);
+ end;
+ dir__BT,dir__BB: begin
+ dvi_left(c_ht);
+ dvi_put(c);
+ dvi_right(c_ht);
+ dvi_up(c_wd);
+ end;
+ end;
+ end;
+ p:=vlink(p);
+ until not is_char_node(p);
+ dvi_h:=cur_h;
+ end
+else @<Output the non-|char_node| |p| for |hlist_out|
+ and move to the next node@>
+
+@ @<Change font |dvi_f| to |f|@>=
+begin if not font_used(f) then
+ begin dvi_font_def(f); set_font_used(f,true);
+ end;
+oval:=f-font_base-1; ocmd:=fnt1; out_cmd;@/
+dvi_f:=f;
+end
+
+@ @<Output the non-|char_node| |p| for |hlist_out|...@>=
+begin case type(p) of
+hlist_node,vlist_node:@<Output a box in an hlist@>;
+rule_node: begin
+ if not (dir_orthogonal(dir_primary[rule_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ rule_ht:=height(p); rule_dp:=depth(p); rule_wd:=width(p);
+ end
+ else begin
+ rule_ht:=width(p) div 2;
+ rule_dp:=width(p) div 2;
+ rule_wd:=height(p)+depth(p);
+ end;
+ goto fin_rule;
+ end;
+whatsit_node: @<Output the whatsit node |p| in an hlist@>;
+glue_node: @<Move right or output leaders@>;
+disc_node: if vlink(no_break(p))<>null then begin
+ vlink(tlink(no_break(p))):=vlink(p);
+ q:=vlink(no_break(p));
+ vlink(no_break(p)):=null;
+ vlink(p):=q;
+ end;
+margin_kern_node,kern_node:cur_h:=cur_h+width(p);
+math_node:cur_h:=cur_h+surround(p);
+othercases do_nothing
+endcases;@/
+goto next_p;
+fin_rule: @<Output a rule in an hlist@>;
+move_past: cur_h:=cur_h+rule_wd;
+next_p:p:=vlink(p);
+end
+
+@ @<Output a box in an hlist@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ effective_horizontal:=width(p);
+ basepoint_vertical:=0;
+ if dir_opposite(dir_secondary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=width(p)
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ effective_horizontal:=height(p)+depth(p);
+ if not (is_mirrored(box_dir(p))) then
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(p)
+ else
+ basepoint_horizontal:=depth(p)
+ else
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(p)
+ else
+ basepoint_horizontal:=height(p);
+ if dir_eq(dir_secondary[box_dir(p)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:= -(width(p) div 2)
+ else
+ basepoint_vertical:= (width(p) div 2);
+ end;
+if not (is_mirrored(dvi_direction)) then
+ basepoint_vertical := basepoint_vertical + shift_amount(p)
+ {shift the box `down'}
+else
+ basepoint_vertical := basepoint_vertical - shift_amount(p);
+ {shift the box `up'}
+if list_ptr(p)=null then cur_h:=cur_h + effective_horizontal
+else begin
+ temp_ptr:=p; edge:=cur_h; cur_h:=cur_h + basepoint_horizontal;
+ edge_v:=cur_v; cur_v:=base_line + basepoint_vertical;
+ synch_h; synch_v; save_h:=dvi_h; save_v:=dvi_v;
+ if type(p)=vlist_node then vlist_out@+else hlist_out;
+ dvi_h:=save_h; dvi_v:=save_v;
+ cur_h:=edge+effective_horizontal; cur_v:=base_line;
+ end
+end
+
+@ @<Output a rule in an hlist@>=
+if is_running(rule_ht) then rule_ht:=height(this_box);
+if is_running(rule_dp) then rule_dp:=depth(this_box);
+rule_ht:=rule_ht+rule_dp; {this is the rule thickness}
+if (rule_ht>0)and(rule_wd>0) then {we don't output empty rules}
+ begin synch_h; cur_v:=base_line+rule_dp; synch_v;
+ case font_direction(dvi_direction) of
+ dir__LT: begin
+ dvi_set_rule(rule_ht)(rule_wd);
+ end;
+ dir__LB: begin
+ dvi_down(rule_ht);
+ dvi_set_rule(rule_ht)(rule_wd);
+ dvi_up(rule_ht);
+ end;
+ dir__RT: begin
+ dvi_left(rule_wd);
+ dvi_put_rule(rule_ht)(rule_wd);
+ end;
+ dir__RB: begin
+ dvi_left(rule_wd);
+ dvi_down(rule_ht);
+ dvi_put_rule(rule_ht)(rule_wd);
+ dvi_up(rule_ht);
+ end;
+ dir__TL: begin
+ dvi_down(rule_wd);
+ dvi_left(rule_ht);
+ dvi_set_rule(rule_wd)(rule_ht);
+ end;
+ dir__TR: begin
+ dvi_down(rule_wd);
+ dvi_put_rule(rule_wd)(rule_ht);
+ end;
+ dir__BL: begin
+ dvi_left(rule_ht);
+ dvi_set_rule(rule_wd)(rule_ht);
+ dvi_up(rule_wd);
+ end;
+ dir__BR: begin
+ dvi_put_rule(rule_wd)(rule_ht);
+ dvi_up(rule_wd);
+ end;
+ end;
+ cur_v:=base_line; dvi_h:=dvi_h+rule_wd;
+ end
+
+@ @d billion==float_constant(1000000000)
+@d vet_glue(#)== glue_temp:=#;
+ if glue_temp>billion then
+ glue_temp:=billion
+ else if glue_temp<-billion then
+ glue_temp:=-billion
+
+@<Move right or output leaders@>=
+begin g:=glue_ptr(p); rule_wd:=width(g)-cur_g;
+if g_sign<>normal then
+ begin if g_sign=stretching then
+ begin if stretch_order(g)=g_order then
+ begin cur_glue:=cur_glue+stretch(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+@^real multiplication@>
+ cur_g:=round(glue_temp);
+ end;
+ end
+ else if shrink_order(g)=g_order then
+ begin cur_glue:=cur_glue-shrink(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+ cur_g:=round(glue_temp);
+ end;
+ end;
+rule_wd:=rule_wd+cur_g;
+
+if subtype(p)>=a_leaders then
+ @<Output leaders in an hlist, |goto fin_rule| if a rule
+ or to |next_p| if done@>;
+goto move_past;
+end
+
+@ @<Output leaders in an hlist...@>=
+begin leader_box:=leader_ptr(p);
+if type(leader_box)=rule_node then
+ begin rule_ht:=height(leader_box); rule_dp:=depth(leader_box);
+ goto fin_rule;
+ end;
+if not (dir_orthogonal(dir_primary[box_dir(leader_box)])(dir_primary[dvi_direction]))
+ then leader_wd:=width(leader_box)
+else
+ leader_wd:=height(leader_box)+depth(leader_box);
+if (leader_wd>0)and(rule_wd>0) then
+ begin rule_wd:=rule_wd+10; {compensate for floating-point rounding}
+ edge:=cur_h+rule_wd; lx:=0;
+ @<Let |cur_h| be the position of the first box, and set |leader_wd+lx|
+ to the spacing between corresponding parts of boxes@>;
+ while cur_h+leader_wd<=edge do
+ @<Output a leader box at |cur_h|,
+ then advance |cur_h| by |leader_wd+lx|@>;
+ cur_h:=edge-10; goto next_p;
+ end;
+end
+
+@ The calculations related to leaders require a bit of care. First, in the
+case of |a_leaders| (aligned leaders), we want to move |cur_h| to
+|left_edge| plus the smallest multiple of |leader_wd| for which the result
+is not less than the current value of |cur_h|; i.e., |cur_h| should become
+$|left_edge|+|leader_wd|\times\lceil
+(|cur_h|-|left_edge|)/|leader_wd|\rceil$. The program here should work in
+all cases even though some implementations of \PASCAL\ give nonstandard
+results for the |div| operation when |cur_h| is less than |left_edge|.
+
+In the case of |c_leaders| (centered leaders), we want to increase |cur_h|
+by half of the excess space not occupied by the leaders; and in the
+case of |x_leaders| (expanded leaders) we increase |cur_h|
+by $1/(q+1)$ of this excess space, where $q$ is the number of times the
+leader box will be replicated. Slight inaccuracies in the division might
+accumulate; half of this rounding error is placed at each end of the leaders.
+
+@<Let |cur_h| be the position of the first box, ...@>=
+if subtype(p)=a_leaders then
+ begin save_h:=cur_h;
+ cur_h:=left_edge+leader_wd*((cur_h-left_edge)@!div leader_wd);
+ if cur_h<save_h then cur_h:=cur_h+leader_wd;
+ end
+else begin lq:=rule_wd div leader_wd; {the number of box copies}
+ lr:=rule_wd mod leader_wd; {the remaining space}
+ if subtype(p)=c_leaders then cur_h:=cur_h+(lr div 2)
+ else begin lx:=lr div (lq+1);
+ cur_h:=cur_h+((lr-(lq-1)*lx) div 2);
+ end;
+ end
+
+@ The `\\{synch}' operations here are intended to decrease the number of
+bytes needed to specify horizontal and vertical motion in the \.{DVI} output.
+
+@<Output a leader box at |cur_h|, ...@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(leader_box)])(dir_primary[dvi_direction]))
+ then begin
+ basepoint_vertical:=0;
+ if dir_opposite(dir_secondary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=width(leader_box)
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ if not (is_mirrored(box_dir(leader_box))) then
+ if dir_eq(dir_primary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(leader_box)
+ else
+ basepoint_horizontal:=depth(leader_box)
+ else
+ if dir_eq(dir_primary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(leader_box)
+ else
+ basepoint_horizontal:=height(leader_box);
+ if dir_eq(dir_secondary[box_dir(leader_box)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:= -(width(leader_box) div 2)
+ else
+ basepoint_vertical:= (width(leader_box) div 2);
+ end;
+if not (is_mirrored(dvi_direction)) then
+ basepoint_vertical := basepoint_vertical + shift_amount(leader_box)
+ {shift the box `down'}
+else
+ basepoint_vertical := basepoint_vertical - shift_amount(leader_box);
+ {shift the box `up'}
+temp_ptr:=leader_box;
+edge_h:=cur_h; cur_h:=cur_h + basepoint_horizontal;
+edge_v:=cur_v; cur_v:=base_line + basepoint_vertical;
+synch_h; synch_v; save_h:=dvi_h; save_v:=dvi_v;
+outer_doing_leaders:=doing_leaders; doing_leaders:=true;
+if type(leader_box)=vlist_node then vlist_out@+else hlist_out;
+doing_leaders:=outer_doing_leaders;
+dvi_h:=save_h; dvi_v:=save_v;
+cur_h:=edge_h+leader_wd+lx; cur_v:=base_line;
+end
+
+@ The |vlist_out| routine is similar to |hlist_out|, but a bit simpler.
+
+@p procedure vlist_out; {output a |vlist_node| box}
+label move_past, fin_rule, next_p;
+var left_edge: scaled; {the left coordinate for this box}
+@!top_edge: scaled; {the top coordinate for this box}
+@!save_h,@!save_v: scaled; {what |dvi_h| and |dvi_v| should pop to}
+@!this_box: pointer; {pointer to containing box}
+@!g_order: glue_ord; {applicable order of infinity for glue}
+@!g_sign: normal..shrinking; {selects type of glue}
+@!p:pointer; {current position in the vlist}
+@!save_loc:integer; {\.{DVI} byte location upon entry}
+@!leader_box:pointer; {the leader box being replicated}
+@!leader_ht:scaled; {height of leader box being replicated}
+@!lx:scaled; {extra space between leader boxes}
+@!outer_doing_leaders:boolean; {were we doing leaders?}
+@!edge:scaled; {bottom boundary of leader space}
+@!glue_temp:real; {glue value before rounding}
+@!cur_glue:real; {glue seen so far}
+@!cur_g:scaled; {rounded equivalent of |cur_glue| times the glue ratio}
+@!save_direction: integer;
+@!effective_vertical: scaled;
+@!basepoint_horizontal: scaled;
+@!basepoint_vertical: scaled;
+@!edge_v: scaled;
+@!saving_v: scaled;
+@!saving_h: scaled;
+begin cur_g:=0; cur_glue:=float_constant(0);
+this_box:=temp_ptr; g_order:=glue_order(this_box);
+g_sign:=glue_sign(this_box); p:=list_ptr(this_box);
+{pdfassert(p<>0);}
+saving_v:=dvi_v; saving_h:=dvi_h;
+save_direction:=dvi_direction;
+dvi_direction:=box_dir(this_box);
+incr(cur_s);
+if cur_s>0 then dvi_out(push);
+if cur_s>max_push then max_push:=cur_s;
+save_loc:=dvi_offset+dvi_ptr; left_edge:=cur_h; cur_v:=cur_v-height(this_box);
+top_edge:=cur_v;
+while p<>null do @<Output node |p| for |vlist_out| and move to the next node,
+ maintaining the condition |cur_h=left_edge|@>;
+cur_v:=saving_v; cur_h:=saving_h;
+synch_v; synch_h;
+prune_movements(save_loc);
+if cur_s>0 then dvi_pop(save_loc);
+decr(cur_s);
+dvi_direction:=save_direction;
+end;
+
+@ @<Output node |p| for |vlist_out|...@>=
+begin if is_char_node(p) then begin print_font_and_char(p); confusion("vlistout"); end
+@:this can't happen vlistout}{\quad vlistout@>
+else @<Output the non-|char_node| |p| for |vlist_out|@>;
+next_p:p:=vlink(p);
+end
+
+@ @<Output the non-|char_node| |p| for |vlist_out|@>=
+begin case type(p) of
+hlist_node,vlist_node:@<Output a box in a vlist@>;
+rule_node: begin
+ if not (dir_orthogonal(dir_primary[rule_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ rule_ht:=height(p); rule_dp:=depth(p); rule_wd:=width(p);
+ end
+ else begin
+ rule_ht:=width(p) div 2;
+ rule_dp:=width(p) div 2;
+ rule_wd:=height(p)+depth(p);
+ end;
+ goto fin_rule;
+ end;
+whatsit_node: @<Output the whatsit node |p| in a vlist@>;
+glue_node: @<Move down or output leaders@>;
+kern_node:cur_v:=cur_v+width(p);
+othercases do_nothing
+endcases;@/
+goto next_p;
+fin_rule: @<Output a rule in a vlist, |goto next_p|@>;
+move_past: cur_v:=cur_v+rule_ht;
+end
+
+@ The |synch_v| here allows the \.{DVI} output to use one-byte commands
+for adjusting |v| in most cases, since the baselineskip distance will
+usually be constant.
+
+@<Output a box in a vlist@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ effective_vertical:=height(p)+depth(p);
+ if (type(p)=hlist_node) and (is_mirrored(box_dir(p))) then
+ basepoint_vertical:=depth(p)
+ else
+ basepoint_vertical:=height(p);
+ if dir_opposite(dir_secondary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=width(p)
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ effective_vertical:=width(p);
+ if not (is_mirrored(box_dir(p))) then
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(p)
+ else
+ basepoint_horizontal:=depth(p)
+ else
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(p)
+ else
+ basepoint_horizontal:=height(p);
+ if dir_eq(dir_secondary[box_dir(p)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:=0
+ else
+ basepoint_vertical:=width(p);
+ end;
+basepoint_horizontal := basepoint_horizontal + shift_amount(p);
+ {shift the box `right'}
+if list_ptr(p)=null then begin
+ cur_v:=cur_v+effective_vertical;
+ end
+else begin
+ synch_h; synch_v; edge_v:=cur_v;
+ cur_h:=left_edge + basepoint_horizontal;
+ cur_v:=cur_v + basepoint_vertical;
+ synch_h; synch_v; save_h:=dvi_h; save_v:=dvi_v;
+ temp_ptr:=p;
+ if type(p)=vlist_node then vlist_out@+else hlist_out;
+ dvi_h:=save_h; dvi_v:=save_v;
+ cur_h:=left_edge; cur_v:=edge_v + effective_vertical;
+ end
+end
+
+@ @<Output a rule in a vlist...@>=
+if is_running(rule_wd) then rule_wd:=width(this_box);
+rule_ht:=rule_ht+rule_dp; {this is the rule thickness}
+cur_v:=cur_v+rule_ht;
+if (rule_ht>0)and(rule_wd>0) then {we don't output empty rules}
+ begin synch_h; synch_v;
+ case font_direction(dvi_direction) of
+ dir__LT: begin
+ dvi_put_rule(rule_ht)(rule_wd);
+ end;
+ dir__LB: begin
+ dvi_down(rule_ht);
+ dvi_put_rule(rule_ht)(rule_wd);
+ dvi_up(rule_ht);
+ end;
+ dir__RT: begin
+ dvi_left(rule_wd);
+ dvi_set_rule(rule_ht)(rule_wd);
+ end;
+ dir__RB: begin
+ dvi_down(rule_ht);
+ dvi_left(rule_wd);
+ dvi_set_rule(rule_ht)(rule_wd);
+ dvi_up(rule_ht);
+ end;
+ dir__TL: begin
+ dvi_down(rule_wd);
+ dvi_left(rule_ht);
+ dvi_set_rule(rule_wd)(rule_ht);
+ dvi_up(rule_wd);
+ end;
+ dir__TR: begin
+ dvi_down(rule_wd);
+ dvi_put_rule(rule_wd)(rule_ht);
+ dvi_up(rule_wd);
+ end;
+ dir__BL: begin
+ dvi_left(rule_ht);
+ dvi_set_rule(rule_wd)(rule_ht);
+ end;
+ dir__BR: begin
+ dvi_put_rule(rule_wd)(rule_ht);
+ end;
+ end;
+ end;
+goto next_p
+
+@ @<Move down or output leaders@>=
+begin g:=glue_ptr(p); rule_ht:=width(g)-cur_g;
+if g_sign<>normal then
+ begin if g_sign=stretching then
+ begin if stretch_order(g)=g_order then
+ begin cur_glue:=cur_glue+stretch(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+@^real multiplication@>
+ cur_g:=round(glue_temp);
+ end;
+ end
+ else if shrink_order(g)=g_order then
+ begin cur_glue:=cur_glue-shrink(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+ cur_g:=round(glue_temp);
+ end;
+ end;
+rule_ht:=rule_ht+cur_g;
+if subtype(p)>=a_leaders then
+ @<Output leaders in a vlist, |goto fin_rule| if a rule
+ or to |next_p| if done@>;
+goto move_past;
+end
+
+@ @<Output leaders in a vlist...@>=
+begin leader_box:=leader_ptr(p);
+if type(leader_box)=rule_node then
+ begin rule_wd:=width(leader_box); rule_dp:=0;
+ goto fin_rule;
+ end;
+if not (dir_orthogonal(dir_primary[box_dir(leader_box)])(dir_primary[dvi_direction]))
+ then leader_ht:=height(leader_box)+depth(leader_box)
+else
+ leader_ht:=width(leader_box);
+if (leader_ht>0)and(rule_ht>0) then
+ begin rule_ht:=rule_ht+10; {compensate for floating-point rounding}
+ edge:=cur_v+rule_ht; lx:=0;
+ @<Let |cur_v| be the position of the first box, and set |leader_ht+lx|
+ to the spacing between corresponding parts of boxes@>;
+ while cur_v+leader_ht<=edge do
+ @<Output a leader box at |cur_v|,
+ then advance |cur_v| by |leader_ht+lx|@>;
+ cur_v:=edge-10; goto next_p;
+ end;
+end
+
+@ @<Let |cur_v| be the position of the first box, ...@>=
+if subtype(p)=a_leaders then
+ begin save_v:=cur_v;
+ cur_v:=top_edge+leader_ht*((cur_v-top_edge)@!div leader_ht);
+ if cur_v<save_v then cur_v:=cur_v+leader_ht;
+ end
+else begin lq:=rule_ht div leader_ht; {the number of box copies}
+ lr:=rule_ht mod leader_ht; {the remaining space}
+ if subtype(p)=c_leaders then cur_v:=cur_v+(lr div 2)
+ else begin lx:=lr div (lq+1);
+ cur_v:=cur_v+((lr-(lq-1)*lx) div 2);
+ end;
+ end
+
+@ When we reach this part of the program, |cur_v| indicates the top of a
+leader box, not its baseline.
+
+@<Output a leader box at |cur_v|, ...@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(leader_box)])(dir_primary[dvi_direction]))
+ then begin
+ effective_vertical:=height(leader_box)+depth(leader_box);
+ if (type(leader_box)=hlist_node) and (is_mirrored(box_dir(leader_box))) then
+ basepoint_vertical:=depth(leader_box)
+ else
+ basepoint_vertical:=height(leader_box);
+ if dir_opposite(dir_secondary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=width(leader_box)
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ effective_vertical:=width(leader_box);
+ if not (is_mirrored(box_dir(leader_box))) then
+ if dir_eq(dir_primary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(leader_box)
+ else
+ basepoint_horizontal:=depth(leader_box)
+ else
+ if dir_eq(dir_primary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(leader_box)
+ else
+ basepoint_horizontal:=height(leader_box);
+ if dir_eq(dir_secondary[box_dir(leader_box)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:= width(leader_box)
+ else
+ basepoint_vertical:= 0;
+ end;
+basepoint_horizontal := basepoint_horizontal + shift_amount(leader_box);
+ {shift the box `right'}
+temp_ptr:=leader_box;
+cur_h:=left_edge + basepoint_horizontal;
+edge_v:=cur_v ;
+cur_v:=cur_v + basepoint_vertical;
+synch_h; synch_v; save_h:=dvi_h; save_v:=dvi_v;
+outer_doing_leaders:=doing_leaders; doing_leaders:=true;
+if type(leader_box)=vlist_node then vlist_out@+else hlist_out;
+doing_leaders:=outer_doing_leaders;
+dvi_h:=save_h; dvi_v:=save_v;
+cur_h:=left_edge; cur_v:=edge_v+leader_ht+lx;
+end
+
+@ The |hlist_out| and |vlist_out| procedures are now complete, so we are
+ready for the |dvi_ship_out| routine that gets them started in the first place.
+
+@p procedure dvi_ship_out(@!p:pointer); {output the box |p|}
+label done;
+var page_loc:integer; {location of the current |bop|}
+@!j,@!k:0..9; {indices to first ten count registers}
+@!s:pool_pointer; {index into |str_pool|}
+@!old_setting:0..max_selector; {saved |selector| setting}
+pre_callback_id:integer;
+post_callback_id:integer;
+ret:boolean;
+begin
+pre_callback_id:=callback_defined(start_page_number_callback);
+post_callback_id:=callback_defined(stop_page_number_callback);
+if (tracing_output>0)and(pre_callback_id=0) then
+ begin print_nl(""); print_ln;
+ print("Completed box being shipped out");
+@.Completed box...@>
+ end;
+if pre_callback_id>0 then
+ ret:=run_callback(pre_callback_id,'->')
+else begin
+ if term_offset>max_print_line-9 then print_ln
+ else if (term_offset>0)or(file_offset>0) then print_char(" ");
+ print_char("["); j:=9;
+ while (count(j)=0)and(j>0) do decr(j);
+ for k:=0 to j do
+ begin print_int(count(k));
+ if k<j then print_char(".");
+ end;
+ end;
+update_terminal;
+if (tracing_output>0)and(post_callback_id=0) then
+ begin print_char("]");
+ begin_diagnostic; show_box(p); end_diagnostic(true);
+ end;
+@<Ship box |p| out@>;
+if (tracing_output<=0)and(post_callback_id=0) then
+ print_char("]");
+dead_cycles:=0;
+update_terminal; {progress report}
+@<Flush the box from memory, showing statistics if requested@>;
+if post_callback_id>0 then
+ ret:=run_callback(post_callback_id,'->');
+end;
+
+@ @<Flush the box from memory, showing statistics if requested@>=
+@!stat if (tracing_stats>1)and(pre_callback_id=0) then
+ begin print_nl("Memory usage before: ");
+@.Memory usage...@>
+ print_int(var_used); print_char("&");
+ print_int(dyn_used); print_char(";");
+ end;
+tats@/
+flush_node_list(p);
+@!stat if (tracing_stats>1)and(post_callback_id=0) then
+ begin print(" after: ");
+ print_int(var_used); print_char("&");
+ print_int(dyn_used); print_ln;
+ end;
+tats
+
+@ @<Ship box |p| out@>=
+@<Update the values of |max_h| and |max_v|; but if the page is too large,
+ |goto done|@>;
+@<Initialize variables as |ship_out| begins@>;
+page_loc:=dvi_offset+dvi_ptr;
+dvi_out(bop);
+for k:=0 to 9 do dvi_four(count(k));
+dvi_four(last_bop); last_bop:=page_loc;
+dvi_direction:=page_direction;
+case box_direction(dvi_direction) of
+dir_TL_,dir_LT_: begin
+ end;
+dir_TR_,dir_RT_: begin
+ dvi_right(cur_page_width-cur_right_offset);
+ dvi_h:=-cur_right_offset;
+ end;
+dir_RB_,dir_BR_: begin
+ dvi_right(cur_page_width-cur_right_offset);
+ dvi_down(cur_page_height-cur_bottom_offset);
+ dvi_h:=-cur_right_offset;
+ dvi_v:=-cur_bottom_offset;
+ end;
+dir_BL_,dir_LB_: begin
+ dvi_down(cur_page_height-cur_bottom_offset);
+ dvi_v:=-cur_bottom_offset;
+ end;
+end;
+cur_h:=h_offset;
+cur_v:=height(p)+v_offset;
+case box_direction(dvi_direction) of
+dir_TL_: begin
+ dvi_down(cur_v);
+ dvi_right(cur_h);
+ end;
+dir_TR_: begin
+ dvi_down(cur_v);
+ dvi_right(-cur_h);
+ end;
+dir_LT_: begin
+ dvi_right(cur_v);
+ dvi_down(cur_h);
+ end;
+dir_LB_: begin
+ dvi_right(cur_v);
+ dvi_down(-cur_h);
+ end;
+dir_BL_: begin
+ dvi_down(-cur_v);
+ dvi_right(cur_h);
+ end;
+dir_BR_: begin
+ dvi_down(-cur_v);
+ dvi_right(-cur_h);
+ end;
+dir_RT_: begin
+ dvi_right(-cur_v);
+ dvi_down(cur_h);
+ end;
+dir_RB_: begin
+ dvi_right(-cur_v);
+ dvi_down(-cur_h);
+ end;
+end;
+dvi_h:=cur_h;
+dvi_v:=cur_v;
+temp_ptr:=p;
+if type(p)=vlist_node then vlist_out@+else hlist_out;
+dvi_out(eop); incr(total_pages); cur_s:=-1;
+done:
+
+@ Sometimes the user will generate a huge page because other error messages
+are being ignored. Such pages are not output to the \.{dvi} file, since they
+may confuse the printing software.
+
+@<Update the values of |max_h| and |max_v|; but if the page is too large...@>=
+if (height(p)>max_dimen)or@|(depth(p)>max_dimen)or@|
+ (height(p)+depth(p)+v_offset>max_dimen)or@|
+ (width(p)+h_offset>max_dimen) then
+ begin print_err("Huge page cannot be shipped out");
+@.Huge page...@>
+ help2("The page just created is more than 18 feet tall or")@/
+ ("more than 18 feet wide, so I suspect something went wrong.");
+ error;
+ if tracing_output<=0 then
+ begin begin_diagnostic;
+ print_nl("The following box has been deleted:");
+@.The following...deleted@>
+ show_box(p);
+ end_diagnostic(true);
+ end;
+ goto done;
+ end;
+if height(p)+depth(p)+v_offset>max_v then max_v:=height(p)+depth(p)+v_offset;
+if width(p)+h_offset>max_h then max_h:=width(p)+h_offset
+
+@ At the end of the program, we must finish things off by writing the
+post\-amble. If |total_pages=0|, the \.{DVI} file was never opened.
+If |total_pages>=65536|, the \.{DVI} file will lie.
+
+An integer variable |k| will be declared for use by this routine.
+
+@<Finish the \.{DVI} file@>=
+while cur_s>-1 do
+ begin if cur_s>0 then dvi_out(pop)
+ else begin dvi_out(eop); incr(total_pages);
+ end;
+ decr(cur_s);
+ end;
+if total_pages=0 then begin
+ if callback_id=0 then
+ print_nl("No pages of output.")
+ else
+ res:=run_callback(callback_id,'->');
+ end
+@.No pages of output@>
+else begin dvi_out(post); {beginning of the postamble}
+ dvi_four(last_bop); last_bop:=dvi_offset+dvi_ptr-5; {|post| location}
+ dvi_four(25400000); dvi_four(473628672); {conversion ratio for sp}
+ prepare_mag; dvi_four(mag); {magnification factor}
+ dvi_four(max_v); dvi_four(max_h);@/
+ dvi_out(max_push div 256); dvi_out(max_push mod 256);@/
+ dvi_out((total_pages div 256) mod 256); dvi_out(total_pages mod 256);@/
+ @<Output the font definitions for all fonts that were used@>;
+ dvi_out(post_post); dvi_four(last_bop); dvi_out(id_byte);@/
+ k:=4+((dvi_buf_size-dvi_ptr) mod 4); {the number of 223's}
+ while k>0 do
+ begin dvi_out(223); decr(k);
+ end;
+ @<Empty the last bytes out of |dvi_buf|@>;
+ if callback_id=0 then begin
+ print_nl("Output written on "); slow_print(output_file_name);
+@.Output written on x@>
+ print(" ("); print_int(total_pages); print(" page");
+ if total_pages<>1 then print_char("s");
+ print(", "); print_int(dvi_offset+dvi_ptr); print(" bytes).");
+ end
+ else
+ res:=run_callback(callback_id,'->');
+ b_close(dvi_file);
+ end
+
+@ @<Output the font definitions...@>=
+k := max_font_id;
+while k>0 do
+ begin if font_used(k) then dvi_font_def(k);
+ decr(k);
+ end
+
+
+@* \[32a] \pdfTeX\ basic.
+
+Initialize \pdfTeX's parameters to some useful default value.
+Helpful in case one forgets to set them during initex run.
+
+@<Initialize table entries...@>=
+pdf_h_origin := one_inch;
+pdf_v_origin := one_inch;
+pdf_compress_level := 9;
+pdf_objcompresslevel := 0;
+pdf_decimal_digits := 3;
+pdf_image_resolution := 72;
+pdf_minor_version := 4;
+pdf_gamma := 1000;
+pdf_image_gamma := 2200;
+pdf_image_hicolor := 1;
+pdf_image_apply_gamma := 0;
+pdf_px_dimen := one_bp;
+pdf_draftmode := 0;
+
+@ The subroutines define the corresponding macros so we can use them
+in C.
+
+@d flushable(#) == (# = str_ptr - 1)
+
+@d is_valid_char(#) == char_exists(f,#)
+
+@p function get_pdf_compress_level: integer;
+begin
+ get_pdf_compress_level := pdf_compress_level;
+end;
+
+function get_nullfont: internal_font_number;
+begin
+ get_nullfont := null_font;
+end;
+
+function get_escape_char: integer;
+begin
+ get_escape_char := escape_char;
+end;
+
+function get_undefined_control_sequence: integer;
+begin
+ get_undefined_control_sequence := undefined_control_sequence;
+end;
+
+function get_fontbase: internal_font_number;
+begin
+ get_fontbase := font_base;
+end;
+
+function get_nullcs: pointer;
+begin
+ get_nullcs := null_cs;
+end;
+
+function get_nullptr: pointer;
+begin
+ get_nullptr := null;
+end;
+
+function get_tex_int(code: integer): integer;
+begin
+ get_tex_int := int_par(code);
+end;
+
+function get_tex_dimen(code: integer): scaled;
+begin
+ get_tex_dimen := dimen_par(code);
+end;
+
+function get_x_height(f: internal_font_number): scaled;
+begin
+ get_x_height := x_height(f);
+end;
+
+function get_charwidth(f: internal_font_number; c: integer): scaled;
+begin
+ if is_valid_char(c) then
+ get_charwidth := char_width(f,c)
+ else
+ get_charwidth := 0;
+end;
+
+function get_charheight(f: internal_font_number; c: integer): scaled;
+begin
+ if is_valid_char(c) then
+ get_charheight := char_height(f,c)
+ else
+ get_charheight := 0;
+end;
+
+function get_chardepth(f: internal_font_number; c: integer): scaled;
+begin
+ if is_valid_char(c) then
+ get_chardepth := char_depth(f,c)
+ else
+ get_chardepth := 0;
+end;
+
+function get_quad(f: internal_font_number): scaled;
+begin
+ get_quad := quad(f);
+end;
+
+function get_slant(f: internal_font_number): scaled;
+begin
+ get_slant := slant(f);
+end;
+
+function new_dummy_font: internal_font_number;
+begin
+ new_dummy_font := read_font_info(null_cs, "dummy", "", -1000, -1);
+end;
+
+function get_hash_size: integer;
+begin
+ get_hash_size:= hash_size;
+end;
+
+function get_eqtb_size: integer;
+begin
+ get_eqtb_size:= eqtb_size;
+end;
+
+function get_hash_base: integer;
+begin
+ get_hash_base:= hash_base;
+end;
+
+function get_active_base: integer;
+begin
+ get_active_base:= active_base;
+end;
+
+function get_cur_font: internal_font_number;
+begin
+ get_cur_font:= cur_font;
+end;
+
+procedure set_cur_font (f: internal_font_number);
+var a:small_number;
+begin
+ a:=0;
+ define(cur_font_loc,data,f);
+end;
+
+function get_current_name: str_number;
+begin
+ get_current_name:= name;
+end;
+
+
+@ Helper for debugging purposes
+
+@p procedure short_display_n(@!p, m:integer); {prints highlights of list |p|}
+var i: integer;
+begin
+i := 0;
+font_in_short_display:=null_font;
+if p = null then
+ return;
+while p<>null do
+ begin if is_char_node(p) then
+ begin if p<=max_halfword then
+ begin if font(p)<>font_in_short_display then
+ begin if not is_valid_font(font(p)) then
+ print_char("*")
+@.*\relax@>
+ else print_font_identifier(font(p));
+ print_char(" "); font_in_short_display:=font(p);
+ end;
+ print(qo(character(p)));
+ end;
+ end
+ else begin
+ if (type(p) = glue_node) or
+ (type(p) = disc_node) or
+ (type(p) = penalty_node) or
+ ((type(p) = kern_node) and (subtype(p) = explicit)) then
+ incr(i);
+ if i >= m then
+ return;
+ if (type(p) = disc_node) then begin
+ print("|");
+ short_display(vlink(pre_break(p)));
+ print("|");
+ short_display(vlink(post_break(p)));
+ print("|");
+ end
+ else
+ @<Print a short indication of the contents of node |p|@>;
+ end;
+ p:=vlink(p);
+ if p = null then
+ return;
+ end;
+ update_terminal;
+end;
+
+@ Sometimes it is neccesary to allocate memory for PDF output that cannot
+be deallocated then, so we use |pdf_mem| for this purpose.
+
+@<Constants...@>=
+@!inf_pdf_mem_size = 10000; {min size of the |pdf_mem| array}
+@!sup_pdf_mem_size = 10000000; {max size of the |pdf_mem| array}
+
+@ @<Glob...@>=
+@!pdf_mem_size: integer;
+@!pdf_mem: ^integer;
+@!pdf_mem_ptr: integer;
+
+@ @<Set init...@>=
+pdf_mem_ptr := 1; {the first word is not used so we can use zero as a value for testing
+whether a pointer to |pdf_mem| is valid}
+pdf_mem_size := inf_pdf_mem_size; {allocated size of |pdf_mem| array}
+
+@ We use |pdf_get_mem| to allocate memory in |pdf_mem|
+
+@p function pdf_get_mem(s: integer): integer; {allocate |s| words in |pdf_mem|}
+var a: integer;
+begin
+ if s > sup_pdf_mem_size - pdf_mem_ptr then
+ overflow("PDF memory size (pdf_mem_size)", pdf_mem_size);
+ if pdf_mem_ptr + s > pdf_mem_size then begin
+ a := 0.2 * pdf_mem_size;
+ if pdf_mem_ptr + s > pdf_mem_size + a then
+ pdf_mem_size := pdf_mem_ptr + s
+ else if pdf_mem_size < sup_pdf_mem_size - a then
+ pdf_mem_size := pdf_mem_size + a
+ else
+ pdf_mem_size := sup_pdf_mem_size;
+ pdf_mem := xreallocarray(pdf_mem, integer, pdf_mem_size);
+ end;
+ pdf_get_mem := pdf_mem_ptr;
+ pdf_mem_ptr := pdf_mem_ptr + s;
+end;
+
+@* \[32b] \pdfTeX\ output low-level subroutines.
+We use the similiar subroutines to handle the output buffer for
+PDF output. When compress is used, the state of writing to buffer
+is held in |zip_write_state|. We must write the header of PDF
+output file in initialization to ensure that it will be the first
+written bytes.
+
+@<Constants...@>=
+@!pdf_op_buf_size = 16384; {size of the PDF output buffer}
+@!inf_pdf_os_buf_size = 1; {initial value of |pdf_os_buf_size|}
+@!sup_pdf_os_buf_size = 5000000; {arbitrary upper hard limit of |pdf_os_buf_size|}
+@!pdf_os_max_objs = 100; {maximum number of objects in object stream}
+
+@ The following macros are similar as for \.{DVI} buffer handling
+
+@d pdf_offset == (pdf_gone + pdf_ptr) {the file offset of last byte in PDF
+buffer that |pdf_ptr| points to}
+
+@d no_zip == 0 {no \.{ZIP} compression}
+@d zip_writing == 1 {\.{ZIP} compression being used}
+@d zip_finish == 2 {finish \.{ZIP} compression}
+
+@d pdf_quick_out(#) == {output a byte to PDF buffer without checking of
+overflow}
+begin
+ pdf_buf[pdf_ptr] := #;
+ incr(pdf_ptr);
+end
+
+@d pdf_room(#) == {make sure that there are at least |n| bytes free in PDF buffer}
+begin
+ if pdf_os_mode and (# + pdf_ptr > pdf_buf_size) then
+ pdf_os_get_os_buf(#)
+ else if not pdf_os_mode and (# > pdf_buf_size) then
+ overflow("PDF output buffer", pdf_op_buf_size)
+ else if not pdf_os_mode and (# + pdf_ptr > pdf_buf_size) then
+ pdf_flush;
+end
+
+@d pdf_out(#) == {do the same as |pdf_quick_out| and flush the PDF
+buffer if necessary}
+begin
+ pdf_room(1);
+ pdf_quick_out(#);
+end
+
+@<Glob...@>=
+@!pdf_file: byte_file; {the PDF output file}
+@!pdf_buf: ^real_eight_bits; {pointer to the PDF output buffer or PDF object stream buffer}
+@!pdf_buf_size: integer; {end of PDF output buffer or PDF object stream buffer}
+@!pdf_ptr: integer; {pointer to the first unused byte in the PDF buffer or object stream buffer}
+@!pdf_op_buf: ^real_eight_bits; {the PDF output buffer}
+@!pdf_os_buf: ^real_eight_bits; {the PDF object stream buffer}
+@!pdf_os_buf_size: integer; {current size of the PDF object stream buffer, grows dynamically}
+@!pdf_os_objnum: ^integer; {array of object numbers within object stream}
+@!pdf_os_objoff: ^integer; {array of object offsets within object stream}
+@!pdf_os_objidx: pointer; {pointer into |pdf_os_objnum| and |pdf_os_objoff|}
+@!pdf_os_cntr: integer; {counter for object stream objects}
+@!pdf_op_ptr: integer; {store for PDF buffer |pdf_ptr| while inside object streams}
+@!pdf_os_ptr: integer; {store for object stream |pdf_ptr| while outside object streams}
+@!pdf_os_mode: boolean; {true if producing object stream}
+@!pdf_os_enable: boolean; {true if object streams are globally enabled}
+@!pdf_os_cur_objnum: integer; {number of current object stream object}
+@!pdf_gone: integer; {number of bytes that were flushed to output}
+@!pdf_save_offset: integer; {to save |pdf_offset|}
+@!zip_write_state: integer; {which state of compression we are in}
+@!fixed_pdf_minor_version: integer; {fixed minor part of the PDF version}
+@!fixed_pdf_objcompresslevel: integer; {fixed level for activating PDF object streams}
+@!pdf_minor_version_written: boolean; {flag if the PDF version has been written}
+@!fixed_pdfoutput: integer; {fixed output format}
+@!fixed_pdfoutput_set: boolean; {|fixed_pdfoutput| has been set?}
+@!fixed_gamma: integer;
+@!fixed_image_gamma: integer;
+@!fixed_image_hicolor: boolean;
+@!fixed_image_apply_gamma: integer;
+@!epochseconds: integer;
+@!microseconds: integer;
+@!fixed_pdf_draftmode: integer; {fixed \\pdfdraftmode}
+@!fixed_pdf_draftmode_set: boolean; {|fixed_pdf_draftmode| has been set?}
+
+
+@ @<Set init...@>=
+pdf_gone := 0;
+pdf_os_mode := false;
+pdf_ptr := 0;
+pdf_op_ptr := 0;
+pdf_os_ptr := 0;
+pdf_os_cur_objnum := 0;
+pdf_os_cntr := 0;
+pdf_buf_size := pdf_op_buf_size;
+pdf_os_buf_size := inf_pdf_os_buf_size;
+pdf_buf := pdf_op_buf;
+pdf_seek_write_length := false;
+zip_write_state := no_zip;
+pdf_minor_version_written := false;
+fixed_pdfoutput_set := false;
+fixed_pdf_draftmode_set := false;
+
+@ @p
+function fix_int(val, min, max: integer): integer;
+begin
+ if val < min then
+ fix_int := min
+ else if val > max then
+ fix_int := max
+ else
+ fix_int := val;
+end;
+
+@ This ensures that |pdfminorversion| is set only before any bytes have
+been written to the generated PDF file. Here also the PDF file is opened
+by |ensure_pdf_open| and the PDF header is written.
+
+@p procedure check_pdfminorversion;
+begin
+ if not pdf_minor_version_written then begin
+ pdf_minor_version_written := true;
+ if (pdf_minor_version < 0) or (pdf_minor_version > 9) then begin
+ print_err("pdfTeX error (illegal pdfminorversion)");
+ print_ln;
+ help2 ("The pdfminorversion must be between 0 and 9.")@/
+ ("I changed this to 4.");
+ int_error (pdf_minor_version);
+ pdf_minor_version := 4;
+ end;
+ fixed_pdf_minor_version := pdf_minor_version;
+ fixed_gamma := fix_int(pdf_gamma, 0, 1000000);
+ fixed_image_gamma := fix_int(pdf_image_gamma, 0, 1000000);
+ fixed_image_hicolor := fix_int(pdf_image_hicolor, 0, 1);
+ fixed_image_apply_gamma := fix_int(pdf_image_apply_gamma, 0, 1);
+ fixed_pdf_objcompresslevel := fix_int(pdf_objcompresslevel, 0, 3);
+ fixed_pdf_draftmode := fix_int(pdf_draftmode, 0, 1);
+ fixed_replace_font := fix_int(pdf_replace_font, 0, 1);
+ if (fixed_pdf_minor_version >= 5) and (fixed_pdf_objcompresslevel > 0) then
+ pdf_os_enable := true
+ else begin
+ if fixed_pdf_objcompresslevel > 0 then begin
+ pdf_warning("Object streams", "\pdfobjcompresslevel > 0 requires \pdfminorversion > 4. Object streams disabled now.", true, true);
+ fixed_pdf_objcompresslevel := 0;
+ end;
+ pdf_os_enable := false;
+ end;
+ ensure_pdf_open;
+ fix_pdfoutput;
+ pdf_print("%PDF-1.");
+ pdf_print_int_ln(fixed_pdf_minor_version);
+ pdf_print("%");
+ pdf_out(208); {'P' + 128}
+ pdf_out(212); {'T' + 128}
+ pdf_out(197); {'E' + 128}
+ pdf_out(216); {'X' + 128}
+ pdf_print_nl;
+ end
+ else begin
+ if fixed_pdf_minor_version <> pdf_minor_version then
+ pdf_error("setup",
+ "\pdfminorversion cannot be changed after data is written to the PDF file");
+ end;
+end;
+
+@ Checks that we have a name for the generated PDF file and that it's open.
+
+@p procedure ensure_pdf_open;
+begin
+ if output_file_name <> 0 then
+ return;
+ if job_name = 0 then
+ open_log_file;
+ pack_job_name(".pdf");
+ if fixed_pdf_draftmode = 0 then
+ while not lua_b_open_out(pdf_file) do
+ prompt_file_name("file name for output",".pdf");
+ pdf_file:=name_file_pointer;
+ output_file_name := b_make_name_string(pdf_file);
+end;
+
+@ The PDF buffer is flushed by calling |pdf_flush|, which checks the
+variable |zip_write_state| and will compress the buffer before flushing if
+neccesary. We call |pdf_begin_stream| to begin a stream and |pdf_end_stream|
+to finish it. The stream contents will be compressed if compression is turn on.
+
+@p procedure pdf_flush; {flush out the |pdf_buf|}
+begin
+ if not pdf_os_mode then begin
+ case zip_write_state of
+ no_zip: if pdf_ptr > 0 then begin
+ if fixed_pdf_draftmode = 0 then write_pdf(0, pdf_ptr - 1);
+ pdf_gone := pdf_gone + pdf_ptr;
+ pdf_last_byte := pdf_buf[pdf_ptr - 1];
+ end;
+ zip_writing:
+ if fixed_pdf_draftmode = 0 then write_zip(false);
+ zip_finish: begin
+ if fixed_pdf_draftmode = 0 then write_zip(true);
+ zip_write_state := no_zip;
+ end;
+ end;
+ pdf_ptr := 0;
+ end;
+end;
+
+procedure pdf_begin_stream; {begin a stream}
+begin
+ pdf_print_ln("/Length ");
+ pdf_seek_write_length := true; {fill in length at |pdf_end_stream| call}
+ pdf_stream_length_offset := pdf_offset - 11;
+ pdf_stream_length := 0;
+ if pdf_compress_level > 0 then begin
+ pdf_print_ln("/Filter /FlateDecode");
+ pdf_print_ln(">>");
+ pdf_print_ln("stream");
+ pdf_flush;
+ zip_write_state := zip_writing;
+ end
+ else begin
+ pdf_print_ln(">>");
+ pdf_print_ln("stream");
+ pdf_save_offset := pdf_offset;
+ end;
+end;
+
+procedure pdf_end_stream; {end a stream}
+begin
+ if zip_write_state = zip_writing then
+ zip_write_state := zip_finish
+ else
+ pdf_stream_length := pdf_offset - pdf_save_offset;
+ pdf_flush;
+ if pdf_seek_write_length then
+ write_stream_length(pdf_stream_length, pdf_stream_length_offset);
+ pdf_seek_write_length := false;
+ if pdf_last_byte <> pdf_new_line_char then
+ pdf_out(pdf_new_line_char);
+ pdf_print_ln("endstream");
+ pdf_end_obj;
+end;
+
+@ Basic printing procedures for PDF output are very similiar to \TeX\ basic
+printing ones but the output is going to PDF buffer. Subroutines with
+suffix |_ln| append a new-line character to the PDF output.
+
+@d pdf_new_line_char == 10 {new-line character for UNIX platforms}
+
+@d pdf_print_nl == {output a new-line character to PDF buffer}
+pdf_out(pdf_new_line_char)
+
+@d pdf_print_ln(#) == {print out a string to PDF buffer followed by
+a new-line character}
+begin
+ pdf_print(#);
+ pdf_print_nl;
+end
+
+@d pdf_print_int_ln(#) == {print out an integer to PDF buffer followed by
+a new-line character}
+begin
+ pdf_print_int(#);
+ pdf_print_nl;
+end
+
+@<Declare procedures that need to be declared forward for \pdfTeX@>=
+procedure pdf_error(t, p: str_number);
+begin
+ normalize_selector;
+ print_err("pdfTeX error");
+ if t <> 0 then begin
+ print(" (");
+ print(t);
+ print(")");
+ end;
+ print(": "); print(p);
+ succumb;
+end;
+
+procedure pdf_warning(t, p: str_number; prepend_nl, append_nl: boolean);
+begin
+ if interaction = error_stop_mode then
+ wake_up_terminal;
+ if prepend_nl then
+ print_ln;
+ print("pdfTeX warning");
+ if t <> 0 then begin
+ print(" (");
+ print(t);
+ print(")");
+ end;
+ print(": "); print(p);
+ if append_nl then
+ print_ln;
+ if history=spotless then history:=warning_issued;
+end;
+
+procedure pdf_os_get_os_buf(s: integer); {check that |s| bytes more
+fit into |pdf_os_buf|; increase it if required}
+var a: integer;
+begin
+ if s > sup_pdf_os_buf_size - pdf_ptr then
+ overflow("PDF object stream buffer", pdf_os_buf_size);
+ if pdf_ptr + s > pdf_os_buf_size then begin
+ a := 0.2 * pdf_os_buf_size;
+ if pdf_ptr + s > pdf_os_buf_size + a then
+ pdf_os_buf_size := pdf_ptr + s
+ else if pdf_os_buf_size < sup_pdf_os_buf_size - a then
+ pdf_os_buf_size := pdf_os_buf_size + a
+ else
+ pdf_os_buf_size := sup_pdf_os_buf_size;
+ pdf_os_buf := xreallocarray(pdf_os_buf, real_eight_bits, pdf_os_buf_size);
+ pdf_buf := pdf_os_buf;
+ pdf_buf_size := pdf_os_buf_size;
+ end;
+end;
+
+procedure remove_last_space;
+begin
+ if (pdf_ptr > 0) and (pdf_buf[pdf_ptr - 1] = 32) then
+ decr(pdf_ptr);
+end;
+
+function str_in_str(s, r: str_number; i: integer): boolean;
+ {test equality of strings}
+label not_found; {loop exit}
+var j, k: pool_pointer; {running indices}
+begin
+ str_in_str := false;
+ if length(s) < i + length(r) then
+ return;
+ j := i + str_start_macro(s);
+ k := str_start_macro(r);
+ while (j < str_start_macro(s + 1)) and (k < str_start_macro(r + 1)) do begin
+ if str_pool[j] <> str_pool[k] then
+ return;
+ incr(j);
+ incr(k);
+ end;
+ str_in_str := true;
+end;
+
+function tokens_to_string(p: pointer): str_number; {return a string from tokens
+list}
+var old_setting:integer;
+begin
+ if selector = new_string then
+ pdf_error("tokens", "tokens_to_string() called while selector = new_string");
+ old_setting:=selector; selector:=new_string;
+ show_token_list(link(p),null,pool_size-pool_ptr);
+ selector:=old_setting;
+ last_tokens_string := make_string;
+ tokens_to_string := last_tokens_string;
+end;
+
+
+@ To print |scaled| value to PDF output we need some subroutines to ensure
+accurary.
+
+@d max_integer == @"7FFFFFFF {$2^{31}-1$}
+@d call_func(#) == begin if # <> 0 then do_nothing end
+
+
+@<Glob...@>=
+@!one_hundred_inch: scaled; {scaled value corresponds to 100in}
+@!one_inch: scaled; {scaled value corresponds to 1in (rounded!)}
+@!one_hundred_bp: scaled; {scaled value corresponds to 100bp}
+@!one_bp: scaled; {scaled value corresponds to 1bp (rounded!)}
+@!ten_pow: array[0..9] of integer; {$10^0..10^9$}
+@!scaled_out: integer; {amount of |scaled| that was taken out in
+|divide_scaled|}
+@!init_pdf_output: boolean;
+
+@ @<Set init...@>=
+one_hundred_inch := 7227 * 65536; {exact, 473628672}
+one_inch := (one_hundred_inch + 50) div 100; {rounded to 4736287}
+one_hundred_bp := one_hundred_inch div 72; {exact, 6578176}
+one_bp := (one_hundred_bp + 50) div 100; {rounded to 65782}
+ten_pow[0] := 1;
+for i := 1 to 9 do
+ ten_pow[i] := 10*ten_pow[i - 1];
+init_pdf_output := false;
+
+
+@ The function |divide_scaled| divides |s| by |m| using |dd| decimal
+digits of precision. It is defined in C because it is a good candidate
+for optimizations that are not possible in pascal.
+
+@<Declare procedures that need to be declared forward for \pdfTeX@>=
+function round_xn_over_d(@!x:scaled; @!n,@!d:integer):scaled;
+var positive:boolean; {was |x>=0|?}
+@!t,@!u,@!v:nonnegative_integer; {intermediate quantities}
+begin if x>=0 then positive:=true
+else begin negate(x); positive:=false;
+ end;
+t:=(x mod @'100000)*n;
+u:=(x div @'100000)*n+(t div @'100000);
+v:=(u mod d)*@'100000 + (t mod @'100000);
+if u div d>=@'100000 then arith_error:=true
+else u:=@'100000*(u div d) + (v div d);
+v := v mod d;
+if 2*v >= d then
+ incr(u);
+if positive then
+ round_xn_over_d := u
+else
+ round_xn_over_d := -u;
+end;
+
+@ Next subroutines are needed for controling spacing in PDF page description.
+For a given character |c| from a font |f|,
+the procedure |adv_char_width| advances |pdf_h|
+by {\it about\/} the amount |w|, which is the character width.
+But we cannot simply add |w| to |pdf_h|.
+Instead we have to bring the required shift into the same raster,
+on which also the \.{/Widths} array values,
+as they appear in the PDF file, are based.
+The |scaled_out| value is the |w| value moved into this raster.
+The \.{/Widths} values are used by the PDF reader independently
+to update its positions.
+So one has to be sure, that calculations are properly synchronized.
+Currently the \.{/Widths} array values are output
+with one digit after the decimal point,
+therefore the raster on which |adv_char_width| is operating
+is $1/10000$ of the |pdf_font_size|.
+
+For PK fonts things are more complicated,
+as we have to deal with scaling bitmaps as well.
+
+@p
+procedure adv_char_width(f: internal_font_number; c: integer); {update |pdf_h|
+by character width |w| from font |f|}
+var w, s_out: scaled;
+ s: integer;
+begin
+ w := char_width(f,c);
+ if hasfmentry(f) then begin
+ if pdf_cur_Tm_a = 0 then begin
+ call_func(divide_scaled_n(w, pdf_font_size(f),10000.0));
+ pdf_delta_h := pdf_delta_h + scaled_out;
+ end
+ else begin
+ s := divide_scaled_n(round_xn_over_d(w, 1000, 1000 + pdf_cur_Tm_a),
+ pdf_font_size(f),10000.0);
+ s_out := round_xn_over_d(round_xn_over_d(pdf_font_size(f), abs(s), 10000),
+ 1000 + pdf_cur_Tm_a, 1000);
+ if s < 0 then
+ s_out := -s_out;
+ pdf_delta_h := pdf_delta_h + s_out;
+ end;
+ end else
+ pdf_delta_h := pdf_delta_h + get_pk_char_width(f, w);
+end;
+
+procedure pdf_print_bp(s: scaled); {print scaled as |bp|}
+begin
+ pdf_print_real(divide_scaled(s, one_hundred_bp, fixed_decimal_digits + 2),
+ fixed_decimal_digits);
+end;
+
+procedure pdf_print_mag_bp(s: scaled); {take |mag| into account}
+begin
+ prepare_mag;
+ if mag <> 1000 then
+ s := round_xn_over_d(s, mag, 1000);
+ pdf_print_bp(s);
+end;
+
+@* \[32c] PDF page description.
+
+@d pdf_h_offset == (h_offset + pdf_h_origin)
+@d pdf_v_offset == (v_offset + pdf_v_origin)
+@d pdf_x(#) == ((#) - pdf_h_offset + one_inch) {convert $x$-coordinate from \.{DVI} to PDF}
+@d pdf_y(#) == (cur_page_height - (#) - pdf_v_offset + one_inch) {convert $y$-coordinate from \.{DVI} to PDF}
+
+@<Glob...@>=
+@!pdf_f: internal_font_number; {the current font in PDF output page}
+@!pdf_h: scaled; {current horizontal coordinate in PDF output page}
+@!pdf_v: scaled; {current vertical coordinate in PDF output page}
+@!pdf_tj_start_h: scaled; {horizontal coordinate in PDF output page just before \.{TJ} array start}
+@!cur_delta_h: scaled; {horizontal |cur_h| offset from |pdf_tj_start_h|}
+@!pdf_delta_h: scaled; {horizontal offset from |pdf_tj_start_h|}
+@!pdf_origin_h: scaled; {current horizontal origin in PDF output page}
+@!pdf_origin_v: scaled; {current vertical origin in PDF output page}
+@!pdf_doing_string: boolean; {we are writing string to PDF file?}
+@!pdf_doing_text: boolean; {we are writing text section to PDF file?}
+@!min_bp_val: scaled;
+@!min_font_val: scaled; {(TJ array system)}
+@!fixed_pk_resolution: integer;
+@!fixed_decimal_digits: integer;
+@!fixed_gen_tounicode: integer;
+@!fixed_replace_font: integer;
+@!pk_scale_factor: integer;
+@!pdf_output_option: integer;
+@!pdf_output_value: integer;
+@!pdf_draftmode_option: integer;
+@!pdf_draftmode_value: integer;
+@!pdf_cur_Tm_a: integer; {|a| value of the current text matrix, ie the current
+ horizontal scaling factor}
+@!pdf_last_f: internal_font_number; {last font in PDF output page}
+@!pdf_last_fs: internal_font_number; {last font size in PDF output page}
+
+
+@ Following procedures implement low-level subroutines to convert \TeX{}
+internal structures to PDF page description.
+
+@p procedure pdf_set_origin(h, v: scaled); {set the origin to |h|, |v|}
+begin
+ if (abs(h - pdf_origin_h) >= min_bp_val) or
+ (abs(v - pdf_origin_v) >= min_bp_val) then begin
+ pdf_print("1 0 0 1 ");
+ pdf_print_bp(h - pdf_origin_h);
+ pdf_origin_h := pdf_origin_h + scaled_out;
+ pdf_out(" ");
+ pdf_print_bp(pdf_origin_v - v);
+ pdf_origin_v := pdf_origin_v - scaled_out;
+ pdf_print_ln(" cm");
+ end;
+ pdf_h := pdf_origin_h;
+ pdf_tj_start_h := pdf_h;
+ pdf_v := pdf_origin_v;
+end;
+
+procedure pdf_set_origin_temp(h, v: scaled); {set the origin to |h|, |v| inside group}
+begin
+ if (abs(h - pdf_origin_h) >= min_bp_val) or
+ (abs(v - pdf_origin_v) >= min_bp_val) then begin
+ pdf_print("1 0 0 1 ");
+ pdf_print_bp(h - pdf_origin_h);
+ pdf_out(" ");
+ pdf_print_bp(pdf_origin_v - v);
+ pdf_print_ln(" cm");
+ end;
+end;
+
+procedure pdf_end_string; {end the current string}
+begin
+ if pdf_doing_string then begin
+ pdf_print(")]TJ");
+ pdf_doing_string := false;
+ end;
+end;
+
+procedure pdf_end_string_nl; {end the current string, with new-line}
+begin
+ if pdf_doing_string then begin
+ pdf_print_ln(")]TJ");
+ pdf_doing_string := false;
+ end;
+end;
+
+procedure pdf_set_textmatrix(v, v_out: scaled; f: internal_font_number);
+{set the next starting point to |cur_h|, |cur_v|}
+var pdf_new_Tm_a: integer; {|a| value of the new text matrix}
+begin
+ pdf_out(" ");
+ if f = pdf_f then
+ pdf_new_Tm_a := pdf_cur_Tm_a
+ else if not pdf_font_auto_expand(f) then
+ pdf_new_Tm_a := 0
+ else
+ pdf_new_Tm_a := pdf_font_expand_ratio(f);
+ if (pdf_new_Tm_a <> 0) or
+ ((pdf_new_Tm_a = 0) and (pdf_cur_Tm_a <> 0)) then begin
+ pdf_print_real(1000 + pdf_new_Tm_a, 3);
+ pdf_print(" 0 0 1 ");
+ pdf_print_bp(cur_h - pdf_origin_h);
+ pdf_h := pdf_origin_h + scaled_out;
+ pdf_out(" ");
+ pdf_print_bp(pdf_origin_v - cur_v);
+ pdf_v := pdf_origin_v - scaled_out;
+ pdf_print(" Tm");
+ pdf_cur_Tm_a := pdf_new_Tm_a;
+ pdfassert(pdf_cur_Tm_a > -1000);
+ end else begin
+ pdf_print_bp(cur_h - pdf_tj_start_h); {works only for unexpanded fonts}
+ pdf_h := pdf_tj_start_h + scaled_out;
+ pdf_out(" ");
+ pdf_print_real(v, fixed_decimal_digits); {use |v| and |v_out| to avoid duplicate calculation}
+ pdf_v := pdf_v - v_out;
+ pdf_print(" Td");
+ end;
+ pdf_tj_start_h := pdf_h;
+ pdf_delta_h := 0;
+end;
+
+procedure pdf_use_font(f: internal_font_number; fontnum: integer);
+{mark |f| as a used font; set |font_used(f)|, |pdf_font_size(f)| and |pdf_font_num(f)|}
+begin
+ call_func(divide_scaled(font_size(f), one_hundred_bp, 6));
+ set_pdf_font_size(f,scaled_out);
+ set_font_used(f,true);
+ pdfassert((fontnum > 0) or ((fontnum < 0) and (pdf_font_num(-fontnum) > 0)));
+ set_pdf_font_num(f,fontnum);
+ if pdf_move_chars > 0 then begin
+ pdf_warning(0,"Primitive \pdfmovechars is obsolete.",true, true);
+ pdf_move_chars := 0; {warn only once}
+ end;
+end;
+
+@ To set PDF font we need to find out fonts with the same name, because \TeX\
+can load the same font several times for various sizes. For such fonts we
+define only one font resource. The array |pdf_font_num| holds the object
+number of font resource. A negative value of an entry of |pdf_font_num|
+indicates that the corresponding font shares the font resource with the font
+
+@d pdf_print_resname_prefix ==
+if pdf_resname_prefix <> 0 then
+ pdf_print(pdf_resname_prefix)
+
+@p procedure pdf_init_font(f: internal_font_number);
+{create a font object}
+var k, b: internal_font_number;
+ i: integer;
+begin
+ pdfassert(not font_used(f));
+
+ {if |f| is auto expanded then ensure the base font is initialized}
+ if pdf_font_auto_expand(f) and (pdf_font_blink(f) <> null_font) then begin
+ b := pdf_font_blink(f);
+ {TODO: reinstate this check. disabled because wide fonts font have fmentries}
+ if false and (not hasfmentry(b)) then
+ pdf_error("font expansion", "auto expansion is only possible with scalable fonts");
+ if not font_used(b) then
+ pdf_init_font(b);
+ set_font_map(f,font_map(b));
+ end;
+
+ {check whether |f| can share the font object with some |k|: we have 2 cases
+ here: 1) |f| and |k| have the same tfm name (so they have been loaded at
+ different sizes, eg 'cmr10' and 'cmr10 at 11pt'); 2) |f| has been auto
+ expanded from |k|}
+ if hasfmentry(f) or true then begin
+ i := head_tab[obj_type_font];
+ while i <> 0 do begin
+ k := obj_info(i);
+ if font_shareable(f,k) then
+ begin
+ pdfassert(pdf_font_num(k) <> 0);
+ if pdf_font_num(k) < 0 then
+ pdf_use_font(f, pdf_font_num(k))
+ else
+ pdf_use_font(f, -k);
+ return;
+ end;
+ i := obj_link(i);
+ end;
+ end;
+
+ {create a new font object for |f|}
+ pdf_create_obj(obj_type_font, f);
+ pdf_use_font(f, obj_ptr);
+end;
+
+procedure pdf_init_font_cur_val;
+begin
+ pdf_init_font(cur_val);
+end;
+
+procedure pdf_set_font(f: internal_font_number);
+{set the actual font on PDF page}
+label found, found1;
+var p: pointer;
+ k: internal_font_number;
+begin
+ if not font_used(f) then
+ pdf_init_font(f);
+ set_ff(f); {set |ff| to the tfm number of the font sharing the font object
+ with |f|; |ff| is either |f| or some font with the same tfm name
+ at different size and/or expansion}
+ k := ff;
+ p := pdf_font_list;
+ while p <> null do begin
+ set_ff(info(p));
+ if ff = k then
+ goto found;
+ p := link(p);
+ end;
+ pdf_append_list(f)(pdf_font_list); {|f| not found in |pdf_font_list|, append it now}
+found:
+ if (k = pdf_last_f) and (font_size(f) = pdf_last_fs) then
+ return;
+ pdf_print("/F");
+ pdf_print_int(k);
+ pdf_print_resname_prefix;
+ pdf_out(" ");
+ pdf_print_real(divide_scaled(font_size(f), one_hundred_bp, 6), 4);
+ pdf_print(" Tf");
+ pdf_last_f := k;
+ pdf_last_fs := font_size(f);
+end;
+
+procedure pdf_begin_text; {begin a text section}
+begin
+ pdf_set_origin(0, cur_page_height);
+ pdf_print_ln("BT");
+ pdf_doing_text := true;
+ pdf_f := null_font;
+ pdf_last_f := null_font;
+ pdf_last_fs := 0;
+ pdf_doing_string := false;
+ pdf_cur_Tm_a := 0;
+end;
+
+@ @p
+procedure pdf_begin_string(f: internal_font_number); {begin to draw a string}
+var s_out, v, v_out: scaled;
+ s: integer;
+begin s_out:=0;
+ if not pdf_doing_text then
+ pdf_begin_text;
+ if f <> pdf_f then begin
+ pdf_end_string;
+ pdf_set_font(f);
+ end;
+ if pdf_cur_Tm_a = 0 then begin
+ s := divide_scaled_n(cur_h - (pdf_tj_start_h + pdf_delta_h), pdf_font_size(f),1000.0);
+ s_out := scaled_out;
+ end
+ else begin
+ s := divide_scaled_n(round_xn_over_d(cur_h - (pdf_tj_start_h + pdf_delta_h), 1000,
+ 1000 + pdf_cur_Tm_a),
+ pdf_font_size(f),
+ 1000.0);
+ if abs(s) < @'100000 then begin
+ s_out := round_xn_over_d(round_xn_over_d(pdf_font_size(f), abs(s), 1000),
+ 1000 + pdf_cur_Tm_a, 1000);
+ if s < 0 then
+ s_out := -s_out;
+ end;
+ {no need to calculate |s_out| when |abs(s) >= @'100000|, since the text
+ matrix will be reset below}
+ end;
+ if abs(cur_v - pdf_v) >= min_bp_val then begin
+ v := divide_scaled(pdf_v - cur_v, one_hundred_bp,
+ fixed_decimal_digits + 2);
+ v_out := scaled_out;
+ end
+ else begin
+ v := 0;
+ v_out := 0;
+ end;
+ if (f <> pdf_f) or (v <> 0) or (abs(s) >= @'100000) then begin
+ pdf_end_string;
+ pdf_set_textmatrix(v, v_out, f);
+ pdf_f := f;
+ s := 0;
+ end;
+ if not pdf_doing_string then begin
+ pdf_print(" [");
+ if s = 0 then
+ pdf_out("(");
+ end;
+ if s <> 0 then begin
+ if pdf_doing_string then
+ pdf_out(")");
+ pdf_print_int(-s);
+ pdf_out("(");
+ pdf_delta_h := pdf_delta_h + s_out;
+ end;
+ pdf_doing_string := true;
+end;
+
+procedure pdf_end_text; {end a text section}
+begin
+ if pdf_doing_text then begin
+ pdf_end_string_nl;
+ pdf_print_ln("ET");
+ pdf_doing_text := false;
+ end;
+end;
+
+procedure pdf_set_rule(x, y, w, h: scaled); {draw a rule}
+begin
+ pdf_end_text;
+ pdf_print_ln("q");
+ if h <= one_bp then begin
+ pdf_set_origin_temp(x, y - (h + 1)/2);
+ pdf_print("[]0 d 0 J ");
+ pdf_print_bp(h); pdf_print(" w 0 0 m ");
+ pdf_print_bp(w); pdf_print_ln(" 0 l S");
+ end
+ else if w <= one_bp then begin
+ pdf_set_origin_temp(x + (w + 1)/2, cur_v);
+ pdf_print("[]0 d 0 J ");
+ pdf_print_bp(w); pdf_print(" w 0 0 m 0 ");
+ pdf_print_bp(h); pdf_print_ln(" l S");
+ end
+ else begin
+ pdf_set_origin_temp(x, y);
+ pdf_print("0 0 ");
+ pdf_print_bp(w); pdf_out(" ");
+ pdf_print_bp(h); pdf_print_ln(" re f");
+ end;
+ pdf_print_ln("Q");
+end;
+
+procedure pdf_rectangle(left, top, right, bottom: scaled); {output a
+rectangle specification to PDF file}
+begin
+ prepare_mag;
+ pdf_print("/Rect [");
+ pdf_print_mag_bp(pdf_x(left)); pdf_out(" ");
+ pdf_print_mag_bp(pdf_y(bottom)); pdf_out(" ");
+ pdf_print_mag_bp(pdf_x(right)); pdf_out(" ");
+ pdf_print_mag_bp(pdf_y(top));
+ pdf_print_ln("]");
+end;
+
+procedure literal(s: str_number; literal_mode: integer; warn: boolean);
+var j: pool_pointer; {current character code position}
+begin
+ j:=str_start_macro(s);
+ if literal_mode = scan_special then begin
+ if not (str_in_str(s, "PDF:", 0) or str_in_str(s, "pdf:", 0)) then begin
+ if warn and not (str_in_str(s, "SRC:", 0)
+ or str_in_str(s, "src:", 0)
+ or (length(s) = 0)) then
+ print_nl("Non-PDF special ignored!");
+ return;
+ end;
+ j := j + length("PDF:");
+ if str_in_str(s, "direct:", length("PDF:")) then begin
+ j := j + length("direct:");
+ literal_mode := direct_always; end
+ else if str_in_str(s, "page:", length("PDF:")) then begin
+ j := j + length("page:");
+ literal_mode := direct_page; end
+ else
+ literal_mode := set_origin;
+ end;
+ case literal_mode of
+ set_origin: begin
+ pdf_end_text;
+ pdf_set_origin(cur_h, cur_v);
+ end;
+ direct_page:
+ pdf_end_text;
+ direct_always:
+ pdf_end_string_nl;
+ othercases confusion("literal1")
+ endcases;
+ while j<str_start_macro(s+1) do begin
+ pdf_out(str_pool[j]);
+ incr(j);
+ end;
+ pdf_print_nl;
+end;
+
+procedure latelua(lua_id: quarterword; s: str_number);
+var b, j: pool_pointer; {current character code position}
+begin
+ j:=str_start_macro(s);
+ b := pool_ptr;
+ luacall(lua_id,(s-string_offset));
+ while b<pool_ptr do begin
+ pdf_out(str_pool[b]);
+ incr(b);
+ end;
+ pdf_print_nl;
+end;
+
+@* \[32d] The cross-reference table.
+
+The cross-reference table |obj_tab| is an array of |obj_tab_size| of
+|tab_entry|. Each entry contains five integer fields and represents an object
+in PDF file whose object number is the index of this entry in |obj_tab|.
+Objects in |obj_tab| maybe linked into list; objects in such a linked list have
+the same type.
+
+@<Types...@>=
+@!obj_entry = record@;@/
+ int0, int1, int2, int3, int4: integer;
+end;
+
+@ The first field contains information representing identifier of this object.
+It is usally a number for most of object types, but it may be a string number
+for named destination or named thread.
+
+The second field of |obj_entry| contains link to the next
+object in |obj_tab| if this object is linked in a list.
+
+The third field holds the byte offset of the object in the output PDF file,
+or its byte offset within an object stream.
+Objects that have been not written yet have this field set to zero. However
+sometimes we have to use this field to store some info before the object is
+written out.
+
+The fourth field holds the object number of the object stream, into which
+the object is included.
+
+The last field usually represents the pointer to some auxiliary data
+structure depending on the object type; however it may be used as a counter as
+well.
+
+@d obj_info(#) == obj_tab[#].int0 {information representing identifier of this object}
+@d obj_link(#) == obj_tab[#].int1 {link to the next entry in linked list}
+@d obj_offset(#) == obj_tab[#].int2 {byte offset for this object in PDF output file, or object stream number for this object}
+@d obj_os_idx(#) == obj_tab[#].int3 {index of this object in object stream}
+@d obj_aux(#) == obj_tab[#].int4 {auxiliary pointer}
+@d is_obj_written(#) == (obj_offset(#) <> 0)
+
+@# {types of objects}
+@d obj_type_others == 0 {objects which are not linked in any list}
+@d obj_type_page == 1 {index of linked list of Page objects}
+@d obj_type_pages == 2 {index of linked list of Pages objects}
+@d obj_type_font == 3 {index of linked list of Fonts objects}
+@d obj_type_outline == 4 {index of linked list of outline objects}
+@d obj_type_dest == 5 {index of linked list of destination objects}
+@d obj_type_obj == 6 {index of linked list of raw objects}
+@d obj_type_xform == 7 {index of linked list of XObject forms}
+@d obj_type_ximage == 8 {index of linked list of XObject image}
+@d obj_type_thread == 9 {index of linked list of num article threads}
+@d head_tab_max == obj_type_thread {max index of |head_tab|}
+
+@# {max number of kids for balanced trees}
+@d pages_tree_kids_max == 6 {max number of kids of Pages tree node}
+@d name_tree_kids_max == 6 {max number of kids of node of name tree for
+name destinations}
+
+@# {when a whatsit node representing annotation is created, words |1..3| are
+width, height and depth of this annotation; after shipping out words |1..4|
+are rectangle specification of annotation. For whatsit node representing
+destination |pdf_left| and |pdf_top| are used for some types of destinations}
+
+@# {coordinates of destinations/threads/annotations (in whatsit node)}
+@d pdf_left(#) == vmem(# + 2).sc
+@d pdf_top(#) == vmem(# + 3).sc
+@d pdf_right(#) == vmem(# + 4).sc
+@d pdf_bottom(#) == vmem(# + 5).sc
+
+@# {dimension of destinations/threads/annotations (in whatsit node)}
+@d pdf_width(#) == vmem(# + 2).sc
+@d pdf_height(#) == vmem(# + 3).sc
+@d pdf_depth(#) == vmem(# + 4).sc
+
+@# {data structure for \.{\\pdfliteral}}
+@d pdf_literal_data(#) == vlink(#+2) {data}
+@d pdf_literal_mode(#) == vinfo(#+2) {mode of resetting the text matrix
+ while writing data to the page stream}
+@# {modes of setting the current transformation matrix (CTM)}
+@d set_origin == 0 {end text (ET) if needed, set CTM to current point}
+@d direct_page == 1 {end text (ET) if needed, but don't change the CTM}
+@d direct_always == 2 {don't end text, don't change the CTM}
+@d scan_special == 3 {look into special text}
+
+@# {data structure for \.{\\pdfcolorstack}}
+@d pdf_colorstack_node_size == 4
+@d pdf_colorstack_stack(#) == vlink(#+2) {stack number}
+@d pdf_colorstack_cmd(#) == vinfo(#+2) {command: set, push, pop, current}
+@d pdf_colorstack_data(#) == vlink(#+3) {data}
+
+@# {color stack commands}
+@d colorstack_set == 0
+@d colorstack_push == 1
+@d colorstack_data == 1 { last value where data field is set }
+@d colorstack_pop == 2
+@d colorstack_current == 3
+
+@# {data structure for \.{\\pdfsetmatrix}}
+@d pdf_setmatrix_node_size == 3
+@d pdf_setmatrix_data(#) == vlink(#+2) {data}
+
+@# {data structure for \.{\\pdsave}}
+@d pdf_save_node_size == 3
+
+@# {data structure for \.{\\pdfrestore}}
+@d pdf_restore_node_size == 3
+
+
+@# {data structure for \.{\\latelua}}
+@d late_lua_data(#) == vlink(#+2) {data}
+@d late_lua_reg(#) == vinfo(#+2) {register id}
+
+@# {data structure for \.{\\pdfobj} and \.{\\pdfrefobj}}
+@d pdf_refobj_node_size == 3 {size of whatsit node representing the raw object}
+@d pdf_obj_objnum(#) == vinfo(# + 2) {number of the raw object}
+@d obj_data_ptr == obj_aux {pointer to |pdf_mem|}
+@d pdfmem_obj_size == 4 {size of memory in |pdf_mem| which |obj_data_ptr| holds}
+@d obj_obj_data(#) == pdf_mem[obj_data_ptr(#) + 0] {object data}
+@d obj_obj_is_stream(#) == pdf_mem[obj_data_ptr(#) + 1] {will this object
+ be written as a stream instead of a dictionary?}
+@d obj_obj_stream_attr(#) == pdf_mem[obj_data_ptr(#) + 2] {additional
+ object attributes for streams}
+@d obj_obj_is_file(#) == pdf_mem[obj_data_ptr(#) + 3] {data should be
+ read from an external file?}
+
+@# {data structure for \.{\\pdfxform} and \.{\\pdfrefxform}}
+@d pdf_refxform_node_size == 6 {size of whatsit node for xform; words 1..3 are
+ form dimensions}
+@d pdf_xform_objnum(#) == vinfo(# + 4) {object number}
+@d pdfmem_xform_size == 6 {size of memory in |pdf_mem| which
+ |obj_data_ptr| holds}
+@d obj_xform_width(#) == pdf_mem[obj_data_ptr(#) + 0]
+@d obj_xform_height(#) == pdf_mem[obj_data_ptr(#) + 1]
+@d obj_xform_depth(#) == pdf_mem[obj_data_ptr(#) + 2]
+@d obj_xform_box(#) == pdf_mem[obj_data_ptr(#) + 3] {this field holds
+ pointer to the corresponding box}
+@d obj_xform_attr(#) == pdf_mem[obj_data_ptr(#) + 4] {additional xform
+ attributes}
+@d obj_xform_resources(#) == pdf_mem[obj_data_ptr(#) + 5] {additional xform
+ Resources}
+
+@# {data structure for \.{\\pdfximage} and \.{\\pdfrefximage}}
+@d pdf_refximage_node_size == 6 {size of whatsit node for ximage; words 2..4
+ are image dimensions}
+@d pdf_ximage_ref(#) == vinfo(# + 5) {image reference number}
+
+@# {data structure of annotations; words 1..4 represent the coordinates of
+ the annotation}
+@d obj_annot_ptr == obj_aux {pointer to corresponding whatsit node}
+@d pdf_annot_node_size == 8 {size of whatsit node representing annotation}
+@d pdf_annot_data(#) == vinfo(# + 6) {raw data of general annotations}
+@d pdf_link_attr(#) == vinfo(# + 6) {attributes of link annotations}
+@d pdf_link_action(#) == vlink(# + 6) {pointer to action structure}
+@d pdf_annot_objnum(#) == vmem(# + 7).int {object number of corresponding object}
+@d pdf_link_objnum(#) == vmem(# + 7).int {object number of corresponding object}
+
+@# {types of actions}
+@d pdf_action_page == 0 {GoTo action}
+@d pdf_action_goto == 1 {GoTo action}
+@d pdf_action_thread == 2 {Thread action}
+@d pdf_action_user == 3 {user-defined action}
+
+@# {data structure of actions}
+@d pdf_action_size == 4 {size of action structure in |mem|}
+@d action_node == 45
+@d pdf_action_type(#) == type(#+1) {action type}
+@d pdf_action_named_id(#) == subtype(#+1) {identifier is type of name}
+@d pdf_action_id(#) == vlink(#+1) {destination/thread name identifier}
+@d pdf_action_file(#) == vinfo(# + 2) {file name for external action}
+@d pdf_action_new_window(#) == vlink(# + 2) {open a new window?}
+@d pdf_action_tokens(#) == vinfo(# + 3) {specification of GoTo page or user action}
+@d pdf_action_refcount(#) == vlink(# + 3) {counter of references to this action}
+
+@# {data structure of outlines; it's not able to write out outline entries
+before all outline entries are defined, so memory allocated for outline
+entries can't not be deallocated and will stay in memory. For this reason we
+will store data of outline entries in |pdf_mem| instead of |mem|}
+
+@d pdfmem_outline_size == 8 {size of memory in |pdf_mem| which
+|obj_outline_ptr| points to}
+@d obj_outline_count == obj_info{count of all opened children}
+@d obj_outline_ptr == obj_aux {pointer to |pdf_mem|}
+@d obj_outline_title(#) == pdf_mem[obj_outline_ptr(#)]
+@d obj_outline_parent(#) == pdf_mem[obj_outline_ptr(#) + 1]
+@d obj_outline_prev(#) == pdf_mem[obj_outline_ptr(#) + 2]
+@d obj_outline_next(#) == pdf_mem[obj_outline_ptr(#) + 3]
+@d obj_outline_first(#) == pdf_mem[obj_outline_ptr(#) + 4]
+@d obj_outline_last(#) == pdf_mem[obj_outline_ptr(#) + 5]
+@d obj_outline_action_objnum(#) == pdf_mem[obj_outline_ptr(#) + 6] {object number of
+action}
+@d obj_outline_attr(#) == pdf_mem[obj_outline_ptr(#) + 7]
+
+@# {types of destinations}
+@d pdf_dest_xyz == 0
+@d pdf_dest_fit == 1
+@d pdf_dest_fith == 2
+@d pdf_dest_fitv == 3
+@d pdf_dest_fitb == 4
+@d pdf_dest_fitbh == 5
+@d pdf_dest_fitbv == 6
+@d pdf_dest_fitr == 7
+
+@# {data structure of destinations}
+@d obj_dest_ptr == obj_aux {pointer to |pdf_dest_node|}
+@d pdf_dest_node_size == 8 {size of whatsit node for destination;
+words |1..4| hold dest dimensions, word |6| identifier type, subtype
+and identifier of destination, word |6| the corresponding object number}
+@d pdf_dest_type(#) == type(# + 6) {type of destination}
+@d pdf_dest_named_id(#) == subtype(# + 6) {is named identifier?}
+@d pdf_dest_id(#) == vlink(# + 6) {destination identifier}
+@d pdf_dest_xyz_zoom(#) == vinfo(# + 7) {zoom factor for |destxyz| destination}
+@d pdf_dest_objnum(#) == vlink(# + 7) {object number of corresponding
+object}
+
+@# {data structure of threads; words 1..4 represent the coordinates of the
+ corners}
+@d pdf_thread_node_size == 8
+@d pdf_thread_named_id(#) == subtype(# + 6) {is a named identifier}
+@d pdf_thread_id(#) == vlink(# + 6) {thread identifier}
+@d pdf_thread_attr(#) == vinfo(# + 7) {attributes of thread}
+@d obj_thread_first == obj_aux {pointer to the first bead}
+
+@# {data structure of beads}
+@d pdfmem_bead_size == 5 {size of memory in |pdf_mem| which
+ |obj_bead_ptr| points to}
+@d obj_bead_ptr == obj_aux {pointer to |pdf_mem|}
+@d obj_bead_rect(#) == pdf_mem[obj_bead_ptr(#)]
+@d obj_bead_page(#) == pdf_mem[obj_bead_ptr(#) + 1]
+@d obj_bead_next(#) == pdf_mem[obj_bead_ptr(#) + 2]
+@d obj_bead_prev(#) == pdf_mem[obj_bead_ptr(#) + 3]
+@d obj_bead_attr(#) == pdf_mem[obj_bead_ptr(#) + 4]
+@d obj_bead_data == obj_bead_rect {pointer to the corresponding
+whatsit node; |obj_bead_rect| is needed only when the bead rectangle has
+been written out and after that |obj_bead_data| is not needed any more
+so we can use this field for both}
+
+@<Constants...@>=
+@!inf_obj_tab_size = 1000; {min size of the cross-reference table for PDF output}
+@!sup_obj_tab_size = 8388607; {max size of the cross-reference table for PDF output}
+@!inf_dest_names_size = 1000; {min size of the destination names table for PDF output}
+@!sup_dest_names_size = 131072; {max size of the destination names table for PDF output}
+@!inf_pk_dpi = 72; {min PK pixel density value from \.{texmf.cnf}}
+@!sup_pk_dpi = 8000; {max PK pixel density value from \.{texmf.cnf}}
+@!pdf_objtype_max = head_tab_max;
+
+@ @<Glob...@>=
+@!obj_tab_size:integer;
+@!obj_tab:^obj_entry;
+@!head_tab: array[1..head_tab_max] of integer;
+@!pages_tail: integer;
+@!obj_ptr: integer; {user objects counter}
+@!sys_obj_ptr: integer; {system objects counter, including object streams}
+@!pdf_last_pages: integer; {pointer to most recently generated pages object}
+@!pdf_last_page: integer; {pointer to most recently generated page object}
+@!pdf_last_stream: integer; {pointer to most recently generated stream}
+@!pdf_stream_length: integer; {length of most recently generated stream}
+@!pdf_stream_length_offset: integer; {file offset of the last stream length}
+@!pdf_seek_write_length: boolean; {flag whether to seek back and write \.{/Length}}
+@!pdf_last_byte: integer; {byte most recently written to PDF file; for \.{endstream} in new line}
+@!pdf_append_list_arg: integer; {for use with |pdf_append_list|}
+@!ff: integer; {for use with |set_ff|}
+@!pdf_box_spec_media: integer;
+@!pdf_box_spec_crop: integer;
+@!pdf_box_spec_bleed: integer;
+@!pdf_box_spec_trim: integer;
+@!pdf_box_spec_art: integer;
+
+@ @<Set init...@>=
+obj_ptr := 0;
+sys_obj_ptr := 0;
+obj_tab_size := inf_obj_tab_size; {allocated size of |obj_tab| array}
+dest_names_size := inf_dest_names_size; {allocated size of |dest_names| array}
+for k := 1 to head_tab_max do
+ head_tab[k] := 0;
+pdf_box_spec_media := 1;
+pdf_box_spec_crop := 2;
+pdf_box_spec_bleed := 3;
+pdf_box_spec_trim := 4;
+pdf_box_spec_art := 5;
+
+@ Here we implement subroutines for work with objects and related things.
+Some of them are used in former parts too, so we need to declare them
+forward.
+
+@d pdf_append_list_end(#) == # := append_ptr(#, pdf_append_list_arg); end
+@d pdf_append_list(#) == begin pdf_append_list_arg := #; pdf_append_list_end
+@d set_ff(#) == begin
+ if pdf_font_num(#) < 0 then
+ ff := -pdf_font_num(#)
+ else
+ ff := #;
+end
+
+@<Declare procedures that need to be declared forward for \pdfTeX@>=
+procedure append_dest_name(s: str_number; n: integer);
+var a: integer;
+begin
+ if pdf_dest_names_ptr = sup_dest_names_size then
+ overflow("number of destination names (dest_names_size)", dest_names_size);
+ if pdf_dest_names_ptr = dest_names_size then begin
+ a := 0.2 * dest_names_size;
+ if dest_names_size < sup_dest_names_size - a then
+ dest_names_size := dest_names_size + a
+ else
+ dest_names_size := sup_dest_names_size;
+ dest_names := xreallocarray(dest_names, dest_name_entry, dest_names_size);
+ end;
+ dest_names[pdf_dest_names_ptr].objname := s;
+ dest_names[pdf_dest_names_ptr].objnum := n;
+ incr(pdf_dest_names_ptr);
+end;
+
+procedure pdf_create_obj(t, i: integer); {create an object with type |t| and
+identifier |i|}
+label done;
+var a, p, q: integer;
+begin
+ if sys_obj_ptr = sup_obj_tab_size then
+ overflow("indirect objects table size", obj_tab_size);
+ if sys_obj_ptr = obj_tab_size then begin
+ a := 0.2 * obj_tab_size;
+ if obj_tab_size < sup_obj_tab_size - a then
+ obj_tab_size := obj_tab_size + a
+ else
+ obj_tab_size := sup_obj_tab_size;
+ obj_tab := xreallocarray(obj_tab, obj_entry, obj_tab_size);
+ end;
+ incr(sys_obj_ptr);
+ obj_ptr := sys_obj_ptr;
+ obj_info(obj_ptr) := i;
+ obj_offset(obj_ptr) := 0;
+ obj_aux(obj_ptr) := 0;
+ avl_put_obj(obj_ptr, t);
+ if t = obj_type_page then begin
+ p := head_tab[t];
+ {find the right position to insert newly created object}@/
+ if (p = 0) or (obj_info(p) < i) then begin
+ obj_link(obj_ptr) := p;
+ head_tab[t] := obj_ptr;
+ end
+ else begin
+ while p <> 0 do begin
+ if obj_info(p) < i then
+ goto done;
+ q := p;
+ p := obj_link(p);
+ end;
+done:
+ obj_link(q) := obj_ptr;
+ obj_link(obj_ptr) := p;
+ end;
+ end
+ else if t <> obj_type_others then begin
+ obj_link(obj_ptr) := head_tab[t];
+ head_tab[t] := obj_ptr;
+ if (t = obj_type_dest) and (i < 0) then
+ append_dest_name(-obj_info(obj_ptr), obj_ptr);
+ end;
+end;
+
+function pdf_new_objnum: integer; {create a new object and return its number}
+begin
+ pdf_create_obj(obj_type_others, 0);
+ pdf_new_objnum := obj_ptr;
+end;
+
+procedure pdf_os_switch(pdf_os: boolean); {switch between PDF stream and object stream mode}
+begin
+ if pdf_os and pdf_os_enable then begin
+ if not pdf_os_mode then begin {back up PDF stream variables}
+ pdf_op_ptr := pdf_ptr;
+ pdf_ptr := pdf_os_ptr;
+ pdf_buf := pdf_os_buf;
+ pdf_buf_size := pdf_os_buf_size;
+ pdf_os_mode := true; {switch to object stream}
+ end;
+ end else begin
+ if pdf_os_mode then begin {back up object stream variables}
+ pdf_os_ptr := pdf_ptr;
+ pdf_ptr := pdf_op_ptr;
+ pdf_buf := pdf_op_buf;
+ pdf_buf_size := pdf_op_buf_size;
+ pdf_os_mode := false; {switch to PDF stream}
+ end;
+ end;
+end;
+
+procedure pdf_os_prepare_obj(i: integer; pdf_os_level: integer); {create new \.{/ObjStm} object
+if required, and set up cross reference info}
+begin
+ pdf_os_switch((pdf_os_level > 0) and (fixed_pdf_objcompresslevel >= pdf_os_level));
+ if pdf_os_mode then begin
+ if pdf_os_cur_objnum = 0 then begin
+ pdf_os_cur_objnum := pdf_new_objnum;
+ decr(obj_ptr); {object stream is not accessible to user}
+ incr(pdf_os_cntr); {only for statistics}
+ pdf_os_objidx := 0;
+ pdf_ptr := 0; {start fresh object stream}
+ end else
+ incr(pdf_os_objidx);
+ obj_os_idx(i) := pdf_os_objidx;
+ obj_offset(i) := pdf_os_cur_objnum;
+ pdf_os_objnum[pdf_os_objidx] := i;
+ pdf_os_objoff[pdf_os_objidx] := pdf_ptr;
+ end else begin
+ obj_offset(i) := pdf_offset;
+ obj_os_idx(i) := -1; {mark it as not included in object stream}
+ end;
+end;
+
+procedure pdf_begin_obj(i: integer; pdf_os_level: integer); {begin a PDF object}
+begin
+ check_pdfminorversion;
+ pdf_os_prepare_obj(i, pdf_os_level);
+ if not pdf_os_mode then begin
+ pdf_print_int(i);
+ pdf_print_ln(" 0 obj");
+ end else if pdf_compress_level = 0 then begin
+ pdf_print("% "); {debugging help}
+ pdf_print_int(i);
+ pdf_print_ln(" 0 obj");
+ end;
+end;
+
+procedure pdf_new_obj(t, i: integer; pdf_os: integer); {begin a new PDF object}
+begin
+ pdf_create_obj(t, i);
+ pdf_begin_obj(obj_ptr, pdf_os);
+end;
+
+procedure pdf_end_obj; {end a PDF object}
+begin
+ if pdf_os_mode then begin
+ if pdf_os_objidx = pdf_os_max_objs - 1 then
+ pdf_os_write_objstream;
+ end else
+ pdf_print_ln("endobj"); {end a PDF object}
+end;
+
+procedure pdf_begin_dict(i: integer; pdf_os_level: integer); {begin a PDF dictionary object}
+begin
+ check_pdfminorversion;
+ pdf_os_prepare_obj(i, pdf_os_level);
+ if not pdf_os_mode then begin
+ pdf_print_int(i);
+ pdf_print(" 0 obj ");
+ end else if pdf_compress_level = 0 then begin
+ pdf_print("% "); {debugging help}
+ pdf_print_int(i);
+ pdf_print_ln(" 0 obj");
+ end;
+ pdf_print_ln("<<");
+end;
+
+procedure pdf_new_dict(t, i: integer; pdf_os: integer); {begin a new PDF dictionary object}
+begin
+ pdf_create_obj(t, i);
+ pdf_begin_dict(obj_ptr, pdf_os);
+end;
+
+procedure pdf_end_dict; {end a PDF dictionary object}
+begin
+ if pdf_os_mode then begin
+ pdf_print_ln(">>");
+ if pdf_os_objidx = pdf_os_max_objs - 1 then
+ pdf_os_write_objstream;
+ end else
+ pdf_print_ln(">> endobj");
+end;
+
+@ Write out an accumulated object stream.
+First the object number and byte offset pairs are generated
+and appended to the ready buffered object stream.
+By this the value of \.{/First} can be calculated.
+Then a new \.{/ObjStm} object is generated, and everything is
+copied to the PDF output buffer, where also compression is done.
+When calling this procedure, |pdf_os_mode| must be |true|.
+
+@<Declare procedures that need to be declared forward for \pdfTeX@>=
+procedure pdf_os_write_objstream;
+var i, j, p, q: pointer;
+begin
+ if pdf_os_cur_objnum = 0 then {no object stream started}
+ return;
+ p := pdf_ptr;
+ i := 0;
+ j := 0;
+ while i <= pdf_os_objidx do begin {assemble object number and byte offset pairs}
+ pdf_print_int(pdf_os_objnum[i]);
+ pdf_print(" ");
+ pdf_print_int(pdf_os_objoff[i]);
+ if j = 9 then begin {print out in groups of ten for better readability}
+ pdf_out(pdf_new_line_char);
+ j := 0;
+ end else begin
+ pdf_print(" ");
+ incr(j);
+ end;
+ incr(i);
+ end;
+ pdf_buf[pdf_ptr - 1] := pdf_new_line_char; {no risk of flush, as we are in |pdf_os_mode|}
+ q := pdf_ptr;
+ pdf_begin_dict(pdf_os_cur_objnum, 0); {switch to PDF stream writing}
+ pdf_print_ln("/Type /ObjStm");
+ pdf_print("/N ");
+ pdf_print_int_ln(pdf_os_objidx + 1);
+ pdf_print("/First ");
+ pdf_print_int_ln(q - p);
+ pdf_begin_stream;
+ pdf_room(q - p); {should always fit into the PDF output buffer}
+ i := p;
+ while i < q do begin {write object number and byte offset pairs}
+ pdf_quick_out(pdf_os_buf[i]);
+ incr(i);
+ end;
+ i := 0;
+ while i < p do begin
+ q := i + pdf_buf_size;
+ if q > p then q := p;
+ pdf_room(q - i);
+ while i < q do begin {write the buffered objects}
+ pdf_quick_out(pdf_os_buf[i]);
+ incr(i);
+ end;
+ end;
+ pdf_end_stream;
+ pdf_os_cur_objnum := 0; {to force object stream generation next time}
+end;
+
+@ @<Declare procedures that need to be declared forward for \pdfTeX@>=
+function append_ptr(p: pointer; i: integer): pointer; {appends a pointer with
+info |i| to the end of linked list with head |p|}
+var q: pointer;
+begin
+ append_ptr := p;
+ fast_get_avail(q);
+ info(q) := i;
+ link(q) := null;
+ if p = null then begin
+ append_ptr := q;
+ return;
+ end;
+ while link(p) <> null do
+ p := link(p);
+ link(p) := q;
+end;
+
+function pdf_lookup_list(p: pointer; i: integer): pointer; {looks up for pointer
+with info |i| in list |p|}
+begin
+ pdf_lookup_list := null;
+ while p <> null do begin
+ if info(p) = i then begin
+ pdf_lookup_list := p;
+ return;
+ end;
+ p := link(p);
+ end;
+end;
+
+@ @<Glob...@>=
+@!pdf_image_procset: integer; {collection of image types used in current page/form}
+@!pdf_text_procset: boolean; {mask of used ProcSet's in the current page/form}
+
+@ Subroutines to print out various PDF objects
+
+@p procedure pdf_print_fw_int(n, w: integer); {print out an integer with
+fixed width; used for outputting cross-reference table}
+var k: integer; {$0\le k\le23$}
+begin
+ k := 0;
+ repeat dig[k] := n mod 10; n := n div 10; incr(k);
+ until k = w;
+ pdf_room(k);
+ while k > 0 do begin
+ decr(k);
+ pdf_quick_out("0" + dig[k]);
+ end;
+end;
+
+procedure pdf_out_bytes(n, w: integer); {print out an integer as
+a number of bytes; used for outputting \.{/XRef} cross-reference stream}
+var k: integer;
+byte: array[0..3] of integer; {digits in a number being output}
+begin
+ k := 0;
+ repeat byte[k] := n mod 256; n := n div 256; incr(k);
+ until k = w;
+ pdf_room(k);
+ while k > 0 do begin
+ decr(k);
+ pdf_quick_out(byte[k]);
+ end;
+end;
+
+procedure pdf_int_entry(s: str_number; v: integer); {print out an entry in
+dictionary with integer value to PDF buffer}
+begin
+ pdf_out("/");
+ pdf_print(s);
+ pdf_out(" ");
+ pdf_print_int(v);
+end;
+
+procedure pdf_int_entry_ln(s: str_number; v: integer);
+begin
+ pdf_int_entry(s, v);
+ pdf_print_nl;
+end;
+
+procedure pdf_indirect(s: str_number; o: integer); {print out an indirect
+entry in dictionary}
+begin
+ pdf_out("/");
+ pdf_print(s);
+ pdf_out(" ");
+ pdf_print_int(o);
+ pdf_print(" 0 R");
+end;
+
+procedure pdf_indirect_ln(s: str_number; o: integer);
+begin
+ pdf_indirect(s, o);
+ pdf_print_nl;
+end;
+
+procedure pdf_print_str_ln(s: str_number); {print out |s| as string in PDF
+output}
+begin
+ pdf_print_str(s);
+ pdf_print_nl;
+end;
+
+procedure pdf_str_entry(s, v: str_number); {print out an entry in
+dictionary with string value to PDF buffer}
+begin
+ if v = 0 then
+ return;
+ pdf_out("/");
+ pdf_print(s);
+ pdf_out(" ");
+ pdf_print_str(v);
+end;
+
+procedure pdf_str_entry_ln(s, v: str_number);
+begin
+ if v = 0 then
+ return;
+ pdf_str_entry(s, v);
+ pdf_print_nl;
+end;
+
+@* \[32e] Font processing.
+
+As \pdfTeX{} should also act as a back-end driver, it needs to support virtual
+fonts too. Information about virtual fonts can be found in the source of some
+\.{DVI}-related programs.
+
+Whenever we want to write out a character in a font to PDF output, we
+should check whether the used character is a virtual or read character.
+The |has_packet()| C macro checks for this condition.
+
+@ The following code typesets a character to PDF output.
+
+@p procedure output_one_char(ffi:internal_font_number;c:integer);
+begin
+ if has_packet(ffi,c) then
+ do_vf_packet(ffi, c)
+ else begin
+ pdf_begin_string(ffi);
+ pdf_print_char(ffi, c);
+ adv_char_width(ffi, c);
+ end;
+end;
+
+@ @<Declare procedures that need to be declared forward for \pdfTeX@>=
+procedure pdf_check_vf_cur_val; forward;
+procedure pdf_create_font_obj; forward;
+procedure pdf_init_font_cur_val; forward;
+procedure scan_pdf_ext_toks; forward;
+
+@ Here come some subroutines to deal with expanded fonts for HZ-algorithm.
+
+@d set_char_and_font(#) ==
+if is_char_node(#) then begin
+ c := character(#);
+ f := font(#);
+end
+
+@p
+function get_default_hyphen_char:integer;
+begin
+ get_default_hyphen_char:=default_hyphen_char;
+end;
+@#
+function get_default_skew_char:integer;
+begin
+ get_default_skew_char:=default_skew_char;
+end;
+@#
+
+procedure copy_expand_params(k, f: internal_font_number; e: integer);
+{set expansion-related parameters for an expanded font |k|, based on the base
+font |f| and the expansion amount |e|}
+begin
+ set_pdf_font_expand_ratio(k,e);
+ set_pdf_font_step(k,pdf_font_step(f));
+ set_pdf_font_auto_expand(k, pdf_font_auto_expand(f));
+ set_pdf_font_blink(k,f);
+end;
+
+function tfm_lookup(s: str_number; fs: scaled): internal_font_number;
+{looks up for a TFM with name |s| loaded at |fs| size; if found then flushes |s|}
+label exit;
+var k: internal_font_number;
+begin
+ if fs <> 0 then begin
+ for k := 1 to max_font_id do
+ if cmp_font_name(k, s) and (font_size(k) = fs) then begin
+ flush_str(s);
+ tfm_lookup := k;
+ return;
+ end;
+ end
+ else begin
+ for k := 1 to max_font_id do
+ if cmp_font_name(k, s) then begin
+ flush_string; {|font_name|}
+ flush_str(s);
+ tfm_lookup := k;
+ return;
+ end else flush_string;
+ end;
+ tfm_lookup := null_font;
+exit:
+end;
+
+function load_expand_font(f: internal_font_number; e: integer): internal_font_number;
+{loads font |f| expanded by |e| thousandths into font memory; |e| is nonzero
+and is a multiple of |pdf_font_step(f)|}
+label found;
+var s: str_number; {font name}
+ k: internal_font_number;
+begin
+ s := expand_font_name(f, e);
+ k := tfm_lookup(s, font_size(f));
+ if k = null_font then begin
+ if pdf_font_auto_expand(f) then begin
+ k := auto_expand_font(f, e);
+ font_id_text(k) := font_id_text(f);
+ end
+ else
+ k := read_font_info(null_cs, s, "", font_size(f), font_natural_dir(f));
+ end;
+ copy_expand_params(k, f, e);
+ load_expand_font := k;
+end;
+
+function fix_expand_value(f: internal_font_number; e: integer): integer;
+{return the multiple of |pdf_font_step(f)| that is nearest to |e|}
+var step: integer;
+ max_expand: integer;
+ neg: boolean;
+begin
+ fix_expand_value := 0;
+ if e = 0 then
+ return;
+ if e < 0 then begin
+ e := -e;
+ neg := true;
+ max_expand := -pdf_font_expand_ratio(pdf_font_shrink(f));
+ end
+ else begin
+ neg := false;
+ max_expand := pdf_font_expand_ratio(pdf_font_stretch(f));
+ end;
+ if e > max_expand then
+ e := max_expand
+ else begin
+ step := pdf_font_step(f);
+ if e mod step > 0 then
+ e := step*round_xn_over_d(e, 1, step);
+ end;
+ if neg then
+ e := -e;
+ fix_expand_value := e;
+end;
+
+function get_expand_font(f: internal_font_number; e: integer): internal_font_number;
+{look up and create if not found an expanded version of |f|; |f| is an
+expandable font; |e| is nonzero and is a multiple of |pdf_font_step(f)|}
+var k: internal_font_number;
+begin
+ k := pdf_font_elink(f);
+ while k <> null_font do begin
+ if pdf_font_expand_ratio(k) = e then begin
+ get_expand_font := k;
+ return;
+ end;
+ k := pdf_font_elink(k);
+ end;
+ k := load_expand_font(f, e);
+ set_pdf_font_elink(k,pdf_font_elink(f));
+ set_pdf_font_elink(f,k);
+ {|wterm_ln('get_expand_font ', e:1, ': ',f:1, ' became ', k:1);|}
+ get_expand_font := k;
+end;
+
+function expand_font(f: internal_font_number; e: integer): internal_font_number;
+{looks up for font |f| expanded by |e| thousandths, |e| is an arbitrary value
+between max stretch and max shrink of |f|; if not found then creates it}
+begin
+ expand_font := f;
+ if e = 0 then
+ return;
+ e := fix_expand_value(f, e);
+ if e = 0 then
+ return;
+ if pdf_font_elink(f) = null_font then
+ pdf_error("font expansion", "uninitialized pdf_font_elink");
+ expand_font := get_expand_font(f, e);
+end;
+
+procedure set_expand_params(f: internal_font_number; auto_expand: boolean;
+ font_stretch, font_shrink, font_step, expand_ratio: integer);
+{expand a font with given parameters}
+begin
+ set_pdf_font_step(f, font_step);
+ set_pdf_font_auto_expand(f, auto_expand);
+ if font_stretch > 0 then
+ set_pdf_font_stretch(f,get_expand_font(f, font_stretch));
+ if font_shrink > 0 then
+ set_pdf_font_shrink(f, get_expand_font(f, -font_shrink));
+ if expand_ratio <> 0 then
+ set_pdf_font_expand_ratio(f,expand_ratio);
+end;
+
+procedure read_expand_font; {read font expansion spec and load expanded font}
+var font_shrink, font_stretch, font_step: integer;
+ f: internal_font_number;
+ auto_expand: boolean;
+begin
+ {read font expansion parameters}
+ scan_font_ident;
+ f := cur_val;
+ if f = null_font then
+ pdf_error("font expansion", "invalid font identifier");
+ if pdf_font_blink(f) <> null_font then
+ pdf_error("font expansion", "\pdffontexpand cannot be used this way (the base font has been expanded or letter-spaced)");
+ scan_optional_equals;
+ scan_int;
+ font_stretch := fix_int(cur_val, 0, 1000);
+ scan_int;
+ font_shrink := fix_int(cur_val, 0, 500);
+ scan_int;
+ font_step := fix_int(cur_val, 0, 100);
+ if font_step = 0 then
+ pdf_error("font expansion", "invalid step");
+ font_stretch := font_stretch - font_stretch mod font_step;
+ if font_stretch < 0 then
+ font_stretch := 0;
+ font_shrink := font_shrink - font_shrink mod font_step;
+ if font_shrink < 0 then
+ font_shrink := 0;
+ if (font_stretch = 0) and (font_shrink = 0) then
+ pdf_error("font expansion", "invalid limit(s)");
+ auto_expand := false;
+ if scan_keyword("autoexpand") then begin
+ auto_expand := true;
+ @<Scan an optional space@>;
+ end;
+
+ {check if the font can be expanded}
+ if (pdf_font_expand_ratio(f) <> 0) then
+ pdf_error("font expansion", "this font has been expanded by another font so it cannot be used now");
+ if (pdf_font_step(f) <> 0) then
+ {this font has been expanded, ensure the expansion parameters are identical}
+ begin
+ if (pdf_font_step(f) <> font_step) or
+ ((pdf_font_stretch(f) = null_font) and (font_stretch <> 0)) or
+ ((pdf_font_stretch(f) <> null_font) and
+ (pdf_font_expand_ratio(pdf_font_stretch(f)) <> font_stretch)) or
+ ((pdf_font_shrink(f) = null_font) and (font_shrink <> 0)) or
+ ((pdf_font_shrink(f) <> null_font) and
+ (pdf_font_expand_ratio(pdf_font_shrink(f)) <> -font_shrink)) or
+ (pdf_font_auto_expand(f) <> auto_expand)
+ then
+ pdf_error("font expansion", "font has been expanded with different parameters");
+ end
+ else begin
+ if font_used(f) then
+ pdf_warning("font expansion", "font should be expanded before its first use",
+ true, true);
+ set_expand_params(f, auto_expand, font_stretch, font_shrink, font_step, 0);
+ if font_type(f) = virtual_font_type then
+ vf_expand_local_fonts(f);
+ end;
+end;
+
+procedure new_letterspaced_font(a: small_number);
+{letter-space a font by creating a virtual font}
+var u:pointer; {user's font identifier}
+@!t:str_number; {name for the frozen font identifier}
+@!old_setting:0..max_selector; {holds |selector| setting}
+@!f, k:internal_font_number;
+begin
+ get_r_token; u:=cur_cs;
+ if u>=hash_base then t:=text(u)
+ else if u=null_cs then t:="FONT"
+ else begin old_setting:=selector; selector:=new_string;
+ print("FONT"); print(u-active_base); selector:=old_setting;
+ @.FONTx@>
+ str_room(1); t:=make_string;
+ end;
+ define(u,set_font,null_font); scan_optional_equals; scan_font_ident;
+ k := cur_val;
+ scan_int;
+ f := letter_space_font(u, k, fix_int(cur_val, -1000, 1000));
+ equiv(u):=f; eqtb[font_id_base+f]:=eqtb[u]; font_id_text(f):=t;
+end;
+
+@ We need to hold information about used characters in each font for partial
+downloading.
+
+@<Types...@>=
+char_map_array = array[0..32] of eight_bits; {move chars in range 0..32}
+fm_entry_ptr = ^integer;
+
+@ @<Glob...@>=
+@!pdf_font_list: pointer; {list of used fonts in current page}
+@!pdf_resname_prefix: str_number; {global prefix of resources name}
+@!last_tokens_string: str_number; {the number of the most recently string
+created by |tokens_to_string|}
+
+@ @<Set init...@>=
+pdf_resname_prefix := 0;
+last_tokens_string := 0;
+
+@ Reading VF files is done in C, using the procedure |do_vf()|
+
+@* \[32f] PDF shipping out.
+To ship out a \TeX\ box to PDF page description we need to implement
+|pdf_hlist_out|, |pdf_vlist_out| and |pdf_ship_out|, which are equivalent to
+the \TeX' original |hlist_out|, |vlist_out| and |ship_out| resp. But first we
+need to declare some procedures needed in |pdf_hlist_out| and |pdf_vlist_out|.
+
+@<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure pdf_out_literal(p:pointer);
+var old_setting:0..max_selector; {holds print |selector|}
+ s: str_number;
+begin
+ old_setting:=selector; selector:=new_string;
+ show_token_list(link(pdf_literal_data(p)),null,pool_size-pool_ptr);
+ selector:=old_setting;
+ s := make_string;
+ literal(s, pdf_literal_mode(p), false);
+ flush_str(s);
+end;
+
+procedure pdf_out_colorstack(p:pointer);
+var old_setting: 0..max_selector; {holds print |selector|}
+ s: str_number;
+ cmd: integer;
+ stack_no: integer;
+ literal_mode: integer;
+begin
+ cmd := pdf_colorstack_cmd(p);
+ stack_no := pdf_colorstack_stack(p);
+ literal_mode := 0;
+ if stack_no >= colorstackused then begin
+ print_nl("");
+ print("Color stack ");
+ print_int(stack_no);
+ print(" is not initialized for use!");
+ print_nl("");
+ return;
+ end;
+ case cmd of
+ colorstack_set, colorstack_push: begin
+ old_setting:=selector; selector:=new_string;
+ show_token_list(link(pdf_colorstack_data(p)),null,pool_size-pool_ptr);
+ selector:=old_setting;
+ s := make_string;
+ if cmd = colorstack_set then
+ literal_mode := colorstackset(stack_no, s)
+ else
+ literal_mode := colorstackpush(stack_no, s);
+ if length(s) > 0 then
+ literal(s, literal_mode, false);
+ flush_str(s);
+ return;
+ end;
+ colorstack_pop: literal_mode := colorstackpop(stack_no);
+ colorstack_current: literal_mode := colorstackcurrent(stack_no);
+ othercases do_nothing
+ endcases;
+ if cur_length > 0 then begin
+ s := make_string;
+ literal(s, literal_mode, false);
+ flush_str(s);
+ end
+end;
+
+procedure pdf_out_colorstack_startpage;
+var i: integer;
+ max: integer;
+ start_status: integer;
+ literal_mode: integer;
+ s: str_number;
+begin
+ i := 0;
+ max := colorstackused;
+ while i < max do begin
+ start_status := colorstackskippagestart(i);
+ if start_status = 0 then begin
+ literal_mode := colorstackcurrent(i);
+ if cur_length > 0 then begin
+ s := make_string;
+ literal(s, literal_mode, false);
+ flush_str(s);
+ end;
+ end;
+ incr(i);
+ end;
+end;
+
+procedure pdf_out_setmatrix(p:pointer);
+var old_setting:0..max_selector; {holds print |selector|}
+ s: str_number;
+begin
+ old_setting:=selector; selector:=new_string;
+ show_token_list(link(pdf_setmatrix_data(p)),null,pool_size-pool_ptr);
+ selector:=old_setting;
+ str_room(7);
+ str_pool[pool_ptr] := 0; { make C string for pdfsetmatrix }
+ pdfsetmatrix(str_start[str_ptr], cur_h, cur_page_height - cur_v);
+ str_room(7);
+ append_char(" ");
+ append_char("0");
+ append_char(" ");
+ append_char("0");
+ append_char(" ");
+ append_char("c");
+ append_char("m");
+ s := make_string;
+ literal(s, set_origin, false);
+ flush_str(s);
+end;
+
+procedure pdf_out_save;
+begin
+ checkpdfsave(cur_h, cur_v);
+ literal("q", set_origin, false);
+end;
+
+procedure pdf_out_restore;
+begin
+ checkpdfrestore(cur_h, cur_v);
+ literal("Q", set_origin, false);
+end;
+
+procedure pdf_special(p: pointer);
+var old_setting:0..max_selector; {holds print |selector|}
+ s: str_number;
+begin
+ old_setting:=selector; selector:=new_string;
+ show_token_list(link(write_tokens(p)),null,pool_size-pool_ptr);
+ selector:=old_setting;
+ s := make_string;
+ literal(s, scan_special, true);
+ flush_str(s);
+end;
+
+procedure do_late_lua(p: pointer);
+var old_setting:0..max_selector; {holds print |selector|}
+ s: str_number;
+begin
+ old_setting:=selector; selector:=new_string;
+ show_token_list(link(late_lua_data(p)),null,pool_size-pool_ptr);
+ selector:=old_setting;
+ s := make_string;
+ latelua(late_lua_reg(p), s);
+ flush_str(s);
+end;
+
+procedure pdf_print_toks(p: pointer); {print tokens list |p|}
+var s: str_number;
+begin
+ s := tokens_to_string(p);
+ if length(s) > 0 then
+ pdf_print(s);
+ flush_str(s);
+end;
+
+procedure pdf_print_toks_ln(p: pointer); {print tokens list |p|}
+var s: str_number;
+begin
+ s := tokens_to_string(p);
+ if length(s) > 0 then begin
+ pdf_print_ln(s);
+ end;
+ flush_str(s);
+end;
+
+@ Similiar to |vlist_out|, |pdf_vlist_out| needs to be declared forward
+
+@p procedure@?pdf_vlist_out; forward;
+
+@ The implementation of procedure |pdf_hlist_out| is similiar to |hlist_out|
+
+@p @t\4@>@<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>@t@>@/
+
+procedure pdf_hlist_out; {output an |hlist_node| box}
+label move_past, fin_rule, next_p;
+var base_line: scaled; {the baseline coordinate for this box}
+c_wd,c_ht,c_dp: scaled;
+ {the real width, height and depth of the character}
+w: scaled; { temporary value for directional width calculation }
+dir_nest: integer; { for tracking nested direction nodes }
+edge_v: scaled;
+edge_h: scaled;
+effective_horizontal: scaled;
+basepoint_horizontal: scaled;
+basepoint_vertical: scaled;
+saving_h: scaled;
+saving_v: scaled;
+save_direction: integer;
+dvi_ptr,dir_ptr,dir_tmp:pointer;
+@!left_edge: scaled; {the left coordinate for this box}
+@!save_h: scaled; {what |cur_h| should pop to}
+@!this_box: pointer; {pointer to containing box}
+@!g_order: glue_ord; {applicable order of infinity for glue}
+@!g_sign: normal..shrinking; {selects type of glue}
+@!p,q:pointer; {current position in the hlist}
+@!leader_box:pointer; {the leader box being replicated}
+@!leader_wd:scaled; {width of leader box being replicated}
+@!lx:scaled; {extra space between leader boxes}
+@!outer_doing_leaders:boolean; {were we doing leaders?}
+@!edge:scaled; {right edge of sub-box or leader space}
+@!prev_p:pointer; {one step behind |p|}
+@!glue_temp:real; {glue value before rounding}
+@!cur_glue:real; {glue seen so far}
+@!save_cur_glue:real; { saved version, for direction switch }
+@!cur_g:scaled; {rounded equivalent of |cur_glue| times the glue ratio}
+@!save_cur_g:scaled; { saved version, for direction switch }
+@!i: small_number; {index to scan |pdf_link_stack|}
+begin cur_g:=0; cur_glue:=float_constant(0);
+this_box:=temp_ptr; g_order:=glue_order(this_box);
+g_sign:=glue_sign(this_box); p:=list_ptr(this_box);
+save_direction:=dvi_direction;
+dvi_direction:=box_dir(this_box);
+dvi_ptr:=0; lx:=0;
+@<DIR: Initialize |dir_ptr| for |ship_out|@>;
+saving_h:=cur_h; saving_v:=cur_v;
+incr(cur_s);
+base_line:=cur_v;
+left_edge:=cur_h;
+prev_p:=this_box+list_offset;
+@<Create link annotations for the current hbox if needed@>;
+while p<>null do
+ @<Output node |p| for |pdf_hlist_out| and move to the next node,
+ maintaining the condition |cur_v=base_line|@>;
+cur_h:=saving_h; cur_v:=saving_v;
+decr(cur_s);
+dvi_direction:=save_direction;
+@<DIR: Reset |dir_ptr|@>;
+end;
+
+@ @<Create link annotations for the current hbox if needed@>=
+for i := 1 to pdf_link_stack_ptr do begin
+ pdfassert(is_running(pdf_width(pdf_link_stack[i].link_node)));
+ if (pdf_link_stack[i].nesting_level = cur_s) then
+ append_link(this_box, left_edge, base_line, i);
+end
+
+@
+
+@d pdf_dvicmd_set(#)==output_one_char(f,#)
+@d pdf_dvicmd_put(#)==output_one_char(f,#); cur_h:=cur_h-c_wd
+@d pdf_dvicmd_right(#)==cur_h := cur_h + #
+@d pdf_dvicmd_left(#)== cur_h := cur_h - #
+@d pdf_dvicmd_down(#)== cur_v := cur_v - #
+@d pdf_dvicmd_up(#)== cur_v := cur_v + #
+@d pdf_dvicmd_h(#)==case box_direction(dvi_direction) of
+ dir_TL_: begin cur_h := cur_h + #; end;
+ dir_TR_: begin cur_h := cur_h - #; end;
+ dir_LT_: begin do_nothing; {if o=right1 then o:=down1 else o:=right1;} end;
+ dir_LB_: begin do_nothing; {if o=right1 then begin o:=down1; negate(w); end else o:=right1;} end;
+ dir_BL_: begin do_nothing; {if o=down1 then negate(w); } end;
+ dir_BR_: begin do_nothing; { negate(w);} end;
+ dir_RT_: begin do_nothing; {if o=right1 then o:=down1 else begin o:=right1; negate(w); end;} end;
+ dir_RB_: begin do_nothing; {if o=right1 then o:=down1 else o:=right1; negate(w);} end;
+ end
+
+
+@<Output node |p| for |pdf_hlist_out|...@>=
+begin
+if is_char_node(p) then
+ begin
+ repeat f:=font(p); c:=character(p);
+ ci := char_info_short (f,c);
+ {|writeln('hlist_out: a char node ', c:1 , ' in font ',f:1);|}
+ if is_valid_char(c) then begin
+ if is_rotated(dvi_direction) then begin
+ c_ht:=charinfo_width(ci) div 2;
+ c_dp:=0;
+ c_wd:=charinfo_height(ci)+charinfo_depth(ci);
+ end
+ else begin
+ c_ht:=charinfo_height(ci);
+ c_dp:=charinfo_depth(ci);
+ c_wd:=charinfo_width(ci);
+ end;
+ if (font_natural_dir(f)<>-1) then
+ case font_direction(dvi_direction) of
+ dir__LT,dir__LB: begin
+ if x_displace(p)<>0 then pdf_dvicmd_right(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_up(-y_displace(p));
+ pdf_dvicmd_set(c);
+ if x_displace(p)<>0 then pdf_dvicmd_left(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_down(-y_displace(p));
+ end;
+ dir__RT,dir__RB: begin
+ if x_displace(p)<>0 then pdf_dvicmd_left(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_up(-y_displace(p));
+ pdf_dvicmd_left(c_wd);
+ pdf_dvicmd_put(c);
+ if x_displace(p)<>0 then pdf_dvicmd_right(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_down(-y_displace(p));
+ end;
+ dir__TL,dir__TR: begin
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_down(c_wd);
+ end;
+ dir__BL,dir__BR: begin
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_up(c_wd);
+ end;
+ dir__LL,dir__LR: begin
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_wd);
+ end;
+ dir__RL,dir__RR: begin
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_left(c_wd);
+ end;
+ dir__TT,dir__TB: begin
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_down(c_wd);
+ end;
+ dir__BT,dir__BB: begin
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_up(c_wd);
+ end;
+ end
+ else
+ case font_direction(dvi_direction) of
+ dir__LT: begin
+ if x_displace(p)<>0 then pdf_dvicmd_right(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_up(-y_displace(p));
+ pdf_dvicmd_set(c);
+ if x_displace(p)<>0 then pdf_dvicmd_left(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_down(-y_displace(p));
+ end;
+ dir__LB: begin
+ pdf_dvicmd_down(c_ht);
+ pdf_dvicmd_set(c);
+ pdf_dvicmd_up(c_ht);
+ end;
+ dir__RT: begin
+ if x_displace(p)<>0 then pdf_dvicmd_left(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_up(-y_displace(p));
+ pdf_dvicmd_left(c_wd);
+ pdf_dvicmd_put(c);
+ if x_displace(p)<>0 then pdf_dvicmd_right(x_displace(p));
+ if y_displace(p)<>0 then pdf_dvicmd_down(-y_displace(p));
+ end;
+ dir__RB: begin
+ pdf_dvicmd_left(c_wd);
+ pdf_dvicmd_down(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_up(c_ht);
+ end;
+ dir__TL: begin
+ pdf_dvicmd_down(c_wd);
+ pdf_dvicmd_left(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_ht);
+ end;
+ dir__TR: begin
+ pdf_dvicmd_down(c_wd);
+ pdf_dvicmd_left(c_dp);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_dp);
+ end;
+ dir__BL: begin
+ pdf_dvicmd_left(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_ht);
+ pdf_dvicmd_up(c_wd);
+ end;
+ dir__BR: begin
+ pdf_dvicmd_left(c_dp);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_dp);
+ pdf_dvicmd_up(c_wd);
+ end;
+ dir__LL,dir__LR: begin
+ pdf_dvicmd_down(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_up(c_ht);
+ pdf_dvicmd_right(c_wd);
+ end;
+ dir__RL,dir__RR: begin
+ pdf_dvicmd_left(c_wd);
+ pdf_dvicmd_down(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_up(c_ht);
+ end;
+ dir__TT,dir__TB: begin
+ pdf_dvicmd_down(c_wd);
+ pdf_dvicmd_left(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_ht);
+ end;
+ dir__BT,dir__BB: begin
+ pdf_dvicmd_left(c_ht);
+ pdf_dvicmd_put(c);
+ pdf_dvicmd_right(c_ht);
+ pdf_dvicmd_up(c_wd);
+ end;
+ end;
+ cur_h:=cur_h+c_wd;
+ end
+ else
+ char_warning(f, c);
+ prev_p:=p;
+ p:=vlink(p);
+ until not is_char_node(p);
+ end
+else @<Output the non-|char_node| |p| for |pdf_hlist_out|
+ and move to the next node@>;
+end
+
+@ @<Output the non-|char_node| |p| for |pdf_hlist_out|...@>=
+begin case type(p) of
+hlist_node,vlist_node:@<(\pdfTeX) Output a box in an hlist@>;
+disc_node: if vlink(no_break(p))<>null then begin
+ q:=tail_of_list (vlink(no_break(p))); {TODO, this should be a tlink}
+ vlink(q):=vlink(p);
+ q:=vlink(no_break(p));
+ vlink(no_break(p)):=null;
+ vlink(p):=q;
+ end;
+rule_node: begin
+ if not (dir_orthogonal(dir_primary[rule_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ rule_ht:=height(p); rule_dp:=depth(p); rule_wd:=width(p);
+ end
+ else begin
+ rule_ht:=width(p) div 2;
+ rule_dp:=width(p) div 2;
+ rule_wd:=height(p)+depth(p);
+ end;
+ goto fin_rule;
+ end;
+whatsit_node: @<Output the whatsit node |p| in |pdf_hlist_out|@>;
+glue_node: @<(\pdfTeX) Move right or output leaders@>;
+margin_kern_node,kern_node: pdf_dvicmd_h(width(p));
+math_node: pdf_dvicmd_h(surround(p));
+othercases do_nothing
+endcases;@/
+goto next_p;
+fin_rule: @<(\pdfTeX) Output a rule in an hlist@>;
+move_past: pdf_dvicmd_h(rule_wd);
+next_p:prev_p:=p; p:=vlink(p);
+end
+
+@ @<(\pdfTeX) Output a box in an hlist@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ effective_horizontal:=width(p);
+ basepoint_vertical:=0;
+ if dir_opposite(dir_secondary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=width(p)
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ effective_horizontal:=height(p)+depth(p);
+ if not (is_mirrored(box_dir(p))) then
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(p)
+ else
+ basepoint_horizontal:=depth(p)
+ else
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(p)
+ else
+ basepoint_horizontal:=height(p);
+ if dir_eq(dir_secondary[box_dir(p)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:= -(width(p) div 2)
+ else
+ basepoint_vertical:= (width(p) div 2);
+ end;
+if not (is_mirrored(dvi_direction)) then
+ basepoint_vertical := basepoint_vertical + shift_amount(p)
+ {shift the box `down'}
+else
+ basepoint_vertical := basepoint_vertical - shift_amount(p);
+ {shift the box `up'}
+if list_ptr(p)=null then begin pdf_dvicmd_h(effective_horizontal); end
+else begin
+ temp_ptr:=p;
+ edge:=cur_h; pdf_dvicmd_h(basepoint_horizontal);
+ edge_v:=cur_v; cur_v:=base_line + basepoint_vertical;
+ if type(p)=vlist_node then pdf_vlist_out@+else pdf_hlist_out;
+ cur_h:=edge; pdf_dvicmd_h(effective_horizontal);
+ cur_v:=base_line;
+ end
+end
+
+@ @<(\pdfTeX) Output a rule in an hlist@>=
+if is_running(rule_ht) then rule_ht:=height(this_box);
+if is_running(rule_dp) then rule_dp:=depth(this_box);
+rule_ht:=rule_ht+rule_dp; {this is the rule thickness}
+if (rule_ht>0)and(rule_wd>0) then {we don't output empty rules}
+ begin cur_v:=base_line+rule_dp;
+ case font_direction(dvi_direction) of
+ dir__LT: begin
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ end;
+ dir__LB: begin
+ pdf_dvicmd_down(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_up(rule_ht);
+ end;
+ dir__RT: begin
+ pdf_dvicmd_left(rule_wd);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_right(rule_wd);
+ end;
+ dir__RB: begin
+ pdf_dvicmd_left(rule_wd);
+ pdf_dvicmd_down(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_wd);
+ pdf_dvicmd_up(rule_ht);
+ end;
+ dir__TL: begin
+ pdf_dvicmd_down(rule_wd);
+ pdf_dvicmd_left(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ end;
+ dir__TR: begin
+ pdf_dvicmd_down(rule_wd);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_ht);
+ end;
+ dir__BL: begin
+ pdf_dvicmd_left(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_up(rule_wd);
+ end;
+ dir__BR: begin
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_ht);
+ pdf_dvicmd_up(rule_wd);
+ end;
+ end;
+ {|cur_h:=cur_h+rule_wd;|}{|dir__RT| is corrected elsewhere}
+ cur_v:=base_line;
+ end
+
+@ @<(\pdfTeX) Move right or output leaders@>=
+begin g:=glue_ptr(p); rule_wd:=width(g)-cur_g;
+if g_sign<>normal then
+ begin if g_sign=stretching then
+ begin if stretch_order(g)=g_order then
+ begin cur_glue:=cur_glue+stretch(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+@^real multiplication@>
+ cur_g:=round(glue_temp);
+ end;
+ end
+ else if shrink_order(g)=g_order then
+ begin cur_glue:=cur_glue-shrink(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+ cur_g:=round(glue_temp);
+ end;
+ end;
+rule_wd:=rule_wd+cur_g;
+if subtype(p)>=a_leaders then
+ @<(\pdfTeX) Output leaders in an hlist, |goto fin_rule| if a rule
+ or to |next_p| if done@>;
+goto move_past;
+end
+
+@ @<(\pdfTeX) Output leaders in an hlist...@>=
+begin leader_box:=leader_ptr(p);
+if type(leader_box)=rule_node then
+ begin rule_ht:=height(leader_box); rule_dp:=depth(leader_box);
+ goto fin_rule;
+ end;
+if not (dir_orthogonal(dir_primary[box_dir(leader_box)])(dir_primary[dvi_direction]))
+ then leader_wd:=width(leader_box)
+else
+ leader_wd:=height(leader_box)+depth(leader_box);
+if (leader_wd>0)and(rule_wd>0) then
+ begin
+ edge:=cur_h+rule_wd;
+ {TODO this double |case| is a hack, and not quite the proper
+ solution, but it produces the correct output for |xleaders|
+ in TRT mode, which is important for KASHIDAH fills.}
+ case box_direction(dvi_direction) of
+ dir_TR_,dir_RT_: begin
+ edge:=cur_h;
+ cur_h:=cur_h-rule_wd;
+ end;
+ end;
+ @<Let |cur_h| be the position of the first box, and set |leader_wd+lx|
+ to the spacing between corresponding parts of boxes@>;
+ while cur_h+leader_wd<=edge do
+ @<(\pdfTeX) Output a leader box at |cur_h|,
+ then advance |cur_h| by |leader_wd+lx|@>;
+ case box_direction(dvi_direction) of
+ dir_TR_,dir_RT_: cur_h:=cur_h-rule_wd;
+ end;
+ goto next_p;
+ end;
+end
+
+@ @<(\pdfTeX) Output a leader box at |cur_h|, ...@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(leader_box)])(dir_primary[dvi_direction]))
+ then begin
+ basepoint_vertical:=0;
+ if dir_opposite(dir_secondary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then begin
+ basepoint_horizontal:=width(leader_box)
+ end
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ if not (is_mirrored(box_dir(leader_box))) then
+ if dir_eq(dir_primary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(leader_box)
+ else
+ basepoint_horizontal:=depth(leader_box)
+ else
+ if dir_eq(dir_primary[box_dir(leader_box)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(leader_box)
+ else
+ basepoint_horizontal:=height(leader_box);
+ if dir_eq(dir_secondary[box_dir(leader_box)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:= -(width(leader_box) div 2)
+ else
+ basepoint_vertical:= (width(leader_box) div 2);
+ end;
+if not (is_mirrored(dvi_direction)) then
+ basepoint_vertical := basepoint_vertical + shift_amount(leader_box)
+ {shift the box `down'}
+else
+ basepoint_vertical := basepoint_vertical - shift_amount(leader_box);
+ {shift the box `up'}
+temp_ptr:=leader_box;
+edge_h:=cur_h; cur_h:=cur_h + basepoint_horizontal;
+edge_v:=cur_v; cur_v:=base_line + basepoint_vertical;
+outer_doing_leaders:=doing_leaders; doing_leaders:=true;
+if type(leader_box)=vlist_node then pdf_vlist_out@+else pdf_hlist_out;
+doing_leaders:=outer_doing_leaders;
+cur_h:=edge_h+leader_wd+lx; cur_v:=base_line;
+end
+
+@ The |pdf_vlist_out| routine is similar to |pdf_hlist_out|, but a bit simpler.
+@p procedure pdf_vlist_out; {output a |pdf_vlist_node| box}
+label move_past, fin_rule, next_p;
+var left_edge: scaled; {the left coordinate for this box}
+@!top_edge: scaled; {the top coordinate for this box}
+@!save_v: scaled; {what |cur_v| should pop to}
+@!this_box: pointer; {pointer to containing box}
+@!g_order: glue_ord; {applicable order of infinity for glue}
+@!g_sign: normal..shrinking; {selects type of glue}
+@!p:pointer; {current position in the vlist}
+@!leader_box:pointer; {the leader box being replicated}
+@!leader_ht:scaled; {height of leader box being replicated}
+@!lx:scaled; {extra space between leader boxes}
+@!outer_doing_leaders:boolean; {were we doing leaders?}
+@!edge:scaled; {bottom boundary of leader space}
+@!glue_temp:real; {glue value before rounding}
+@!cur_glue:real; {glue seen so far}
+@!cur_g:scaled; {rounded equivalent of |cur_glue| times the glue ratio}
+@!save_direction: integer;
+@!effective_vertical: scaled;
+@!basepoint_horizontal: scaled;
+@!basepoint_vertical: scaled;
+@!edge_v: scaled;
+@!saving_v: scaled;
+@!saving_h: scaled;
+begin cur_g:=0; cur_glue:=float_constant(0);
+this_box:=temp_ptr; g_order:=glue_order(this_box);
+g_sign:=glue_sign(this_box); p:=list_ptr(this_box);
+{pdfassert(p<>0);}
+saving_v:=cur_v; saving_h:=cur_h;
+{|writeln(''); writeln('vlist_out: left edge: ', cur_h:1 , '');|}
+save_direction:=dvi_direction;
+dvi_direction:=box_dir(this_box);
+incr(cur_s);
+left_edge:=cur_h; cur_v:=cur_v-height(this_box); top_edge:=cur_v;
+@<Create thread for the current vbox if needed@>;
+while p<>null do
+ @<Output node |p| for |pdf_vlist_out| and move to the next node,
+ maintaining the condition |cur_h=left_edge|@>;
+cur_v:=saving_v; cur_h:=saving_h;
+decr(cur_s);
+dvi_direction:=save_direction;
+end;
+
+@ @<Create thread for the current vbox if needed@>=
+if (last_thread <> null) and is_running(pdf_thread_dp) and
+ (pdf_thread_level = cur_s) then
+ append_thread(this_box, left_edge, top_edge + height(this_box))
+
+@ @<Output node |p| for |pdf_vlist_out|...@>=
+begin if is_char_node(p) then confusion("pdfvlistout")
+@:this can't happen pdfvlistout}{\quad pdfvlistout@>
+else @<Output the non-|char_node| |p| for |pdf_vlist_out|@>;
+next_p:p:=vlink(p);
+end
+
+@ @<Output the non-|char_node| |p| for |pdf_vlist_out|@>=
+begin case type(p) of
+hlist_node,vlist_node:@<(\pdfTeX) Output a box in a vlist@>;
+rule_node: begin
+ if not (dir_orthogonal(dir_primary[rule_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ rule_ht:=height(p); rule_dp:=depth(p); rule_wd:=width(p);
+ end
+ else begin
+ rule_ht:=width(p) div 2;
+ rule_dp:=width(p) div 2;
+ rule_wd:=height(p)+depth(p);
+ end;
+ goto fin_rule;
+ end;
+whatsit_node: @<Output the whatsit node |p| in |pdf_vlist_out|@>;
+glue_node: @<(\pdfTeX) Move down or output leaders@>;
+kern_node:cur_v:=cur_v+width(p);
+othercases do_nothing
+endcases;@/
+goto next_p;
+fin_rule: @<(\pdfTeX) Output a rule in a vlist, |goto next_p|@>;
+move_past: cur_v:=cur_v+rule_ht;
+end
+
+@ TODO: the direct test to switch between |width(p)| and |-width(p)|
+is definately wrong, because it does not nest properly. But at least
+it fixes a very obvious problem that otherwise occured with
+\.{\\pardir TLT} in a document with \.{\\bodydir TRT}, and so it
+will have to do for now.
+
+@<(\pdfTeX) Output a box in a vlist@>=
+begin
+if not (dir_orthogonal(dir_primary[box_dir(p)])(dir_primary[dvi_direction]))
+ then begin
+ effective_vertical:=height(p)+depth(p);
+ if (type(p)=hlist_node) and (is_mirrored(box_dir(p))) then
+ basepoint_vertical:=depth(p)
+ else
+ basepoint_vertical:=height(p);
+ if dir_opposite(dir_secondary[box_dir(p)])(dir_secondary[dvi_direction]) then begin
+ if dvi_direction=dir_TL_ then
+ basepoint_horizontal:=width(p)
+ else
+ basepoint_horizontal:=-width(p);
+ end
+ else
+ basepoint_horizontal:=0;
+ end
+else begin
+ effective_vertical:=width(p);
+ if not (is_mirrored(box_dir(p))) then
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=height(p)
+ else
+ basepoint_horizontal:=depth(p)
+ else
+ if dir_eq(dir_primary[box_dir(p)])(dir_secondary[dvi_direction]) then
+ basepoint_horizontal:=depth(p)
+ else
+ basepoint_horizontal:=height(p);
+ if dir_eq(dir_secondary[box_dir(p)])(dir_primary[dvi_direction]) then
+ basepoint_vertical:=0
+ else
+ basepoint_vertical:=width(p);
+ end;
+basepoint_horizontal := basepoint_horizontal + shift_amount(p);
+if list_ptr(p)=null then begin
+ cur_v:=cur_v+effective_vertical;
+ end
+else begin
+ edge_v:=cur_v;
+ cur_h:=left_edge + basepoint_horizontal;
+ cur_v:=cur_v + basepoint_vertical;
+ temp_ptr:=p;
+ if type(p)=vlist_node then pdf_vlist_out@+else pdf_hlist_out;
+ cur_h:=left_edge; cur_v:=edge_v + effective_vertical;
+ end
+end
+
+@ @<(\pdfTeX) Output a rule in a vlist...@>=
+if is_running(rule_wd) then rule_wd:=width(this_box);
+rule_ht:=rule_ht+rule_dp; {this is the rule thickness}
+cur_v:=cur_v+rule_ht;
+if (rule_ht>0)and(rule_wd>0) then {we don't output empty rules}
+ begin
+ case font_direction(dvi_direction) of
+ dir__LT: begin
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ {|pdf_dvicmd_left(rule_wd);|}
+ end;
+ dir__LB: begin
+ pdf_dvicmd_down(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_wd);
+ pdf_dvicmd_up(rule_ht);
+ end;
+ dir__RT: begin
+ pdf_dvicmd_left(rule_wd);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_wd);
+ end;
+ dir__RB: begin
+ pdf_dvicmd_down(rule_ht);
+ pdf_dvicmd_left(rule_wd);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_up(rule_ht);
+ end;
+ dir__TL: begin
+ pdf_dvicmd_down(rule_wd);
+ pdf_dvicmd_left(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_up(rule_wd);
+ end;
+ dir__TR: begin
+ pdf_dvicmd_down(rule_wd);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_wd);
+ pdf_dvicmd_up(rule_wd);
+ end;
+ dir__BL: begin
+ pdf_dvicmd_left(rule_ht);
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ end;
+ dir__BR: begin
+ pdf_set_rule(cur_h, cur_v, rule_wd, rule_ht);
+ pdf_dvicmd_left(rule_wd);
+ end;
+ end;
+ end;
+goto next_p
+
+@ @<(\pdfTeX) Move down or output leaders@>=
+begin g:=glue_ptr(p); rule_ht:=width(g)-cur_g;
+if g_sign<>normal then
+ begin if g_sign=stretching then
+ begin if stretch_order(g)=g_order then
+ begin cur_glue:=cur_glue+stretch(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+@^real multiplication@>
+ cur_g:=round(glue_temp);
+ end;
+ end
+ else if shrink_order(g)=g_order then
+ begin cur_glue:=cur_glue-shrink(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+ cur_g:=round(glue_temp);
+ end;
+ end;
+rule_ht:=rule_ht+cur_g;
+if subtype(p)>=a_leaders then
+ @<(\pdfTeX) Output leaders in a vlist, |goto fin_rule| if a rule
+ or to |next_p| if done@>;
+goto move_past;
+end
+
+@ @<(\pdfTeX) Output leaders in a vlist...@>=
+begin leader_box:=leader_ptr(p);
+if type(leader_box)=rule_node then
+ begin rule_wd:=width(leader_box); rule_dp:=0;
+ goto fin_rule;
+ end;
+leader_ht:=height(leader_box)+depth(leader_box);
+if (leader_ht>0)and(rule_ht>0) then
+ begin rule_ht:=rule_ht+10; {compensate for floating-point rounding}
+ edge:=cur_v+rule_ht; lx:=0;
+ @<Let |cur_v| be the position of the first box, and set |leader_ht+lx|
+ to the spacing between corresponding parts of boxes@>;
+ while cur_v+leader_ht<=edge do
+ @<(\pdfTeX) Output a leader box at |cur_v|,
+ then advance |cur_v| by |leader_ht+lx|@>;
+ cur_v:=edge-10; goto next_p;
+ end;
+end
+
+@ @<(\pdfTeX) Output a leader box at |cur_v|, ...@>=
+begin cur_h:=left_edge+shift_amount(leader_box);
+cur_v:=cur_v+height(leader_box); save_v:=cur_v;
+temp_ptr:=leader_box;
+outer_doing_leaders:=doing_leaders; doing_leaders:=true;
+if type(leader_box)=vlist_node then pdf_vlist_out@+else pdf_hlist_out;
+doing_leaders:=outer_doing_leaders;
+cur_h:=left_edge;
+cur_v:=save_v-height(leader_box)+leader_ht+lx;
+end
+
+@ |fix_pdfoutput| freezes |pdfoutput| when something has been written to
+the output.
+
+@p procedure fix_pdfoutput;
+begin
+ if not fixed_pdfoutput_set then begin
+ fixed_pdfoutput := pdf_output;
+ fixed_pdfoutput_set := true;
+ end
+ else if fixed_pdfoutput <> pdf_output then
+ pdf_error("setup",
+ "\pdfoutput can only be changed before anything is written to the output");
+ if fixed_pdfoutput_set then fix_pdf_draftmode;
+end;
+
+@ |fix_pdf_draftmode| freezes |pdfdraftmode| when something has been written to
+the output and also switches somes things off when draftmode is on.
+@p procedure fix_pdf_draftmode;
+begin
+ if not fixed_pdf_draftmode_set then begin
+ fixed_pdf_draftmode := pdf_draftmode;
+ fixed_pdf_draftmode_set := true;
+ end
+ else if fixed_pdf_draftmode <> pdf_draftmode then
+ pdf_error("setup",
+ "\pdfdraftmode can only be changed before anything is written to the output");
+ if fixed_pdf_draftmode_set and fixed_pdf_draftmode > 0 then begin
+ fixed_pdf_draftmode_set := true;
+ pdf_compress_level := 0;
+ fixed_pdf_objcompresslevel := 0;
+ end;
+end;
+
+@ |pdf_ship_out| is used instead of |ship_out| to shipout a box to PDF
+output. If |shipping_page| is not set then the output will be a Form object,
+otherwise it will be a Page object.
+
+@p procedure pdf_ship_out(p: pointer; shipping_page: boolean); {output the box |p|}
+label done, done1;
+var i,j,k:integer; {general purpose accumulators}
+save_font_list: pointer; {to save |pdf_font_list| during flushing pending forms}
+save_obj_list: pointer; {to save |pdf_obj_list|}
+save_ximage_list: pointer; {to save |pdf_ximage_list|}
+save_xform_list: pointer; {to save |pdf_xform_list|}
+save_image_procset: integer; {to save |pdf_image_procset|}
+save_text_procset: integer; {to save |pdf_text_procset|}
+save_cur_page_height: scaled; {to save |cur_page_height| during flushing pending forms}
+pdf_last_resources: integer; {pointer to most recently generated Resources object}
+pre_callback_id:integer;
+post_callback_id:integer;
+ret:boolean;
+begin
+pre_callback_id:=callback_defined(start_page_number_callback);
+post_callback_id:=callback_defined(stop_page_number_callback);
+if (tracing_output>0)and(pre_callback_id=0) then
+ begin print_nl(""); print_ln;
+ print("Completed box being shipped out");
+@.Completed box...@>
+ end;
+if not init_pdf_output then begin
+ @<Initialize variables for \.{PDF} output@>;
+ init_pdf_output := true;
+end;
+is_shipping_page := shipping_page;
+if shipping_page then begin
+ if pre_callback_id>0 then
+ ret:=run_callback(pre_callback_id,'->')
+ else begin
+ if term_offset>max_print_line-9 then print_ln
+ else if (term_offset>0)or(file_offset>0) then print_char(" ");
+ print_char("["); j:=9;
+ while (count(j)=0)and(j>0) do decr(j);
+ for k:=0 to j do
+ begin print_int(count(k));
+ if k<j then print_char(".");
+ end;
+ end;
+ update_terminal;
+end;
+if (tracing_output>0)and(post_callback_id=0) then
+ begin if shipping_page then print_char("]");
+ begin_diagnostic; show_box(p); end_diagnostic(true);
+ end;
+@<(\pdfTeX) Ship box |p| out@>;
+if (tracing_output<=0)and(post_callback_id=0) and shipping_page then
+ print_char("]");
+dead_cycles:=0;
+update_terminal; {progress report}
+@<Flush the box from memory, showing statistics if requested@>;
+if post_callback_id>0 then
+ ret:=run_callback(post_callback_id,'->');
+end;
+
+@ @<(\pdfTeX) Ship box |p| out@>=
+@<Update the values of |max_h| and |max_v|; but if the page is too large,
+ |goto done|@>;
+@<Initialize variables as |pdf_ship_out| begins@>;
+if type(p)=vlist_node then pdf_vlist_out@+else pdf_hlist_out;
+if shipping_page then
+ incr(total_pages);
+cur_s:=-1;
+@<Finish shipping@>;
+done:
+
+@ @<Initialize variables as |pdf_ship_out| begins@>=
+fix_pdfoutput;
+temp_ptr:=p;
+prepare_mag;
+pdf_last_resources := pdf_new_objnum;
+@<Reset resource lists@>;
+dvi_direction:=page_direction;
+@<Calculate PDF page dimensions and margins@>;
+if not shipping_page then begin
+ pdf_begin_dict(pdf_cur_form, 0);
+ pdf_last_stream := pdf_cur_form;
+ @<Write out Form stream header@>;
+end
+else begin
+ pdf_last_page := get_obj(obj_type_page, total_pages + 1, 0);
+ obj_aux(pdf_last_page) := 1; {mark that this page has beed created}
+ pdf_new_dict(obj_type_others, 0, 0);
+ pdf_last_stream := obj_ptr;
+ @<Reset PDF mark lists@>;
+end;
+@<Start stream of page/form contents@>
+
+@ @<Reset resource lists@>=
+pdf_font_list := null;
+pdf_obj_list := null;
+pdf_xform_list := null;
+pdf_ximage_list := null;
+pdf_text_procset := false;
+pdf_image_procset := 0
+
+@ @<Reset PDF mark lists@>=
+pdf_annot_list := null;
+pdf_link_list := null;
+pdf_dest_list := null;
+pdf_bead_list := null;
+last_thread := null
+
+@ @<Calculate PDF page dimensions and margins@>=
+if is_shipping_page then begin
+ if page_width > 0 then
+ cur_page_width := page_width
+ else
+ cur_page_width := width(p) + 2 * pdf_h_offset;
+ if page_height > 0 then
+ cur_page_height := page_height
+ else
+ cur_page_height := height(p) + depth(p) + 2 * pdf_v_offset;
+ if page_bottom_offset <> 0 then
+ cur_bottom_offset := page_bottom_offset
+ else
+ cur_bottom_offset := one_inch;
+ if page_right_offset <> 0 then
+ cur_right_offset := page_right_offset
+ else
+ cur_right_offset := one_inch;
+ cur_h := pdf_h_offset;
+ cur_v := height(p) + pdf_v_offset;
+ case box_direction(dvi_direction) of
+ dir_TL_,dir_LT_: begin end;
+ dir_TR_,dir_RT_: begin cur_h:=cur_page_width-cur_right_offset; end;
+ dir_RB_,dir_BR_: begin cur_h:=cur_page_width-cur_right_offset; cur_v:=-cur_bottom_offset; end;
+ dir_BL_,dir_LB_: begin cur_v:=-cur_bottom_offset; end;
+ end;
+end
+else begin
+ cur_page_width := width(p);
+ cur_page_height := height(p) + depth(p);
+ cur_h := 0;
+ cur_v := height(p);
+end;
+pdf_origin_h := 0;
+pdf_origin_v := cur_page_height;
+
+@ Here we write out the header for Form.
+
+@<Write out Form stream header@>=
+pdf_print_ln("/Type /XObject");
+pdf_print_ln("/Subtype /Form");
+if obj_xform_attr(pdf_cur_form) <> null then begin
+ pdf_print_toks_ln(obj_xform_attr(pdf_cur_form));
+ delete_toks(obj_xform_attr(pdf_cur_form));
+end;
+pdf_print("/BBox [");
+pdf_print("0 0 ");
+pdf_print_bp(cur_page_width); pdf_out(" ");
+pdf_print_bp(cur_page_height); pdf_print_ln("]");
+pdf_print_ln("/FormType 1");
+pdf_print_ln("/Matrix [1 0 0 1 0 0]");
+pdf_indirect_ln("Resources", pdf_last_resources)
+
+@ @<Start stream of page/form contents@>=
+pdf_begin_stream;
+if shipping_page then begin
+ @<Adjust transformation matrix for the magnification ratio@>;
+end;
+pdfshipoutbegin(shipping_page);
+if shipping_page then
+ pdf_out_colorstack_startpage;
+
+
+@ @<Adjust transformation matrix for the magnification ratio@>=
+prepare_mag;
+if mag <> 1000 then begin
+ pdf_print_real(mag, 3);
+ pdf_print(" 0 0 ");
+ pdf_print_real(mag, 3);
+ pdf_print_ln(" 0 0 cm");
+end
+
+@ @<Finish shipping@>=
+@<Finish stream of page/form contents@>;
+if shipping_page then begin
+ @<Write out page object@>;
+end;
+@<Write out resource lists@>;
+if shipping_page then begin
+ @<Write out pending PDF marks@>;
+end;
+@<Write out resources dictionary@>;
+@<Flush resource lists@>;
+if shipping_page then begin
+ @<Flush PDF mark lists@>;
+end
+
+@ @<Finish stream of page/form contents@>=
+pdf_end_text;
+pdfshipoutend(shipping_page);
+pdf_end_stream
+
+@ @<Write out resource lists@>=
+@<Write out pending raw objects@>;
+@<Write out pending forms@>;
+@<Write out pending images@>
+
+@ @<Write out resources dictionary@>=
+pdf_begin_dict(pdf_last_resources, 1);
+@<Print additional resources@>;
+@<Generate font resources@>;
+@<Generate XObject resources@>;
+@<Generate ProcSet@>;
+pdf_end_dict
+
+@ @<Print additional resources@>=
+if shipping_page then begin
+ if pdf_page_resources <> null then
+ pdf_print_toks_ln(pdf_page_resources);
+end
+else begin
+ if obj_xform_resources(pdf_cur_form) <> null then begin
+ pdf_print_toks_ln(obj_xform_resources(pdf_cur_form));
+ delete_toks(obj_xform_resources(pdf_cur_form));
+ end;
+end
+
+@ In the end of shipping out a page we reset all the lists holding objects
+have been created during the page shipping.
+
+@d delete_toks(#) == begin delete_token_ref(#); # := null; end
+
+@<Flush resource lists@>=
+flush_list(pdf_font_list);
+flush_list(pdf_obj_list);
+flush_list(pdf_xform_list);
+flush_list(pdf_ximage_list)
+
+@ @<Flush PDF mark lists@>=
+flush_list(pdf_annot_list);
+flush_list(pdf_link_list);
+flush_list(pdf_dest_list);
+flush_list(pdf_bead_list)
+
+@ @<Generate font resources@>=
+if pdf_font_list <> null then begin
+ pdf_print("/Font << ");
+ k := pdf_font_list;
+ while k <> null do begin
+ pdf_print("/F");
+ set_ff(info(k));
+ pdf_print_int(ff);
+ pdf_print_resname_prefix;
+ pdf_out(" ");
+ pdf_print_int(pdf_font_num(ff));
+ pdf_print(" 0 R ");
+ k := link(k);
+ end;
+ pdf_print_ln(">>");
+ pdf_text_procset := true;
+end
+
+@ @<Generate XObject resources@>=
+if (pdf_xform_list <> null) or (pdf_ximage_list <> null) then begin
+ pdf_print("/XObject << ");
+ k := pdf_xform_list;
+ while k <> null do begin
+ pdf_print("/Fm");
+ pdf_print_int(obj_info(info(k)));
+ pdf_print_resname_prefix;
+ pdf_out(" ");
+ pdf_print_int(info(k));
+ pdf_print(" 0 R ");
+ k := link(k);
+ end;
+ k := pdf_ximage_list;
+ while k <> null do begin
+ pdf_print("/Im");
+ pdf_print_int(image_index(obj_data_ptr(info(k))));
+ pdf_print_resname_prefix;
+ pdf_out(" ");
+ pdf_print_int(info(k));
+ pdf_print(" 0 R ");
+ update_image_procset(obj_data_ptr(info(k)));
+ k := link(k);
+ end;
+ pdf_print_ln(">>");
+end
+
+@ @<Generate ProcSet@>=
+pdf_print("/ProcSet [ /PDF");
+if pdf_text_procset then
+ pdf_print(" /Text");
+if check_image_b(pdf_image_procset) then
+ pdf_print(" /ImageB");
+if check_image_c(pdf_image_procset) then
+ pdf_print(" /ImageC");
+if check_image_i(pdf_image_procset) then
+ pdf_print(" /ImageI");
+pdf_print_ln(" ]")
+
+@ @<Write out page object@>=
+pdf_begin_dict(pdf_last_page, 1);
+pdf_print_ln("/Type /Page");
+pdf_indirect_ln("Contents", pdf_last_stream);
+pdf_indirect_ln("Resources", pdf_last_resources);
+pdf_print("/MediaBox [0 0 ");
+pdf_print_mag_bp(cur_page_width); pdf_out(" ");
+pdf_print_mag_bp(cur_page_height);
+pdf_print_ln("]");
+if pdf_page_attr <> null then
+ pdf_print_toks_ln(pdf_page_attr);
+@<Generate parent pages object@>;
+@<Generate array of annotations or beads in page@>;
+pdf_end_dict
+
+@ @<Generate parent pages object@>=
+if total_pages mod pages_tree_kids_max = 1 then begin
+ pdf_create_obj(obj_type_pages, pages_tree_kids_max);
+ pdf_last_pages := obj_ptr;
+end;
+pdf_indirect_ln("Parent", pdf_last_pages)
+
+@ @<Generate array of annotations or beads in page@>=
+if (pdf_annot_list <> null) or (pdf_link_list <> null) then begin
+ pdf_print("/Annots [ ");
+ k := pdf_annot_list;
+ while k <> null do begin
+ pdf_print_int(info(k));
+ pdf_print(" 0 R ");
+ k := link(k);
+ end;
+ k := pdf_link_list;
+ while k <> null do begin
+ pdf_print_int(info(k));
+ pdf_print(" 0 R ");
+ k := link(k);
+ end;
+ pdf_print_ln("]");
+end;
+if pdf_bead_list <> null then begin
+ k := pdf_bead_list;
+ pdf_print("/B [ ");
+ while k <> null do begin
+ pdf_print_int(info(k));
+ pdf_print(" 0 R ");
+ k := link(k);
+ end;
+ pdf_print_ln("]");
+end
+
+@ @<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure pdf_write_obj(n: integer); {write a raw PDF object}
+var s: str_number;
+ f: byte_file;
+ data_size:integer; {total size of the data file}
+ data_cur:integer; {index into |data_buffer|}
+ data_buffer:^real_eight_bits; {byte buffer for data files}
+ file_opened:boolean;
+ k:integer;
+ res:boolean;
+ fnam: str_number;
+ callback_id:integer;
+begin
+ s := tokens_to_string(obj_obj_data(n));
+ delete_toks(obj_obj_data(n));
+ if obj_obj_is_stream(n) > 0 then begin
+ pdf_begin_dict(n, 0);
+ if obj_obj_stream_attr(n) <> null then begin
+ pdf_print_toks_ln(obj_obj_stream_attr(n));
+ delete_toks(obj_obj_stream_attr(n));
+ end;
+ pdf_begin_stream;
+ end
+ else
+ pdf_begin_obj(n, 1);
+ if obj_obj_is_file(n) > 0 then begin
+ data_size:=0; data_cur:=0; data_buffer:=0;
+ pack_file_name(s,"","");
+ callback_id:=callback_defined(find_data_file_callback);
+ if callback_id>0 then begin
+ res := run_callback(callback_id,'S->s',stringcast(nameoffile+1),addressof(fnam));
+ if (res)and(fnam<>0)and(length(fnam)>0) then begin
+ @<Fixup |nameoffile| after callback@>;
+ end;
+ end;
+ callback_id:=callback_defined(read_data_file_callback);
+ if callback_id>0 then begin
+ file_opened := false;
+ res := run_callback(callback_id,'S->bSd',stringcast(nameoffile+1),
+ addressof(file_opened), addressof(data_buffer),addressof(data_size));
+ if not file_opened then pdf_error("ext5", "cannot open file for embedding");
+ end
+ else begin
+ if not tex_b_open_in(f) then
+ pdf_error("ext5", "cannot open file for embedding");
+ res := read_data_file(f,addressof(data_buffer),addressof(data_size));
+ b_close(f);
+ end;
+ if not data_size then pdf_error("ext5", "empty file for embedding");
+ if not res then pdf_error("ext5", "error reading file for embedding");
+ print("<<");
+ print(s);
+ while data_cur<data_size do begin
+ pdf_out(data_buffer[data_cur]);
+ incr(data_cur);
+ end;
+ if data_buffer<>0 then libcfree(data_buffer);
+ print(">>");
+ end
+ else if obj_obj_is_stream(n) > 0 then
+ pdf_print(s)
+ else
+ pdf_print_ln(s);
+ if obj_obj_is_stream(n) > 0 then
+ pdf_end_stream
+ else
+ pdf_end_obj;
+ flush_str(s);
+end;
+
+@ @<Write out pending raw objects@>=
+if pdf_obj_list <> null then begin
+ k := pdf_obj_list;
+ while k <> null do begin
+ if not is_obj_written(info(k)) then
+ pdf_write_obj(info(k));
+ k := link(k);
+ end;
+end
+
+@ When flushing pending forms we need to save and restore resource lists
+(|pdf_font_list|, |pdf_obj_list|, |pdf_xform_list| and |pdf_ximage_list|),
+which are also used by page shipping.
+Saving and restoring |cur_page_height| is needed for proper
+writing out pending PDF marks.
+
+@<Write out pending forms@>=
+if pdf_xform_list <> null then begin
+ k := pdf_xform_list;
+ while k <> null do begin
+ if not is_obj_written(info(k)) then begin
+ pdf_cur_form := info(k);
+ @<Save resource lists@>;
+ @<Reset resource lists@>;
+ save_cur_page_height := cur_page_height;
+ pdf_ship_out(obj_xform_box(pdf_cur_form), false);
+ cur_page_height := save_cur_page_height;
+ @<Restore resource lists@>;
+ end;
+ k := link(k);
+ end;
+end
+
+@ @<Save resource lists@>=
+save_font_list := pdf_font_list;
+save_obj_list := pdf_obj_list;
+save_xform_list := pdf_xform_list;
+save_ximage_list := pdf_ximage_list;
+save_text_procset := pdf_text_procset;
+save_image_procset := pdf_image_procset
+
+@ @<Restore resource lists@>=
+pdf_font_list := save_font_list;
+pdf_obj_list := save_obj_list;
+pdf_xform_list := save_xform_list;
+pdf_ximage_list := save_ximage_list;
+pdf_text_procset := save_text_procset;
+pdf_image_procset := save_image_procset
+
+@ @<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure pdf_write_image(n: integer); {write an image}
+begin
+ pdf_begin_dict(n, 0);
+ if fixed_pdf_draftmode = 0 then write_image(obj_data_ptr(n));
+end;
+
+@ @<Write out pending images@>=
+if pdf_ximage_list <> null then begin
+ k := pdf_ximage_list;
+ while k <> null do begin
+ if not is_obj_written(info(k)) then
+ pdf_write_image(info(k));
+ k := link(k);
+ end;
+end
+
+@ @<Write out pending PDF marks@>=
+pdf_origin_h := 0;
+pdf_origin_v := cur_page_height;
+@<Write out PDF annotations@>;
+@<Write out PDF link annotations@>;
+@<Write out PDF mark destinations@>;
+@<Write out PDF bead rectangle specifications@>
+
+@ @<Write out PDF annotations@>=
+if pdf_annot_list <> null then begin
+ k := pdf_annot_list;
+ while k <> null do begin
+ i := obj_annot_ptr(info(k)); {|i| points to |pdf_annot_node|}
+ pdf_begin_dict(info(k), 1);
+ pdf_print_ln("/Type /Annot");
+ pdf_print_toks_ln(pdf_annot_data(i));
+ pdf_rectangle(pdf_left(i), pdf_top(i), pdf_right(i), pdf_bottom(i));
+ pdf_end_dict;
+ k := link(k);
+ end;
+end
+
+@ @<Write out PDF link annotations@>=
+if pdf_link_list <> null then begin
+k := pdf_link_list;
+while k <> null do begin
+ i := obj_annot_ptr(info(k));
+ pdf_begin_dict(info(k), 1);
+ pdf_print_ln("/Type /Annot");
+ if pdf_link_attr(i) <> null then
+ pdf_print_toks_ln(pdf_link_attr(i));
+ pdf_rectangle(pdf_left(i), pdf_top(i), pdf_right(i), pdf_bottom(i));
+ if pdf_action_type(pdf_link_action(i)) <> pdf_action_user
+ then begin
+ pdf_print_ln("/Subtype /Link");
+ pdf_print("/A ");
+ end;
+ write_action(pdf_link_action(i));
+ pdf_end_dict;
+ k := link(k);
+ end;
+ @<Flush |pdf_start_link_node|'s created by |append_link|@>;
+end
+
+@ @<Flush |pdf_start_link_node|'s created by |append_link|@>=
+k := pdf_link_list;
+while k <> null do begin
+ i := obj_annot_ptr(info(k));
+ {nodes with |subtype = pdf_link_data_node| were created by |append_link| and
+ must be flushed here, as they are not linked in any list}
+ if subtype(i) = pdf_link_data_node then
+ flush_node(i);
+ k := link(k);
+end
+
+@ @<Write out PDF mark destinations@>=
+if pdf_dest_list <> null then begin
+ k := pdf_dest_list;
+ while k <> null do begin
+ if is_obj_written(info(k)) then
+ pdf_error("ext5",
+ "destination has been already written (this shouldn't happen)")
+ else begin
+ i := obj_dest_ptr(info(k));
+ if pdf_dest_named_id(i) > 0 then begin
+ pdf_begin_dict(info(k), 1);
+ pdf_print("/D ");
+ end
+ else
+ pdf_begin_obj(info(k), 1);
+ pdf_out("["); pdf_print_int(pdf_last_page); pdf_print(" 0 R ");
+ case pdf_dest_type(i) of
+ pdf_dest_xyz: begin
+ pdf_print("/XYZ ");
+ pdf_print_mag_bp(pdf_x(pdf_left(i))); pdf_out(" ");
+ pdf_print_mag_bp(pdf_y(pdf_top(i))); pdf_out(" ");
+ if pdf_dest_xyz_zoom(i) = null then
+ pdf_print("null")
+ else begin
+ pdf_print_int(pdf_dest_xyz_zoom(i) div 1000);
+ pdf_out(".");
+ pdf_print_int((pdf_dest_xyz_zoom(i) mod 1000));
+ end;
+ end;
+ pdf_dest_fit:
+ pdf_print("/Fit");
+ pdf_dest_fith: begin
+ pdf_print("/FitH ");
+ pdf_print_mag_bp(pdf_y(pdf_top(i)));
+ end;
+ pdf_dest_fitv: begin
+ pdf_print("/FitV ");
+ pdf_print_mag_bp(pdf_x(pdf_left(i)));
+ end;
+ pdf_dest_fitb:
+ pdf_print("/FitB");
+ pdf_dest_fitbh: begin
+ pdf_print("/FitBH ");
+ pdf_print_mag_bp(pdf_y(pdf_top(i)));
+ end;
+ pdf_dest_fitbv: begin
+ pdf_print("/FitBV ");
+ pdf_print_mag_bp(pdf_x(pdf_left(i)));
+ end;
+ pdf_dest_fitr: begin
+ pdf_print("/FitR ");
+ pdf_print_rect_spec(i);
+ end;
+ othercases pdf_error("ext5", "unknown dest type");
+ endcases;
+ pdf_print_ln("]");
+ if pdf_dest_named_id(i) > 0 then
+ pdf_end_dict
+ else
+ pdf_end_obj;
+ end;
+ k := link(k);
+ end;
+end
+
+@ @<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure pdf_print_rect_spec(r: pointer); {prints a rect spec}
+begin
+ pdf_print_mag_bp(pdf_x(pdf_left(r)));
+ pdf_out(" ");
+ pdf_print_mag_bp(pdf_y(pdf_bottom(r)));
+ pdf_out(" ");
+ pdf_print_mag_bp(pdf_x(pdf_right(r)));
+ pdf_out(" ");
+ pdf_print_mag_bp(pdf_y(pdf_top(r)));
+end;
+
+@ @<Write out PDF bead rectangle specifications@>=
+if pdf_bead_list <> null then begin
+ k := pdf_bead_list;
+ while k <> null do begin
+ pdf_new_obj(obj_type_others, 0, 1);
+ pdf_out("[");
+ i := obj_bead_data(info(k)); {pointer to a whatsit or whatsit-like node}
+ pdf_print_rect_spec(i);
+ if subtype(i) = pdf_thread_data_node then {thanh says it mis be destroyed here}
+ flush_node(i);
+ pdf_print_ln("]");
+ obj_bead_rect(info(k)) := obj_ptr; {rewrite |obj_bead_data|}
+ pdf_end_obj;
+ k := link(k);
+ end;
+end
+
+@ In the end we must flush PDF objects that cannot be written out
+immediately after shipping out pages.
+
+@ @<Output outlines@>=
+if pdf_first_outline <> 0 then begin
+ pdf_new_dict(obj_type_others, 0, 1);
+ outlines := obj_ptr;
+ l := pdf_first_outline; k := 0;
+ repeat
+ incr(k);
+ a := open_subentries(l);
+ if obj_outline_count(l) > 0 then
+ k := k + a;
+ obj_outline_parent(l) := obj_ptr;
+ l := obj_outline_next(l);
+ until l = 0;
+ pdf_print_ln("/Type /Outlines");
+ pdf_indirect_ln("First", pdf_first_outline);
+ pdf_indirect_ln("Last", pdf_last_outline);
+ pdf_int_entry_ln("Count", k);
+ pdf_end_dict;
+ @<Output PDF outline entries@>;
+end
+else
+ outlines := 0
+
+@ @<Output PDF outline entries@>=
+k := head_tab[obj_type_outline];
+while k <> 0 do begin
+ if obj_outline_parent(k) = pdf_parent_outline then begin
+ if obj_outline_prev(k) = 0 then
+ pdf_first_outline := k;
+ if obj_outline_next(k) = 0 then
+ pdf_last_outline := k;
+ end;
+ pdf_begin_dict(k, 1);
+ pdf_indirect_ln("Title", obj_outline_title(k));
+ pdf_indirect_ln("A", obj_outline_action_objnum(k));
+ if obj_outline_parent(k) <> 0 then
+ pdf_indirect_ln("Parent", obj_outline_parent(k));
+ if obj_outline_prev(k) <> 0 then
+ pdf_indirect_ln("Prev", obj_outline_prev(k));
+ if obj_outline_next(k) <> 0 then
+ pdf_indirect_ln("Next", obj_outline_next(k));
+ if obj_outline_first(k) <> 0 then
+ pdf_indirect_ln("First", obj_outline_first(k));
+ if obj_outline_last(k) <> 0 then
+ pdf_indirect_ln("Last", obj_outline_last(k));
+ if obj_outline_count(k) <> 0 then
+ pdf_int_entry_ln("Count", obj_outline_count(k));
+ if obj_outline_attr(k) <> 0 then begin
+ pdf_print_toks_ln(obj_outline_attr(k));
+ delete_toks(obj_outline_attr(k));
+ end;
+ pdf_end_dict;
+ k := obj_link(k);
+end
+
+@ @<Output article threads@>=
+if head_tab[obj_type_thread] <> 0 then begin
+ pdf_new_obj(obj_type_others, 0, 1);
+ threads := obj_ptr;
+ pdf_out("[");
+ k := head_tab[obj_type_thread];
+ while k <> 0 do begin
+ pdf_print_int(k);
+ pdf_print(" 0 R ");
+ k := obj_link(k);
+ end;
+ remove_last_space;
+ pdf_print_ln("]");
+ pdf_end_obj;
+ k := head_tab[obj_type_thread];
+ while k <> 0 do begin
+ out_thread(k);
+ k := obj_link(k);
+ end;
+end
+else
+ threads := 0
+
+@ Now we are ready to declare our new procedure |ship_out|. It will call
+|pdf_ship_out| if the integer parameter |pdf_output| is positive; otherwise it
+will call |dvi_ship_out|, which is the \TeX\ original |ship_out|.
+
+@p procedure ship_out(p:pointer); {output the box |p|}
+begin
+ fix_pdfoutput;
+ if pdf_output > 0 then
+ pdf_ship_out(p, true)
+ else
+ dvi_ship_out(p);
+end;
+
+@ @<Initialize variables for \.{PDF} output@>=
+check_pdfminorversion;
+prepare_mag;
+fixed_decimal_digits := fix_int(pdf_decimal_digits, 0, 4);
+min_bp_val :=
+ divide_scaled(one_hundred_bp, ten_pow[fixed_decimal_digits + 2], 0);
+if pdf_pk_resolution = 0 then {if not set from format file or by user}
+ pdf_pk_resolution := pk_dpi; {take it from \.{texmf.cnf}}
+fixed_pk_resolution := fix_int(pdf_pk_resolution, 72, 8000);
+pk_scale_factor :=
+ divide_scaled(72, fixed_pk_resolution, 5 + fixed_decimal_digits);
+if not callback_defined(read_pk_file_callback) then begin
+ if pdf_pk_mode <> null then begin
+ kpseinitprog('PDFTEX', fixed_pk_resolution,
+ makecstring(tokens_to_string(pdf_pk_mode)), nil);
+ flush_string;
+ end else
+ kpseinitprog('PDFTEX', fixed_pk_resolution, nil, nil);
+ if not kpsevarvalue('MKTEXPK') then
+ kpsesetprogramenabled (kpsepkformat, 1, kpsesrccmdline);
+ end;
+set_job_id(year, month, day, time);
+if (pdf_unique_resname > 0) and (pdf_resname_prefix = 0) then
+ pdf_resname_prefix := get_resname_prefix
+
+@ Finishing the PDF output file.
+
+The following procedures sort the table of destination names
+@p function str_less_str(s1, s2: str_number): boolean; {compare two strings}
+var c1, c2: pool_pointer;
+ l, i: integer;
+begin
+ c1 := str_start_macro(s1);
+ c2 := str_start_macro(s2);
+ if length(s1) < length(s2) then
+ l := length(s1)
+ else
+ l := length(s2);
+ i := 0;
+ while (i < l) and (str_pool[c1 + i] = str_pool[c2 + i]) do
+ incr(i);
+ if ((i < l) and (str_pool[c1 + i] < str_pool[c2 + i])) or
+ ((i = l) and (length(s1) < length(s2))) then
+ str_less_str := true
+ else
+ str_less_str := false;
+end;
+
+procedure sort_dest_names(l, r: integer); {sorts |dest_names| by names}
+var i, j: integer;
+ s: str_number;
+ e: dest_name_entry;
+begin
+ i := l;
+ j := r;
+ s := dest_names[(l + r) div 2].objname;
+ repeat
+ while str_less_str(dest_names[i].objname, s) do
+ incr(i);
+ while str_less_str(s, dest_names[j].objname) do
+ decr(j);
+ if i <= j then begin
+ e := dest_names[i];
+ dest_names[i] := dest_names[j];
+ dest_names[j] := e;
+ incr(i);
+ decr(j);
+ end;
+ until i > j;
+ if l < j then
+ sort_dest_names(l, j);
+ if i < r then
+ sort_dest_names(i, r);
+end;
+
+@ Now the finish of PDF output file. At this moment all Page objects
+are already written completely to PDF output file.
+
+@<Finish the PDF file@>=
+if total_pages=0 then begin
+ if callback_id=0 then
+ print_nl("No pages of output.")
+ else
+ res:=run_callback(callback_id,'->');
+ @.No pages of output@>
+ if pdf_gone > 0 then
+ garbage_warning;
+end
+else begin
+ if fixed_pdf_draftmode = 0 then begin
+ pdf_flush; {to make sure that the output file name has been already
+ created}
+ if total_pages mod pages_tree_kids_max <> 0 then
+ obj_info(pdf_last_pages) := total_pages mod pages_tree_kids_max;
+ {last pages object may have less than |pages_tree_kids_max| children}
+ flush_jbig2_page0_objects; {flush page 0 objects from JBIG2 images, if any}
+ @<Check for non-existing pages@>;
+ @<Reverse the linked list of Page and Pages objects@>;
+ @<Check for non-existing destinations@>;
+ @<Output fonts definition@>;
+ @<Output pages tree@>;
+ @<Output outlines@>;
+ @<Output name tree@>;
+ @<Output article threads@>;
+ @<Output the catalog object@>;
+ pdf_print_info; {last candidate for object stream}
+ if pdf_os_enable then begin
+ pdf_os_switch(true);
+ pdf_os_write_objstream;
+ pdf_flush;
+ pdf_os_switch(false);
+ @<Output the cross-reference stream dictionary@>;
+ pdf_flush;
+ end else begin
+ @<Output the |obj_tab|@>;
+ end;
+ @<Output the trailer@>;
+ pdf_flush;
+ if callback_id=0 then begin
+ print_nl("Output written on "); print_file_name(0, output_file_name, 0);
+ @.Output written on x@>
+ print(" ("); print_int(total_pages); print(" page");
+ if total_pages<>1 then print_char("s");
+ print(", "); print_int(pdf_offset); print(" bytes).");
+ end
+ else
+ res:=run_callback(callback_id,'->');
+ end;
+ libpdffinish;
+ if fixed_pdf_draftmode = 0 then b_close(pdf_file)
+ else pdf_warning(0, "\pdfdraftmode enabled, not changing output pdf", true, true)
+end
+
+@ Destinations that have been referenced but don't exists have
+|obj_dest_ptr=null|. Leaving them undefined might cause troubles for
+PDF browsers, so we need to fix them.
+
+@p procedure pdf_fix_dest(k: integer);
+begin
+ if obj_dest_ptr(k) <> null then
+ return;
+ pdf_warning("dest", "", false, false);
+ if obj_info(k) < 0 then begin
+ print("name{");
+ print(-obj_info(k));
+ print("}");
+ end
+ else begin
+ print("num");
+ print_int(obj_info(k));
+ end;
+ print(" has been referenced but does not exist, replaced by a fixed one");
+ print_ln; print_ln;
+ pdf_begin_obj(k, 1);
+ pdf_out("[");
+ pdf_print_int(head_tab[obj_type_page]);
+ pdf_print_ln(" 0 R /Fit]");
+ pdf_end_obj;
+end;
+
+@ @<Check for non-existing destinations@>=
+k := head_tab[obj_type_dest];
+while k <> 0 do begin
+ pdf_fix_dest(k);
+ k := obj_link(k);
+end
+
+@ @<Check for non-existing pages@>=
+k := head_tab[obj_type_page];
+while obj_aux(k) = 0 do begin
+ pdf_warning("dest", "Page ", false, false);
+ print_int(obj_info(k));
+ print(" has been referenced but does not exist!");
+ print_ln; print_ln;
+ k := obj_link(k);
+end;
+head_tab[obj_type_page] := k
+
+@ @<Reverse the linked list of Page and Pages objects@>=
+k := head_tab[obj_type_page];
+l := 0;
+repeat
+ i := obj_link(k);
+ obj_link(k) := l;
+ l := k;
+ k := i;
+until k = 0;
+head_tab[obj_type_page] := l;
+k := head_tab[obj_type_pages];
+pages_tail := k;
+l := 0;
+repeat
+ i := obj_link(k);
+ obj_link(k) := l;
+ l := k;
+ k := i;
+until k = 0;
+head_tab[obj_type_pages] := l
+
+@ @<Output fonts definition@>=
+for k := 1 to max_font_id do
+ if font_used(k) and (pdf_font_num(k) < 0) then begin
+ i := -pdf_font_num(k);
+ pdfassert(pdf_font_num(i) > 0);
+ for j := font_bc(k) to font_ec(k) do
+ if pdf_char_marked(k, j) then
+ pdf_mark_char(i, j);
+ if (pdf_font_attr(i) = 0) and (pdf_font_attr(k) <> 0) then
+ set_pdf_font_attr(i, pdf_font_attr(k))
+ else if (pdf_font_attr(k) = 0) and (pdf_font_attr(i) <> 0) then
+ set_pdf_font_attr(k,pdf_font_attr(i))
+ else if (pdf_font_attr(i) <> 0) and (pdf_font_attr(k) <> 0) and
+ not str_eq_str(pdf_font_attr(i), pdf_font_attr(k)) then begin
+ pdf_warning("\pdffontattr", "fonts ", false, false);
+ print_font_identifier(i);
+ print(" and ");
+ print_font_identifier(k);
+ print(" has conflicting attributes"); print_ln; print_ln;
+ end;
+ end;
+fixed_gen_tounicode := pdf_gen_tounicode;
+k := head_tab[obj_type_font];
+while k <> 0 do begin
+ f := obj_info(k);
+ pdfassert(pdf_font_num(f) > 0);
+ do_pdf_font(k, f);
+ k := obj_link(k);
+end;
+write_fontstuff
+
+@ We will generate in each single step the parents of all Pages/Page objects in
+the previous level. These new generated Pages object will create a new level of
+Pages tree. We will repeat this until search only one Pages object. This one
+will be the Root object.
+
+@<Output pages tree@>=
+a := sys_obj_ptr + 1; {all Pages objects whose children are not Page objects
+ should have index greater than |a|}
+l := head_tab[obj_type_pages]; {|l| is the index of current Pages object
+ which is being output}
+k := head_tab[obj_type_page]; {|k| is the index of current child of |l|}
+b := 0;
+repeat
+ i := 0; {counter of Pages object in current level}
+ c := 0; {first Pages object in previous level}
+ if obj_link(l) = 0 then
+ is_root := true {only Pages object; total pages is
+ not greater than |pages_tree_kids_max|}
+ else
+ is_root := false;
+ repeat
+ if not is_root then begin
+ if i mod pages_tree_kids_max = 0 then begin {create a new Pages object
+ for next level}
+ pdf_last_pages := pdf_new_objnum;
+ if c = 0 then
+ c := pdf_last_pages;
+ obj_link(pages_tail) := pdf_last_pages;
+ pages_tail := pdf_last_pages;
+ obj_link(pdf_last_pages) := 0;
+ obj_info(pdf_last_pages) := obj_info(l);
+ end
+ else
+ obj_info(pdf_last_pages) := obj_info(pdf_last_pages) +
+ obj_info(l);
+ end;
+ @<Output the current Pages object in this level@>;
+ incr(i);
+ l := obj_link(l);
+ until (l = c);
+ b := c;
+ if l = 0 then
+ goto done;
+until false;
+done:
+
+@ @<Output the current Pages object in this level@>=
+pdf_begin_dict(l, 1);
+pdf_print_ln("/Type /Pages");
+pdf_int_entry_ln("Count", obj_info(l));
+if not is_root then
+ pdf_indirect_ln("Parent", pdf_last_pages);
+pdf_print("/Kids [");
+j := 0;
+repeat
+ pdf_print_int(k);
+ pdf_print(" 0 R ");
+ k := obj_link(k);
+ incr(j);
+until ((l < a) and (j = obj_info(l))) or
+ (k = 0) or ((k = b) and (b <> 0)) or
+ (j = pages_tree_kids_max);
+remove_last_space;
+pdf_print_ln("]");
+if k = 0 then begin
+ k := head_tab[obj_type_pages];
+ head_tab[obj_type_pages] := 0;
+end;
+if is_root and (pdf_pages_attr <> null) then
+ pdf_print_toks_ln(pdf_pages_attr);
+pdf_end_dict;
+
+@ The name tree is very similiar to Pages tree so its construction should be
+certain from Pages tree construction. For intermediate node |obj_info| will be
+the first name and |obj_link| will be the last name in \.{\\Limits} array.
+Note that |pdf_dest_names_ptr| will be less than |obj_ptr|, so we test if
+|k < pdf_dest_names_ptr| then |k| is index of leaf in |dest_names|; else
+|k| will be index in |obj_tab| of some intermediate node.
+
+@<Output name tree@>=
+if pdf_dest_names_ptr = 0 then begin
+ dests := 0;
+ goto done1;
+end;
+sort_dest_names(0, pdf_dest_names_ptr - 1);
+names_head := 0;
+names_tail := 0;
+k := 0; {index of current child of |l|; if |k < pdf_dest_names_ptr|
+ then this is pointer to |dest_names| array;
+ otherwise it is the pointer to |obj_tab| (object number)}
+is_names := true; {flag whether Names or Kids}
+b := 0;
+repeat
+ repeat
+ pdf_create_obj(obj_type_others, 0); {create a new node}
+ l := obj_ptr;
+ if b = 0 then
+ b := l; {first in this level}
+ if names_head = 0 then begin
+ names_head := l;
+ names_tail := l;
+ end else begin
+ obj_link(names_tail) := l;
+ names_tail := l;
+ end;
+ obj_link(names_tail) := 0;
+ @<Output the current node in this level@>;
+ until b = 0;
+ if k = l then begin
+ dests := l;
+ goto done1;
+ end;
+until false;
+done1:
+if (dests <> 0) or (pdf_names_toks <> null) then begin
+ pdf_new_dict(obj_type_others, 0, 1);
+ if (dests <> 0) then
+ pdf_indirect_ln("Dests", dests);
+ if pdf_names_toks <> null then begin
+ pdf_print_toks_ln(pdf_names_toks);
+ delete_toks(pdf_names_toks);
+ end;
+ pdf_end_dict;
+ names_tree := obj_ptr;
+end
+else
+ names_tree := 0
+
+@ @<Output the current node in this level@>=
+pdf_begin_dict(l, 1);
+j := 0;
+if is_names then begin
+ obj_info(l) := dest_names[k].objname;
+ pdf_print("/Names [");
+ repeat
+ pdf_print_str(dest_names[k].objname);
+ pdf_out(" ");
+ pdf_print_int(dest_names[k].objnum);
+ pdf_print(" 0 R ");
+ incr(j);
+ incr(k);
+ until (j = name_tree_kids_max) or (k = pdf_dest_names_ptr);
+ remove_last_space;
+ pdf_print_ln("]");
+ obj_aux(l) := dest_names[k - 1].objname;
+ if k = pdf_dest_names_ptr then begin
+ is_names := false;
+ k := names_head;
+ b := 0;
+ end;
+end
+else begin
+ obj_info(l) := obj_info(k);
+ pdf_print("/Kids [");
+ repeat
+ pdf_print_int(k);
+ pdf_print(" 0 R ");
+ incr(j);
+ obj_aux(l) := obj_aux(k);
+ k := obj_link(k);
+ until (j = name_tree_kids_max) or (k = b) or (obj_link(k) = 0);
+ remove_last_space;
+ pdf_print_ln("]");
+ if k = b then
+ b := 0;
+end;
+pdf_print("/Limits [");
+pdf_print_str(obj_info(l));
+pdf_out(" ");
+pdf_print_str(obj_aux(l));
+pdf_print_ln("]");
+pdf_end_dict;
+
+@ @<Output the catalog object@>=
+pdf_new_dict(obj_type_others, 0, 1);
+root := obj_ptr;
+pdf_print_ln("/Type /Catalog");
+pdf_indirect_ln("Pages", pdf_last_pages);
+if threads <> 0 then
+ pdf_indirect_ln("Threads", threads);
+if outlines <> 0 then
+ pdf_indirect_ln("Outlines", outlines);
+if names_tree <> 0 then
+ pdf_indirect_ln("Names", names_tree);
+if pdf_catalog_toks <> null then begin
+ pdf_print_toks_ln(pdf_catalog_toks);
+ delete_toks(pdf_catalog_toks);
+end;
+if pdf_catalog_openaction <> 0 then
+ pdf_indirect_ln("OpenAction", pdf_catalog_openaction);
+pdf_end_dict
+
+@ If the same keys in a dictionary are given several times, then it is not
+defined which value is choosen by an application. Therefore the keys
+|/Producer| and |/Creator| are only set if the token list
+|pdf_info_toks| converted to a string does not contain these key strings.
+
+@p function substr_of_str(s, t: str_number):boolean;
+label continue,exit;
+var j, k, kk: pool_pointer; {running indices}
+begin
+ k:=str_start_macro(t);
+ while (k < str_start_macro(t+1) - length(s)) do begin
+ j:=str_start_macro(s);
+ kk:=k;
+ while (j < str_start_macro(s+1)) do begin
+ if str_pool[j] <> str_pool[kk] then
+ goto continue;
+ incr(j);
+ incr(kk);
+ end;
+ substr_of_str:=true;
+ return;
+ continue: incr(k);
+ end;
+ substr_of_str:=false;
+end;
+
+procedure pdf_print_info; {print info object}
+var s: str_number;
+ creator_given, producer_given, creationdate_given, moddate_given, trapped_given: boolean;
+begin
+ s:="";
+ pdf_new_dict(obj_type_others, 0, 3); {keep Info readable unless explicitely forced}
+ creator_given:=false;
+ producer_given:=false;
+ creationdate_given:=false;
+ moddate_given:=false;
+ trapped_given:=false;
+ if pdf_info_toks <> null then begin
+ s:=tokens_to_string(pdf_info_toks);
+ creator_given:=substr_of_str("/Creator", s);
+ producer_given:=substr_of_str("/Producer", s);
+ creationdate_given:=substr_of_str("/CreationDate", s);
+ moddate_given:=substr_of_str("/ModDate", s);
+ trapped_given:=substr_of_str("/Trapped", s);
+ end;
+ if not producer_given then begin
+ @<Print the Producer key@>;
+ end;
+ if pdf_info_toks <> null then begin
+ if length(s) > 0 then begin
+ pdf_print_ln(s);
+ end;
+ flush_str(s);
+ delete_toks(pdf_info_toks);
+ end;
+ if not creator_given then
+ pdf_str_entry_ln("Creator", "TeX");
+ if not creationdate_given then begin
+ @<Print the CreationDate key@>;
+ end;
+ if not moddate_given then begin
+ @<Print the ModDate key@>;
+ end;
+ if not trapped_given then begin
+ pdf_print_ln("/Trapped /False");
+ end;
+ pdf_str_entry_ln("PTEX.Fullbanner", pdftex_banner);
+ pdf_end_dict;
+end;
+
+@ @<Print the Producer key@>=
+pdf_print("/Producer (luaTeX-");
+pdf_print_int(luatex_version div 100);
+pdf_out(".");
+pdf_print_int(luatex_version mod 100);
+pdf_out(".");
+pdf_print(luatex_revision);
+pdf_print_ln(")")
+
+@ @<Print the CreationDate key@>=
+print_creation_date;
+
+@ @<Print the ModDate key@>=
+print_mod_date;
+
+@ @<Glob...@>=
+@!pdftex_banner: str_number; {the complete banner}
+
+@ @<Output the |obj_tab|@>=
+l := 0;
+for k := 1 to sys_obj_ptr do
+ if obj_offset(k) = 0 then begin
+ obj_link(l) := k;
+ l := k;
+ end;
+obj_link(l) := 0;
+pdf_save_offset := pdf_offset;
+pdf_print_ln("xref");
+pdf_print("0 "); pdf_print_int_ln(obj_ptr + 1);
+pdf_print_fw_int(obj_link(0), 10);
+pdf_print_ln(" 65535 f ");
+for k := 1 to obj_ptr do begin
+ if obj_offset(k) = 0 then begin
+ pdf_print_fw_int(obj_link(k), 10);
+ pdf_print_ln(" 00000 f ");
+ end
+ else begin
+ pdf_print_fw_int(obj_offset(k), 10);
+ pdf_print_ln(" 00000 n ");
+ end;
+end
+
+@ @<Output the cross-reference stream dictionary@>=
+pdf_new_dict(obj_type_others, 0, 0);
+if obj_offset(sys_obj_ptr) > 16777215 then
+ xref_offset_width := 4
+else if obj_offset(sys_obj_ptr) > 65535 then
+ xref_offset_width := 3
+else if obj_offset(sys_obj_ptr) > 255 then
+ xref_offset_width := 2
+else
+ xref_offset_width := 1;
+l := 0;
+for k := 1 to sys_obj_ptr do
+ if obj_offset(k) = 0 then begin
+ obj_link(l) := k;
+ l := k;
+ end;
+obj_link(l) := 0;
+pdf_print_ln("/Type /XRef");
+pdf_print("/Index [0 ");
+pdf_print_int(obj_ptr);
+pdf_print_ln("]");
+pdf_int_entry_ln("Size", obj_ptr);
+pdf_print("/W [1 ");
+pdf_print_int(xref_offset_width);
+pdf_print_ln(" 1]");
+pdf_indirect_ln("Root", root);
+pdf_indirect_ln("Info", obj_ptr - 1);
+if pdf_trailer_toks <> null then begin
+ pdf_print_toks_ln(pdf_trailer_toks);
+ delete_toks(pdf_trailer_toks);
+end;
+print_ID(output_file_name);
+pdf_print_nl;
+pdf_begin_stream;
+for k := 0 to sys_obj_ptr do begin
+ if obj_offset(k) = 0 then begin {a free object}
+ pdf_out(0);
+ pdf_out_bytes(obj_link(k), xref_offset_width);
+ pdf_out(255);
+ end else begin
+ if obj_os_idx(k) = -1 then begin {object not in object stream}
+ pdf_out(1);
+ pdf_out_bytes(obj_offset(k), xref_offset_width);
+ pdf_out(0);
+ end else begin {object in object stream}
+ pdf_out(2);
+ pdf_out_bytes(obj_offset(k), xref_offset_width);
+ pdf_out(obj_os_idx(k));
+ end;
+ end;
+end;
+pdf_end_stream;
+
+@ @<Output the trailer@>=
+if not pdf_os_enable then begin
+ pdf_print_ln("trailer");
+ pdf_print("<< ");
+ pdf_int_entry_ln("Size", sys_obj_ptr + 1);
+ pdf_indirect_ln("Root", root);
+ pdf_indirect_ln("Info", sys_obj_ptr);
+ if pdf_trailer_toks <> null then begin
+ pdf_print_toks_ln(pdf_trailer_toks);
+ delete_toks(pdf_trailer_toks);
+ end;
+ print_ID(output_file_name);
+ pdf_print_ln(" >>");
+end;
+pdf_print_ln("startxref");
+if pdf_os_enable then
+ pdf_print_int_ln(obj_offset(sys_obj_ptr))
+else
+ pdf_print_int_ln(pdf_save_offset);
+pdf_print_ln("%%EOF")
+
+@* \[33] Packaging.
+We're essentially done with the parts of \TeX\ that are concerned with
+the input (|get_next|) and the output (|ship_out|). So it's time to
+get heavily into the remaining part, which does the real work of typesetting.
+
+After lists are constructed, \TeX\ wraps them up and puts them into boxes.
+Two major subroutines are given the responsibility for this task: |hpack|
+applies to horizontal lists (hlists) and |vpack| applies to vertical lists
+(vlists). The main duty of |hpack| and |vpack| is to compute the dimensions
+of the resulting boxes, and to adjust the glue if one of those dimensions
+is pre-specified. The computed sizes normally enclose all of the material
+inside the new box; but some items may stick out if negative glue is used,
+if the box is overfull, or if a \.{\\vbox} includes other boxes that have
+been shifted left.
+
+The subroutine call |hpack(p,w,m)| returns a pointer to an |hlist_node|
+for a box containing the hlist that starts at |p|. Parameter |w| specifies
+a width; and parameter |m| is either `|exactly|' or `|additional|'. Thus,
+|hpack(p,w,exactly)| produces a box whose width is exactly |w|, while
+|hpack(p,w,additional)| yields a box whose width is the natural width plus
+|w|. It is convenient to define a macro called `|natural|' to cover the
+most common case, so that we can say |hpack(p,natural)| to get a box that
+has the natural width of list |p|.
+
+Similarly, |vpack(p,w,m)| returns a pointer to a |vlist_node| for a
+box containing the vlist that starts at |p|. In this case |w| represents
+a height instead of a width; the parameter |m| is interpreted as in |hpack|.
+
+@d exactly=0 {a box dimension is pre-specified}
+@d additional=1 {a box dimension is increased from the natural one}
+@d natural==0,additional {shorthand for parameters to |hpack| and |vpack|}
+
+@<Glob...@>=
+pack_direction:integer;
+spec_direction:integer;
+
+@ The parameters to |hpack| and |vpack| correspond to \TeX's primitives
+like `\.{\\hbox} \.{to} \.{300pt}', `\.{\\hbox} \.{spread} \.{10pt}'; note
+that `\.{\\hbox}' with no dimension following it is equivalent to
+`\.{\\hbox} \.{spread} \.{0pt}'. The |scan_spec| subroutine scans such
+constructions in the user's input, including the mandatory left brace that
+follows them, and it puts the specification onto |save_stack| so that the
+desired box can later be obtained by executing the following code:
+$$\vbox{\halign{#\hfil\cr
+|save_ptr:=save_ptr-2;|\cr
+|hpack(p,saved(1),saved(0)).|\cr}}$$
+Special care is necessary to ensure that the special |save_stack| codes
+are placed just below the new group code, because scanning can change
+|save_stack| when \.{\\csname} appears.
+
+@p procedure scan_spec(@!c:group_code;@!three_codes:boolean);
+ {scans a box specification and left brace}
+label found, continue;
+var @!s:integer; {temporarily saved value}
+i:integer; v:integer;
+@!spec_code:exactly..additional;
+attr_list:halfword;
+begin s:=0;
+if attr_list_cache=cache_disabled then update_attribute_cache;
+attr_list:=attr_list_cache;
+if three_codes then begin
+ s:=saved(0);
+continue:
+ if scan_keyword("attr") then begin
+ scan_register_num; i:=cur_val;
+ scan_optional_equals;
+ scan_int; v:=cur_val;
+ if (attr_list<>null) and (attr_list=attr_list_cache) then begin
+ attr_list:=copy_attribute_list(attr_list_cache);
+ add_node_attr_ref(attr_list); {will be used once}
+ end;
+ attr_list:=do_set_attribute(attr_list,i,v);
+ goto continue;
+ end;
+ if scan_keyword("dir") then begin
+ scan_direction; spec_direction:=cur_val;
+ goto continue;
+ end;
+ end;
+if attr_list=attr_list_cache then begin add_node_attr_ref(attr_list); end;
+if scan_keyword("to") then spec_code:=exactly
+@.to@>
+else if scan_keyword("spread") then spec_code:=additional
+@.spread@>
+else begin spec_code:=additional; cur_val:=0;
+ goto found;
+ end;
+scan_normal_dimen;
+found: if three_codes then begin
+ saved(0):=s;
+ saved(1):=spec_code;
+ saved(2):=cur_val;
+ saved(3):=spec_direction;
+ @<DIR: Adjust |text_dir_ptr| for |scan_spec|@>;
+ saved(5):=attr_list;
+ save_ptr:=save_ptr+6;
+ new_save_level(c); scan_left_brace;
+ eq_word_define(dir_base+body_direction_code,spec_direction);
+ eq_word_define(dir_base+par_direction_code,spec_direction);
+ eq_word_define(dir_base+text_direction_code,spec_direction);
+ eq_word_define(int_base+level_local_dir_code,cur_level);
+ end
+ else begin
+ saved(0):=spec_code;
+ saved(1):=cur_val;
+ save_ptr:=save_ptr+2;
+ new_save_level(c); scan_left_brace;
+ end;
+spec_direction:=-1;
+end;
+
+@ To figure out the glue setting, |hpack| and |vpack| determine how much
+stretchability and shrinkability are present, considering all four orders
+of infinity. The highest order of infinity that has a nonzero coefficient
+is then used as if no other orders were present.
+
+For example, suppose that the given list contains six glue nodes with
+the respective stretchabilities 3pt, 8fill, 5fil, 6pt, $-3$fil, $-8$fill.
+Then the total is essentially 2fil; and if a total additional space of 6pt
+is to be achieved by stretching, the actual amounts of stretch will be
+0pt, 0pt, 15pt, 0pt, $-9$pt, and 0pt, since only `fil' glue will be
+considered. (The `fill' glue is therefore not really stretching infinitely
+with respect to `fil'; nobody would actually want that to happen.)
+
+The arrays |total_stretch| and |total_shrink| are used to determine how much
+glue of each kind is present. A global variable |last_badness| is used
+to implement \.{\\badness}.
+
+@<Glob...@>=
+@!total_stretch, @!total_shrink: array[glue_ord] of scaled;
+ {glue found by |hpack| or |vpack|}
+@!last_badness:integer; {badness of the most recently packaged box}
+
+@ If the global variable |adjust_tail| is non-null, the |hpack| routine
+also removes all occurrences of |ins_node|, |mark_node|, and |adjust_node|
+items and appends the resulting material onto the list that ends at
+location |adjust_tail|.
+
+@< Glob...@>=
+@!adjust_tail:pointer; {tail of adjustment list}
+
+@ @<Set init...@>=adjust_tail:=null; last_badness:=0;
+
+@ @<Glob...@>=
+@!font_expand_ratio: integer; {current expansion ratio}
+@!last_leftmost_char: pointer;
+@!last_rightmost_char: pointer;
+
+@ @d cal_margin_kern_var(#) ==
+begin
+ character(cp) := character(#);
+ font(cp) := font(#);
+ do_subst_font(cp, 1000);
+ if font(cp) <> font(#) then
+ margin_kern_stretch := margin_kern_stretch + left_pw(#) - left_pw(cp);
+ font(cp) := font(#);
+ do_subst_font(cp, -1000);
+ if font(cp) <> font(#) then
+ margin_kern_shrink := margin_kern_shrink + left_pw(cp) - left_pw(#);
+end
+
+@ @<Glob...@>=
+next_char_p:pointer; {pointer to the next char of an implicit kern}
+prev_char_p:pointer; {pointer to the previous char of an implicit kern}
+
+@ This procedure is called repeatedly from inside the line break algorithm.
+
+@p procedure set_prev_char_p(p:pointer);
+begin prev_char_p:=p;
+end;
+
+@ Here is |hpack|, which is place where we do font substituting when
+font expansion is being used. We define some constants used when calling
+|hpack| to deal with font expansion.
+
+@d cal_expand_ratio == 2 {calculate amount for font expansion after breaking
+ paragraph into lines}
+@d subst_ex_font == 3 {substitute fonts}
+
+@d substituted = 3 {|subtype| of kern nodes that should be substituted}
+
+@d left_pw(#) == char_pw(#, left_side)
+@d right_pw(#) == char_pw(#, right_side)
+
+@p function char_stretch(p:halfword): scaled;
+var k: internal_font_number;
+ dw: scaled;
+ ef: integer;
+ f: internal_font_number;
+ c: integer;
+begin
+ f := font(p);
+ c := character(p);
+ char_stretch := 0;
+ k := pdf_font_stretch(f);
+ ef := get_ef_code(f, c);
+ if (k <> null_font) and (ef > 0) then begin
+ dw := char_width(k,c) - char_width(f,c);
+ if dw > 0 then
+ char_stretch := round_xn_over_d(dw, ef, 1000);
+ end;
+end;
+
+function char_shrink(p:halfword): scaled;
+var k: internal_font_number;
+ dw: scaled;
+ ef: integer;
+ f: internal_font_number;
+ c: integer;
+begin
+ f := font(p);
+ c := character(p);
+ char_shrink := 0;
+ k := pdf_font_shrink(f);
+ ef := get_ef_code(f, c);
+ if (k <> null_font) and (ef > 0) then begin
+ dw := char_width(f,c) - char_width(k,c);
+ if dw > 0 then
+ char_shrink := round_xn_over_d(dw, ef, 1000);
+ end;
+end;
+
+function kern_stretch(p: pointer): scaled;
+var l, r: pointer;
+ d: scaled;
+begin
+ kern_stretch := 0;
+ if (prev_char_p = null) or (vlink(prev_char_p) <> p) or (vlink(p) = null)
+ then
+ return;
+ l := prev_char_p;
+ r := vlink(p);
+ if not (is_char_node(l) and is_char_node(r) and
+ (font(l) = font(r)) and
+ (pdf_font_stretch(font(l)) <> null_font))
+ then
+ return;
+ d := get_kern(pdf_font_stretch(font(l)), character(l), character(r));
+ kern_stretch := round_xn_over_d(d - width(p),
+ get_ef_code(font(l), character(l)), 1000);
+end;
+
+function kern_shrink(p: pointer): scaled;
+var l, r: pointer;
+ d: scaled;
+begin
+ kern_shrink := 0;
+ if (prev_char_p = null) or (vlink(prev_char_p) <> p) or (vlink(p) = null)
+ then
+ return;
+ l := prev_char_p;
+ r := vlink(p);
+ if not (is_char_node(l) and is_char_node(r) and
+ (font(l) = font(r)) and
+ (pdf_font_shrink(font(l)) <> null_font))
+ then
+ return;
+ d := get_kern(pdf_font_shrink(font(l)), character(l), character(r));
+ kern_shrink := round_xn_over_d(width(p) - d,
+ get_ef_code(font(l), character(l)), 1000);
+end;
+
+procedure do_subst_font(p: pointer; ex_ratio: integer);
+var f, k: internal_font_number;
+ r: pointer;
+ ef: integer;
+begin
+ if not is_char_node(p) and (type(p) = disc_node) then begin
+ r := vlink(pre_break(p));
+ while r <> null do begin
+ if is_char_node(r) then
+ do_subst_font(r, ex_ratio);
+ r := vlink(r);
+ end;
+ r := vlink(post_break(p));
+ while r <> null do begin
+ if is_char_node(r) then
+ do_subst_font(r, ex_ratio);
+ r := vlink(r);
+ end;
+ r := vlink(no_break(p));
+ while r <> null do begin
+ if is_char_node(r) then
+ do_subst_font(r, ex_ratio);
+ r := vlink(r);
+ end;
+ return;
+ end;
+ if is_char_node(p) then
+ r := p
+ else begin
+ {|short_display_n(p, 5);|}
+ pdf_error("font expansion", "invalid node type");
+ return;
+ end;
+ f := font(r);
+ ef := get_ef_code(f, character(r));
+ if ef = 0 then
+ return;
+ if (pdf_font_expand_ratio(f)=0) and
+ (pdf_font_stretch(f) <> null_font) and
+ (ex_ratio > 0) then
+ k := expand_font(f, ext_xn_over_d(ex_ratio*ef,
+ pdf_font_expand_ratio(pdf_font_stretch(f)),
+ 1000000))
+ else if (pdf_font_expand_ratio(f)=0) and
+ (pdf_font_shrink(f) <> null_font) and (ex_ratio < 0) then
+ k := expand_font(f, ext_xn_over_d(ex_ratio*ef,
+ -pdf_font_expand_ratio(pdf_font_shrink(f)),
+ 1000000))
+ else
+ k := f;
+ if k <> f then begin
+ font(r) := k;
+ if not is_char_node(p) then begin
+ r := lig_ptr(p);
+ while r <> null do begin
+ font(r) := k;
+ r := vlink(r);
+ end;
+ end;
+ end;
+end;
+
+function char_pw(p: pointer; side: small_number): scaled;
+var f: internal_font_number;
+ c: integer;
+begin
+ char_pw := 0;
+ if side = left_side then
+ last_leftmost_char := null
+ else
+ last_rightmost_char := null;
+ if p = null then
+ return;
+ if not is_char_node(p) then
+ return;
+ f := font(p);
+ if side = left_side then begin
+ c := get_lp_code(f, character(p));
+ last_leftmost_char := p;
+ end
+ else begin
+ c := get_rp_code(f, character(p));
+ last_rightmost_char := p;
+ end;
+ if c = 0 then
+ return;
+ char_pw :=
+ round_xn_over_d(quad(f), c, 1000);
+end;
+
+function new_margin_kern(w: scaled; p: pointer; side: small_number): pointer;
+var k,q: pointer;
+begin
+ k := new_node(margin_kern_node,side);
+ width(k) := w;
+ if p = null then
+ pdf_error("margin kerning", "invalid pointer to marginal char node");
+ q := new_char(font(p), character(p)); margin_char(k):=q;
+ new_margin_kern := k;
+end;
+
+function hpack(@!p:pointer;@!w:scaled;@!m:small_number):pointer;
+label reswitch,common_ending,exit;
+var r:pointer; {the box node that will be returned}
+@!q:pointer; {trails behind |p|}
+@!h,@!d,@!x:scaled; {height, depth, and natural width}
+@!s:scaled; {shift amount}
+@!g:pointer; {points to a glue specification}
+@!o:glue_ord; {order of infinity}
+@!f:internal_font_number; {the font in a |char_node|}
+@!dir_tmp,dir_ptr:pointer; {for managing the direction stack}
+@!hpack_dir:integer; {the current direction}
+@!disc_level:integer;
+pack_interrupt:array[0..255] of halfword;
+font_stretch: scaled;
+font_shrink: scaled;
+k: scaled;
+begin last_badness:=0; r:=new_node(hlist_node,min_quarterword);
+if pack_direction=-1 then
+ box_dir(r):=text_direction
+else begin
+ box_dir(r):=pack_direction; pack_direction:=-1;
+ end;
+hpack_dir:=box_dir(r);
+dir_ptr:=null;
+push_dir(hpack_dir);
+q:=r+list_offset; vlink(q):=p;@/
+if m = cal_expand_ratio then begin
+ prev_char_p := null;
+ font_stretch := 0;
+ font_shrink := 0;
+ font_expand_ratio := 0;
+end;
+@{
+if m = subst_ex_font then begin
+ wterm_ln('replacing ', font_expand_ratio:1);
+end;
+@}
+h:=0; @<Clear dimensions to zero@>;
+disc_level:=0;
+reswitch:
+while (p<>null)or(disc_level>0) do begin
+ if p=null then begin
+ decr(disc_level);
+ p:=pack_interrupt[disc_level];
+ goto reswitch;
+ end;
+ @<Examine node |p| in the hlist, taking account of its effect
+ on the dimensions of the new box, or moving it to the adjustment list;
+ then advance |p| to the next node@>;
+ end;
+if adjust_tail<>null then vlink(adjust_tail):=null;
+if pre_adjust_tail<>null then vlink(pre_adjust_tail):=null;
+height(r):=h; depth(r):=d;@/
+@<Determine the value of |width(r)| and the appropriate glue setting;
+ then |return| or |goto common_ending|@>;
+common_ending: @<Finish issuing a diagnostic message
+ for an overfull or underfull hbox@>;
+exit:
+if (m = cal_expand_ratio) and (font_expand_ratio <> 0) then begin
+ font_expand_ratio := fix_int(font_expand_ratio, -1000, 1000);
+ q := list_ptr(r);
+ list_ptr(r):=null; flush_node(r);
+ r:=hpack(q, w, subst_ex_font);
+end;
+while dir_ptr<>null do pop_dir_node;
+hpack:=r;
+end;
+
+function filtered_hpack(@!p:pointer;@!qt:pointer;@!w:scaled;@!m:small_number;@!grp:integer):pointer;
+var q:pointer;
+ d:integer; { a direction }
+begin
+ new_hyphenation(p,qt);
+ call_func(new_ligkern(p,qt)); {don't care about the tail in this case}
+ q:=vlink(p);
+ q:=lua_hpack_filter(q,w,m,grp);
+ filtered_hpack:=hpack(q,w,m);
+end;
+
+@ @<Clear dimensions to zero@>=
+d:=0; x:=0;
+total_stretch[normal]:=0; total_shrink[normal]:=0;
+total_stretch[sfi]:=0; total_shrink[sfi]:=0;
+total_stretch[fil]:=0; total_shrink[fil]:=0;
+total_stretch[fill]:=0; total_shrink[fill]:=0;
+total_stretch[filll]:=0; total_shrink[filll]:=0
+
+@ @<Examine node |p| in the hlist, taking account of its effect...@>=
+@^inner loop@>
+begin while is_char_node(p) do
+ @<Incorporate character dimensions into the dimensions of
+ the hbox that will contain~it, then move to the next node@>;
+if p<>null then
+ begin case type(p) of
+ hlist_node,vlist_node,rule_node,unset_node:
+ @<Incorporate box dimensions into the dimensions of
+ the hbox that will contain~it@>;
+ ins_node,mark_node,adjust_node: begin if adjust_tail<>null then
+ @<Transfer node |p| to the adjustment list@>; end;
+ whatsit_node:@<Incorporate a whatsit node into an hbox@>;
+ glue_node:@<Incorporate glue into the horizontal totals@>;
+ margin_kern_node: begin
+ if m = cal_expand_ratio then begin
+ f := font(margin_char(p));
+ do_subst_font(margin_char(p), 1000);
+ if f <> font(margin_char(p)) then
+ font_stretch := font_stretch - width(p) -
+ char_pw(margin_char(p), subtype(p));
+ font(margin_char(p)) := f;
+ do_subst_font(margin_char(p), -1000);
+ if f <> font(margin_char(p)) then
+ font_shrink := font_shrink - width(p) -
+ char_pw(margin_char(p), subtype(p));
+ font(margin_char(p)) := f;
+ end
+ else if m = subst_ex_font then begin
+ do_subst_font(margin_char(p), font_expand_ratio);
+ width(p) := -char_pw(margin_char(p), subtype(p));
+ end;
+ x := x + width(p);
+ end;
+ kern_node: begin
+ if subtype(p) = normal then begin
+ if m = cal_expand_ratio then begin
+ font_stretch := font_stretch + kern_stretch(p);
+ font_shrink := font_shrink + kern_shrink(p);
+ end
+ else if m = subst_ex_font then begin
+ if font_expand_ratio > 0 then
+ k := kern_stretch(p)
+ else if font_expand_ratio < 0 then
+ k := kern_shrink(p)
+ else
+ pdfassert(0);
+ if k <> 0 then
+ width(p) := get_kern(font(prev_char_p),
+ character(prev_char_p),
+ character(vlink(p)))
+ end;
+ end;
+ x := x + width(p);
+ end;
+ math_node: x:=x+surround(p);
+ disc_node:
+ begin
+ if m = subst_ex_font then do_subst_font(p, font_expand_ratio);
+ if vlink(no_break(p))<>null then begin
+ pack_interrupt[disc_level]:=vlink(p);
+ incr(disc_level);
+ p:=no_break(p);
+ end;
+ end;
+ othercases do_nothing
+ endcases;@/
+ p:=vlink(p);
+ end;
+end
+
+
+@ The code here implicitly uses the fact that running dimensions are
+indicated by |null_flag|, which will be ignored in the calculations
+because it is a highly negative number.
+
+@<Incorporate box dimensions into the dimensions of the hbox...@>=
+begin
+if (type(p)=hlist_node) or (type(p)=vlist_node) then begin
+ if dir_orthogonal(dir_primary[box_dir(p)])(dir_primary[hpack_dir]) then begin
+ x:=x+height(p)+depth(p);
+ s:=shift_amount(p);
+ if (width(p) div 2)-s>h then h:=(width(p) div 2)-s;
+ if (width(p) div 2)+s>d then d:=(width(p) div 2)+s;
+ end
+ else if (type(p)=hlist_node) and (is_mirrored(hpack_dir)) then begin
+ x:=x+width(p);
+ s:=shift_amount(p);
+ if depth(p)-s>h then h:=depth(p)-s;
+ if height(p)+s>d then d:=height(p)+s;
+ end
+ else begin
+ x:=x+width(p);
+ s:=shift_amount(p);
+ if height(p)-s>h then h:=height(p)-s;
+ if depth(p)+s>d then d:=depth(p)+s;
+ end
+ end
+else begin
+ x:=x+width(p);
+ if type(p)>=rule_node then s:=0 @+else s:=shift_amount(p);
+ if height(p)-s>h then h:=height(p)-s;
+ if depth(p)+s>d then d:=depth(p)+s;
+ end;
+end
+
+@ The following code is part of \TeX's inner loop; i.e., adding another
+character of text to the user's input will cause each of these instructions
+to be exercised one more time.
+@^inner loop@>
+
+@d add_char_stretch_end(#) == char_stretch(#)
+@d add_char_stretch(#) == # := # + add_char_stretch_end
+
+@d add_char_shrink_end(#) == char_shrink(#)
+@d add_char_shrink(#) == # := # + add_char_shrink_end
+
+@<Incorporate character dimensions into the dimensions of the hbox...@>=
+begin
+if m >= cal_expand_ratio then begin
+ prev_char_p := p;
+ case m of
+ cal_expand_ratio: begin
+ add_char_stretch(font_stretch)(p);
+ add_char_shrink(font_shrink)(p);
+ end;
+ subst_ex_font:
+ do_subst_font(p, font_expand_ratio);
+ endcases;
+end;
+f:=font(p);
+if is_rotated(hpack_dir) then begin
+ x:=x+glyph_height(p)+glyph_depth(p);@/
+ s:=glyph_width(p) div 2;@+if s>h then h:=s;@+if s>d then d:=s;
+ end
+else if dir_opposite(dir_tertiary[hpack_dir])(dir_tertiary[box_dir(r)])
+ then begin
+ x:=x+glyph_width(p);@/
+ s:=glyph_depth(p);@+if s>h then h:=s;
+ s:=glyph_height(p);@+if s>d then d:=s;
+ end
+else begin
+ x:=x+glyph_width(p);@/
+ s:=glyph_height(p);@+if s>h then h:=s;
+ s:=glyph_depth(p);@+if s>d then d:=s;
+ end;
+p:=vlink(p);
+end
+
+@ Although node |q| is not necessarily the immediate predecessor of node |p|,
+it always points to some node in the list preceding |p|. Thus, we can delete
+nodes by moving |q| when necessary. The algorithm takes linear time, and the
+extra computation does not intrude on the inner loop unless it is necessary
+to make a deletion.
+@^inner loop@>
+
+@<Glob...@>=
+@!pre_adjust_tail: pointer;
+
+@ @<Set init...@>=
+pre_adjust_tail := null;
+
+@ Materials in \.{\\vadjust} used with \.{pre} keyword will be appended to
+|pre_adjust_tail| instead of |adjust_tail|.
+
+@d update_adjust_list(#) == begin
+ vlink(#) := adjust_ptr(p);
+ while vlink(#) <> null do
+ # := vlink(#);
+end
+
+@<Transfer node |p| to the adjustment list@>=
+begin while vlink(q)<>p do q:=vlink(q);
+ if type(p) = adjust_node then begin
+ if adjust_pre(p) <> 0 then
+ update_adjust_list(pre_adjust_tail)
+ else
+ update_adjust_list(adjust_tail);
+ p := vlink(p);
+ adjust_ptr(vlink(q)):=null; flush_node(vlink(q));
+ end
+else begin vlink(adjust_tail):=p; adjust_tail:=p; p:=vlink(p);
+ end;
+vlink(q):=p; p:=q;
+end
+
+@ @<Incorporate glue into the horizontal totals@>=
+begin g:=glue_ptr(p); x:=x+width(g);@/
+o:=stretch_order(g); total_stretch[o]:=total_stretch[o]+stretch(g);
+o:=shrink_order(g); total_shrink[o]:=total_shrink[o]+shrink(g);
+if subtype(p)>=a_leaders then
+ begin g:=leader_ptr(p);
+ if height(g)>h then h:=height(g);
+ if depth(g)>d then d:=depth(g);
+ end;
+end
+
+@ When we get to the present part of the program, |x| is the natural width
+of the box being packaged.
+
+@<Determine the value of |width(r)| and the appropriate glue setting...@>=
+if m=additional then w:=x+w;
+width(r):=w; x:=w-x; {now |x| is the excess to be made up}
+if x=0 then
+ begin glue_sign(r):=normal; glue_order(r):=normal;
+ set_glue_ratio_zero(glue_set(r));
+ return;
+ end
+else if x>0 then @<Determine horizontal glue stretch setting, then |return|
+ or \hbox{|goto common_ending|}@>
+else @<Determine horizontal glue shrink setting, then |return|
+ or \hbox{|goto common_ending|}@>
+
+@ If |hpack| is called with |m=cal_expand_ratio| we calculate
+|font_expand_ratio| and return without checking for overfull or underfull box.
+
+@<Determine horizontal glue stretch setting...@>=
+begin @<Determine the stretch order@>;
+if (m = cal_expand_ratio) and (o = normal) and (font_stretch > 0) then begin
+ font_expand_ratio := divide_scaled_n(x, font_stretch, 1000.0);
+ return;
+end;
+glue_order(r):=o; glue_sign(r):=stretching;
+if total_stretch[o]<>0 then glue_set(r):=unfloat(x/total_stretch[o])
+@^real division@>
+else begin glue_sign(r):=normal;
+ set_glue_ratio_zero(glue_set(r)); {there's nothing to stretch}
+ end;
+if o=normal then if list_ptr(r)<>null then
+ @<Report an underfull hbox and |goto common_ending|, if this box
+ is sufficiently bad@>;
+return;
+end
+
+@ @<Determine the stretch order@>=
+if total_stretch[filll]<>0 then o:=filll
+else if total_stretch[fill]<>0 then o:=fill
+else if total_stretch[fil]<>0 then o:=fil
+else if total_stretch[sfi]<>0 then o:=sfi
+else o:=normal
+
+@ @<Report an underfull hbox and |goto common_ending|, if...@>=
+begin last_badness:=badness(x,total_stretch[normal]);
+if last_badness>hbadness then
+ begin print_ln;
+ if last_badness>100 then print_nl("Underfull")@+else print_nl("Loose");
+ print(" \hbox (badness "); print_int(last_badness);
+@.Underfull \\hbox...@>
+@.Loose \\hbox...@>
+ goto common_ending;
+ end;
+end
+
+@ In order to provide a decent indication of where an overfull or underfull
+box originated, we use a global variable |pack_begin_line| that is
+set nonzero only when |hpack| is being called by the paragraph builder
+or the alignment finishing routine.
+
+@<Glob...@>=
+@!pack_begin_line:integer; {source file line where the current paragraph
+ or alignment began; a negative value denotes alignment}
+
+@ @<Set init...@>=
+pack_begin_line:=0;
+
+@ @<Finish issuing a diagnostic message for an overfull or underfull hbox@>=
+if output_active then print(") has occurred while \output is active")
+else begin if pack_begin_line<>0 then
+ begin if pack_begin_line>0 then print(") in paragraph at lines ")
+ else print(") in alignment at lines ");
+ print_int(abs(pack_begin_line));
+ print("--");
+ end
+ else print(") detected at line ");
+ print_int(line);
+ end;
+print_ln;@/
+font_in_short_display:=null_font; short_display(list_ptr(r)); print_ln;@/
+begin_diagnostic; show_box(r); end_diagnostic(true)
+
+@ @<Determine horizontal glue shrink setting...@>=
+begin @<Determine the shrink order@>;
+if (m = cal_expand_ratio) and (o = normal) and (font_shrink > 0) then begin
+ font_expand_ratio := divide_scaled_n(x, font_shrink, 1000.0);
+ return;
+end;
+glue_order(r):=o; glue_sign(r):=shrinking;
+if total_shrink[o]<>0 then glue_set(r):=unfloat((-x)/total_shrink[o])
+@^real division@>
+else begin glue_sign(r):=normal;
+ set_glue_ratio_zero(glue_set(r)); {there's nothing to shrink}
+ end;
+if (total_shrink[o]<-x)and(o=normal)and(list_ptr(r)<>null) then
+ begin last_badness:=1000000;
+ set_glue_ratio_one(glue_set(r)); {use the maximum shrinkage}
+ @<Report an overfull hbox and |goto common_ending|, if this box
+ is sufficiently bad@>;
+ end
+else if o=normal then if list_ptr(r)<>null then
+ @<Report a tight hbox and |goto common_ending|, if this box
+ is sufficiently bad@>;
+return;
+end
+
+@ @<Determine the shrink order@>=
+if total_shrink[filll]<>0 then o:=filll
+else if total_shrink[fill]<>0 then o:=fill
+else if total_shrink[fil]<>0 then o:=fil
+else if total_shrink[sfi]<>0 then o:=sfi
+else o:=normal
+
+@ @<Report an overfull hbox and |goto common_ending|, if...@>=
+if (-x-total_shrink[normal]>hfuzz)or(hbadness<100) then
+ begin if (overfull_rule>0)and(-x-total_shrink[normal]>hfuzz) then
+ begin while vlink(q)<>null do q:=vlink(q);
+ vlink(q):=new_rule; rule_dir(vlink(q)):=box_dir(r);
+ width(vlink(q)):=overfull_rule;
+ end;
+ print_ln; print_nl("Overfull \hbox (");
+@.Overfull \\hbox...@>
+ print_scaled(-x-total_shrink[normal]); print("pt too wide");
+ goto common_ending;
+ end
+
+@ @<Report a tight hbox and |goto common_ending|, if...@>=
+begin last_badness:=badness(-x,total_shrink[normal]);
+if last_badness>hbadness then
+ begin print_ln; print_nl("Tight \hbox (badness "); print_int(last_badness);
+@.Tight \\hbox...@>
+ goto common_ending;
+ end;
+end
+
+@ The |vpack| subroutine is actually a special case of a slightly more
+general routine called |vpackage|, which has four parameters. The fourth
+parameter, which is |max_dimen| in the case of |vpack|, specifies the
+maximum depth of the page box that is constructed. The depth is first
+computed by the normal rules; if it exceeds this limit, the reference
+point is simply moved down until the limiting depth is attained.
+
+@d vpack(#)==vpackage(#,max_dimen) {special case of unconstrained depth}
+
+@p function vpackage(@!p:pointer;@!h:scaled;@!m:small_number;@!l:scaled):
+ pointer;
+label common_ending, exit;
+var r:pointer; {the box node that will be returned}
+@!w,@!d,@!x:scaled; {width, depth, and natural height}
+@!s:scaled; {shift amount}
+@!g:pointer; {points to a glue specification}
+@!o:glue_ord; {order of infinity}
+begin last_badness:=0;
+{pdfassert(p<>0);}
+r:=new_node(vlist_node,0);
+if pack_direction=-1 then
+ box_dir(r):=body_direction
+else begin
+ box_dir(r):=pack_direction; pack_direction:=-1;
+ end;
+subtype(r):=min_quarterword; shift_amount(r):=0;
+list_ptr(r):=p;@/
+w:=0; @<Clear dimensions to zero@>;
+while p<>null do @<Examine node |p| in the vlist, taking account of its effect
+ on the dimensions of the new box; then advance |p| to the next node@>;
+width(r):=w;
+if d>l then
+ begin x:=x+d-l; depth(r):=l;
+ end
+else depth(r):=d;
+@<Determine the value of |height(r)| and the appropriate glue setting;
+ then |return| or |goto common_ending|@>;
+common_ending: @<Finish issuing a diagnostic message
+ for an overfull or underfull vbox@>;
+exit: vpackage:=r;
+end;
+
+function filtered_vpackage(@!p:pointer;@!h:scaled;@!m:small_number;@!l:scaled;@!grp:integer):pointer;
+var q:pointer;
+begin
+ q:=p;
+ q:=lua_vpack_filter(q,h,m,l,grp);
+ filtered_vpackage:=vpackage(q,h,m,l);
+end;
+
+@ @<Examine node |p| in the vlist, taking account of its effect...@>=
+begin if is_char_node(p) then confusion("vpack")
+@:this can't happen vpack}{\quad vpack@>
+else case type(p) of
+ hlist_node,vlist_node,rule_node,unset_node:
+ @<Incorporate box dimensions into the dimensions of
+ the vbox that will contain~it@>;
+ whatsit_node:@<Incorporate a whatsit node into a vbox@>;
+ glue_node: @<Incorporate glue into the vertical totals@>;
+ kern_node: begin x:=x+d+width(p); d:=0;
+ end;
+ othercases do_nothing
+ endcases;
+p:=vlink(p);
+end
+
+@ @<Incorporate box dimensions into the dimensions of the vbox...@>=
+begin
+if (type(p)=hlist_node) or (type(p)=vlist_node) then begin
+ if dir_orthogonal(dir_primary[box_dir(p)])(dir_primary[box_dir(r)]) then begin
+ x:=x+d+(width(p) div 2); d:=width(p) div 2;
+ s:=shift_amount(p);
+ if depth(p)+height(p)+s>w then w:=depth(p)+height(p)+s;
+ end
+ else if (type(p)=hlist_node) and (is_mirrored(box_dir(p))) then begin
+ x:=x+d+depth(p); d:=height(p);
+ s:=shift_amount(p);
+ if width(p)+s>w then w:=width(p)+s;
+ end
+ else begin
+ x:=x+d+height(p); d:=depth(p);
+ s:=shift_amount(p);
+ if width(p)+s>w then w:=width(p)+s;
+ end
+ end
+else
+ begin x:=x+d+height(p); d:=depth(p);
+ if type(p)>=rule_node then s:=0 @+else s:=shift_amount(p);
+ if width(p)+s>w then w:=width(p)+s;
+ end;
+end
+
+@ @<Incorporate glue into the vertical totals@>=
+begin x:=x+d; d:=0;@/
+g:=glue_ptr(p); x:=x+width(g);@/
+o:=stretch_order(g); total_stretch[o]:=total_stretch[o]+stretch(g);
+o:=shrink_order(g); total_shrink[o]:=total_shrink[o]+shrink(g);
+if subtype(p)>=a_leaders then
+ begin g:=leader_ptr(p);
+ if width(g)>w then w:=width(g);
+ end;
+end
+
+@ When we get to the present part of the program, |x| is the natural height
+of the box being packaged.
+
+@<Determine the value of |height(r)| and the appropriate glue setting...@>=
+if m=additional then h:=x+h;
+height(r):=h; x:=h-x; {now |x| is the excess to be made up}
+if x=0 then
+ begin glue_sign(r):=normal; glue_order(r):=normal;
+ set_glue_ratio_zero(glue_set(r));
+ return;
+ end
+else if x>0 then @<Determine vertical glue stretch setting, then |return|
+ or \hbox{|goto common_ending|}@>
+else @<Determine vertical glue shrink setting, then |return|
+ or \hbox{|goto common_ending|}@>
+
+@ @<Determine vertical glue stretch setting...@>=
+begin @<Determine the stretch order@>;
+glue_order(r):=o; glue_sign(r):=stretching;
+if total_stretch[o]<>0 then glue_set(r):=unfloat(x/total_stretch[o])
+@^real division@>
+else begin glue_sign(r):=normal;
+ set_glue_ratio_zero(glue_set(r)); {there's nothing to stretch}
+ end;
+if o=normal then if list_ptr(r)<>null then
+ @<Report an underfull vbox and |goto common_ending|, if this box
+ is sufficiently bad@>;
+return;
+end
+
+@ @<Report an underfull vbox and |goto common_ending|, if...@>=
+begin last_badness:=badness(x,total_stretch[normal]);
+if last_badness>vbadness then
+ begin print_ln;
+ if last_badness>100 then print_nl("Underfull")@+else print_nl("Loose");
+ print(" \vbox (badness "); print_int(last_badness);
+@.Underfull \\vbox...@>
+@.Loose \\vbox...@>
+ goto common_ending;
+ end;
+end
+
+@ @<Finish issuing a diagnostic message for an overfull or underfull vbox@>=
+if output_active then print(") has occurred while \output is active")
+else begin if pack_begin_line<>0 then {it's actually negative}
+ begin print(") in alignment at lines ");
+ print_int(abs(pack_begin_line));
+ print("--");
+ end
+ else print(") detected at line ");
+ print_int(line);
+ print_ln;@/
+ end;
+begin_diagnostic; show_box(r); end_diagnostic(true)
+
+@ @<Determine vertical glue shrink setting...@>=
+begin @<Determine the shrink order@>;
+glue_order(r):=o; glue_sign(r):=shrinking;
+if total_shrink[o]<>0 then glue_set(r):=unfloat((-x)/total_shrink[o])
+@^real division@>
+else begin glue_sign(r):=normal;
+ set_glue_ratio_zero(glue_set(r)); {there's nothing to shrink}
+ end;
+if (total_shrink[o]<-x)and(o=normal)and(list_ptr(r)<>null) then
+ begin last_badness:=1000000;
+ set_glue_ratio_one(glue_set(r)); {use the maximum shrinkage}
+ @<Report an overfull vbox and |goto common_ending|, if this box
+ is sufficiently bad@>;
+ end
+else if o=normal then if list_ptr(r)<>null then
+ @<Report a tight vbox and |goto common_ending|, if this box
+ is sufficiently bad@>;
+return;
+end
+
+@ @<Report an overfull vbox and |goto common_ending|, if...@>=
+if (-x-total_shrink[normal]>vfuzz)or(vbadness<100) then
+ begin print_ln; print_nl("Overfull \vbox (");
+@.Overfull \\vbox...@>
+ print_scaled(-x-total_shrink[normal]); print("pt too high");
+ goto common_ending;
+ end
+
+@ @<Report a tight vbox and |goto common_ending|, if...@>=
+begin last_badness:=badness(-x,total_shrink[normal]);
+if last_badness>vbadness then
+ begin print_ln; print_nl("Tight \vbox (badness "); print_int(last_badness);
+@.Tight \\vbox...@>
+ goto common_ending;
+ end;
+end
+
+@ When a box is being appended to the current vertical list, the
+baselineskip calculation is handled by the |append_to_vlist| routine.
+
+@p procedure append_to_vlist(@!b:pointer);
+var d:scaled; {deficiency of space between baselines}
+@!p:pointer; {a new glue specification}
+begin if prev_depth>ignore_depth then
+ begin
+ if (type(b)=hlist_node) and (is_mirrored(box_dir(b))) then
+ d:=width(baseline_skip)-prev_depth-depth(b)
+ else
+ d:=width(baseline_skip)-prev_depth-height(b);
+ if d<line_skip_limit then p:=new_param_glue(line_skip_code)
+ else begin p:=new_skip_param(baseline_skip_code);
+ width(temp_ptr):=d; {|temp_ptr=glue_ptr(p)|}
+ end;
+ vlink(tail):=p; tail:=p;
+ end;
+vlink(tail):=b; tail:=b;
+if (type(b)=hlist_node) and (is_mirrored(box_dir(b))) then
+ prev_depth:=height(b)
+else
+ prev_depth:=depth(b);
+end;
+
+@* \[34] Data structures for math mode.
+When \TeX\ reads a formula that is enclosed between \.\$'s, it constructs an
+{\sl mlist}, which is essentially a tree structure representing that
+formula. An mlist is a linear sequence of items, but we can regard it as
+a tree structure because mlists can appear within mlists. For example, many
+of the entries can be subscripted or superscripted, and such ``scripts''
+are mlists in their own right.
+
+An entire formula is parsed into such a tree before any of the actual
+typesetting is done, because the current style of type is usually not
+known until the formula has been fully scanned. For example, when the
+formula `\.{\$a+b \\over c+d\$}' is being read, there is no way to tell
+that `\.{a+b}' will be in script size until `\.{\\over}' has appeared.
+
+During the scanning process, each element of the mlist being built is
+classified as a relation, a binary operator, an open parenthesis, etc.,
+or as a construct like `\.{\\sqrt}' that must be built up. This classification
+appears in the mlist data structure.
+
+After a formula has been fully scanned, the mlist is converted to an hlist
+so that it can be incorporated into the surrounding text. This conversion is
+controlled by a recursive procedure that decides all of the appropriate
+styles by a ``top-down'' process starting at the outermost level and working
+in towards the subformulas. The formula is ultimately pasted together using
+combinations of horizontal and vertical boxes, with glue and penalty nodes
+inserted as necessary.
+
+An mlist is represented internally as a linked list consisting chiefly
+of ``noads'' (pronounced ``no-adds''), to distinguish them from the somewhat
+similar ``nodes'' in hlists and vlists. Certain kinds of ordinary nodes are
+allowed to appear in mlists together with the noads; \TeX\ tells the difference
+by means of the |type| field, since a noad's |type| is always greater than
+that of a node. An mlist does not contain character nodes, hlist nodes, vlist
+nodes, math nodes or unset nodes; in particular, each mlist item appears in the
+variable-size part of |mem|, so the |type| field is always present.
+
+@ Each noad is five or more words long. The first word contains the
+|type| and |subtype| and |link| fields that are already so familiar to
+us; the second contains the attribute list pointer, and the third,
+fourth an fifth words are called the noad's |nucleus|, |subscr|, and
+|supscr| fields. (This use of a combined attribute list is temporary.
+Eventually, each of fields need their own list)
+
+Consider, for example, the simple formula `\.{\$x\^2\$}', which would be
+parsed into an mlist containing a single element called an |ord_noad|.
+The |nucleus| of this noad is a representation of `\.x', the |subscr| is
+empty, and the |supscr| is a representation of `\.2'.
+
+The |nucleus|, |subscr|, and |supscr| fields are further broken into
+subfields. If |p| points to a noad, and if |q| is one of its principal
+fields (e.g., |q=subscr(p)|), there are several possibilities for the
+subfields, depending on the |math_type| of |q|.
+
+\yskip\hang|math_type(q)=math_char| means that |fam(q)| refers to one of
+the sixteen font families, and |character(q)| is the number of a character
+within a font of that family, as in a character node.
+
+\yskip\hang|math_type(q)=math_text_char| is similar, but the character is
+unsubscripted and unsuperscripted and it is followed immediately by another
+character from the same font. (This |math_type| setting appears only
+briefly during the processing; it is used to suppress unwanted italic
+corrections.)
+
+\yskip\hang|math_type(q)=empty| indicates a field with no value (the
+corresponding attribute of noad |p| is not present).
+
+\yskip\hang|math_type(q)=sub_box| means that |vinfo(q)| points to a box
+node (either an |hlist_node| or a |vlist_node|) that should be used as the
+value of the field. The |shift_amount| in the subsidiary box node is the
+amount by which that box will be shifted downward.
+
+\yskip\hang|math_type(q)=sub_mlist| means that |vinfo(q)| points to
+an mlist; the mlist must be converted to an hlist in order to obtain
+the value of this field.
+
+\yskip\noindent In the latter case, we might have |vinfo(q)=null|. This
+is not the same as |math_type(q)=empty|; for example, `\.{\$P\_\{\}\$}'
+and `\.{\$P\$}' produce different results (the former will not have the
+``italic correction'' added to the width of |P|, but the ``script skip''
+will be added).
+
+The definitions of subfields given here are a little wasteful of space,
+since a quarterword is being used for the |math_type| although only three
+bits would be needed. However, there are hardly ever many noads present at
+once, since they are soon converted to nodes that take up even more space,
+so we can afford to represent them in whatever way simplifies the
+programming.
+
+I tried exchanging |mcharacter()| and |math_type()| so that a character
+could use the full Unicode range, but for some reason that does not work
+properly. TH
+
+@d noad_size=5 {number of words in a normal noad}
+@d nucleus(#)==#+2 {the |nucleus| field of a noad}
+@d supscr(#)==#+3 {the |supscr| field of a noad}
+@d subscr(#)==#+4 {the |subscr| field of a noad}
+@d math_type==vlink {a |quarterword| in |mem|}
+@d fam(#)==type(#) {a |quarterword| in |mem|}
+@d mcharacter(#)==subtype(#)
+@d math_char=1 {|math_type| when the attribute is simple}
+@d sub_box=2 {|math_type| when the attribute is a box}
+@d sub_mlist=3 {|math_type| when the attribute is a formula}
+@d math_text_char=4 {|math_type| when italic correction is dubious}
+
+@ Each portion of a formula is classified as Ord, Op, Bin, Rel, Ope,
+Clo, Pun, or Inn, for purposes of spacing and line breaking. An
+|ord_noad|, |op_noad|, |bin_noad|, |rel_noad|, |open_noad|, |close_noad|,
+|punct_noad|, or |inner_noad| is used to represent portions of the various
+types. For example, an `\.=' sign in a formula leads to the creation of a
+|rel_noad| whose |nucleus| field is a representation of an equals sign
+(usually |fam=0|, |character=@'75|). A formula preceded by \.{\\mathrel}
+also results in a |rel_noad|. When a |rel_noad| is followed by an
+|op_noad|, say, and possibly separated by one or more ordinary nodes (not
+noads), \TeX\ will insert a penalty node (with the current |rel_penalty|)
+just after the formula that corresponds to the |rel_noad|, unless there
+already was a penalty immediately following; and a ``thick space'' will be
+inserted just before the formula that corresponds to the |op_noad|.
+
+A noad of type |ord_noad|, |op_noad|, \dots, |inner_noad| usually
+has a |subtype=normal|. The only exception is that an |op_noad| might
+have |subtype=limits| or |no_limits|, if the normal positioning of
+limits has been overridden for this operator.
+
+@d ord_noad=unset_node+3 {|type| of a noad classified Ord}
+@d op_noad=ord_noad+1 {|type| of a noad classified Op}
+@d bin_noad=ord_noad+2 {|type| of a noad classified Bin}
+@d rel_noad=ord_noad+3 {|type| of a noad classified Rel}
+@d open_noad=ord_noad+4 {|type| of a noad classified Ope}
+@d close_noad=ord_noad+5 {|type| of a noad classified Clo}
+@d punct_noad=ord_noad+6 {|type| of a noad classified Pun}
+@d inner_noad=ord_noad+7 {|type| of a noad classified Inn}
+@d limits=1 {|subtype| of |op_noad| whose scripts are to be above, below}
+@d no_limits=2 {|subtype| of |op_noad| whose scripts are to be normal}
+
+@ A |radical_noad| is five words long; the fifth word is the |left_delimiter|
+field, which usually represents a square root sign.
+
+A |fraction_noad| is six words long; it has a |right_delimiter| field
+as well as a |left_delimiter|.
+
+Delimiter fields are of type |four_quarters|, and they have four subfields
+called |small_fam|, |small_char|, |large_fam|, |large_char|. These subfields
+represent variable-size delimiters by giving the ``small'' and ``large''
+starting characters, as explained in Chapter~17 of {\sl The \TeX book}.
+@:TeXbook}{\sl The \TeX book@>
+
+A |fraction_noad| is actually quite different from all other noads. Not
+only does it have six words, it has |thickness|, |denominator|, and
+|numerator| fields instead of |nucleus|, |subscr|, and |supscr|. The
+|thickness| is a scaled value that tells how thick to make a fraction
+rule; however, the special value |default_code| is used to stand for the
+|default_rule_thickness| of the current size. The |numerator| and
+|denominator| point to mlists that define a fraction; we always have
+$$\hbox{|math_type(numerator)=math_type(denominator)=sub_mlist|}.$$ The
+|left_delimiter| and |right_delimiter| fields specify delimiters that will
+be placed at the left and right of the fraction. In this way, a
+|fraction_noad| is able to represent all of \TeX's operators \.{\\over},
+\.{\\atop}, \.{\\above}, \.{\\overwithdelims}, \.{\\atopwithdelims}, and
+ \.{\\abovewithdelims}.
+
+@d left_delimiter(#)==#+5 {first delimiter field of a noad}
+@d right_delimiter(#)==#+6 {second delimiter field of a fraction noad}
+@d radical_noad=inner_noad+1 {|type| of a noad for square roots}
+@d radical_noad_size=6 {number of |mem| words in a radical noad}
+@d fraction_noad=radical_noad+1 {|type| of a noad for generalized fractions}
+@d fraction_noad_size=7 {number of |mem| words in a fraction noad}
+@d small_fam(#)==vmem(#).qqqq.b0 {|fam| for ``small'' delimiter}
+@d small_char(#)==vmem(#).qqqq.b1 {|character| for ``small'' delimiter}
+@d large_fam(#)==vmem(#).qqqq.b2 {|fam| for ``large'' delimiter}
+@d large_char(#)==vmem(#).qqqq.b3 {|character| for ``large'' delimiter}
+@d thickness(#)==vmem(#+2).sc {|thickness| field in a fraction noad}
+@d default_code==@'10000000000 {denotes |default_rule_thickness|}
+@d numerator==supscr {|numerator| field in a fraction noad}
+@d denominator==subscr {|denominator| field in a fraction noad}
+
+@ The global variable |empty_field| is set up for initialization of empty
+fields in new noads. Similarly, |null_delimiter| is for the initialization
+of delimiter fields.
+
+@<Glob...@>=
+@!empty_field:two_halves;
+@!null_delimiter:four_quarters;
+
+@ @<Set init...@>=
+empty_field.rh:=empty; empty_field.lh:=null;@/
+null_delimiter.b0:=0; null_delimiter.b1:=min_quarterword;@/
+null_delimiter.b2:=0; null_delimiter.b3:=min_quarterword;
+
+@ The |new_noad| function creates an |ord_noad| that is completely null.
+
+@p function new_noad:pointer;
+var p:pointer;
+begin p:=new_node(ord_noad,normal);
+vmem(nucleus(p)).hh:=empty_field;
+vmem(subscr(p)).hh:=empty_field;
+vmem(supscr(p)).hh:=empty_field;
+new_noad:=p;
+end;
+
+@ A few more kinds of noads will complete the set: An |under_noad| has its
+nucleus underlined; an |over_noad| has it overlined. An |accent_noad| places
+an accent over its nucleus; the accent character appears as
+|fam(accent_chr(p))| and |mcharacter(accent_chr(p))|. A |vcenter_noad|
+centers its nucleus vertically with respect to the axis of the formula;
+in such noads we always have |math_type(nucleus(p))=sub_box|.
+
+And finally, we have |left_noad| and |right_noad| types, to implement
+\TeX's \.{\\left} and \.{\\right} as well as \eTeX's \.{\\middle}.
+The |nucleus| of such noads is
+replaced by a |delimiter| field; thus, for example, `\.{\\left(}' produces
+a |left_noad| such that |delimiter(p)| holds the family and character
+codes for all left parentheses. A |left_noad| never appears in an mlist
+except as the first element, and a |right_noad| never appears in an mlist
+except as the last element; furthermore, we either have both a |left_noad|
+and a |right_noad|, or neither one is present. The |subscr| and |supscr|
+fields are always |empty| in a |left_noad| and a |right_noad|.
+
+@d under_noad=fraction_noad+1 {|type| of a noad for underlining}
+@d over_noad=under_noad+1 {|type| of a noad for overlining}
+@d accent_noad=over_noad+1 {|type| of a noad for accented subformulas}
+@d accent_noad_size=6 {number of |mem| words in an accent noad}
+@d accent_chr(#)==#+5 {the |accent_chr| field of an accent noad}
+@d vcenter_noad=accent_noad+1 {|type| of a noad for \.{\\vcenter}}
+@d left_noad=vcenter_noad+1 {|type| of a noad for \.{\\left}}
+@d right_noad=left_noad+1 {|type| of a noad for \.{\\right}}
+@d delimiter==nucleus {|delimiter| field in left and right noads}
+@d middle_noad==1 {|subtype| of right noad representing \.{\\middle}}
+@d scripts_allowed(#)==(type(#)>=ord_noad)and(type(#)<left_noad)
+
+@ Math formulas can also contain instructions like \.{\\textstyle} that
+override \TeX's normal style rules. A |style_node| is inserted into the
+data structure to record such instructions; it is three words long, so it
+is considered a node instead of a noad. The |subtype| is either |display_style|
+or |text_style| or |script_style| or |script_script_style|. The
+second and third words of a |style_node| are not used, but they are
+present because a |choice_node| is converted to a |style_node|.
+
+\TeX\ uses even numbers 0, 2, 4, 6 to encode the basic styles
+|display_style|, \dots, |script_script_style|, and adds~1 to get the
+``cramped'' versions of these styles. This gives a numerical order that
+is backwards from the convention of Appendix~G in {\sl The \TeX book\/};
+i.e., a smaller style has a larger numerical value.
+@:TeXbook}{\sl The \TeX book@>
+
+@d style_node=unset_node+1 {|type| of a style node}
+@d style_node_size=4 {number of words in a style node}
+@d display_style=0 {|subtype| for \.{\\displaystyle}}
+@d text_style=2 {|subtype| for \.{\\textstyle}}
+@d script_style=4 {|subtype| for \.{\\scriptstyle}}
+@d script_script_style=6 {|subtype| for \.{\\scriptscriptstyle}}
+@d cramped=1 {add this to an uncramped style if you want to cramp it}
+
+@p function new_style(@!s:small_number):pointer; {create a style node}
+var p:pointer; {the new node}
+begin p:=new_node(style_node,s);
+new_style:=p;
+end;
+
+@ Finally, the \.{\\mathchoice} primitive creates a |choice_node|, which
+has special subfields |display_mlist|, |text_mlist|, |script_mlist|,
+and |script_script_mlist| pointing to the mlists for each style.
+
+@d choice_node=unset_node+2 {|type| of a choice node}
+@d display_mlist(#)==vinfo(#+2) {mlist to be used in display style}
+@d text_mlist(#)==vlink(#+2) {mlist to be used in text style}
+@d script_mlist(#)==vinfo(#+3) {mlist to be used in script style}
+@d script_script_mlist(#)==vlink(#+3) {mlist to be used in scriptscript style}
+
+@p function new_choice:pointer; {create a choice node}
+var p:pointer; {the new node}
+begin p:=new_node(choice_node,0); {the |subtype| is not used}
+new_choice:=p;
+end;
+
+@ Let's consider now the previously unwritten part of |show_node_list|
+that displays the things that can only be present in mlists; this
+program illustrates how to access the data structures just defined.
+
+In the context of the following program, |p| points to a node or noad that
+should be displayed, and the current string contains the ``recursion history''
+that leads to this point. The recursion history consists of a dot for each
+outer level in which |p| is subsidiary to some node, or in which |p| is
+subsidiary to the |nucleus| field of some noad; the dot is replaced by
+`\.\_' or `\.\^' or `\./' or `\.\\' if |p| is descended from the |subscr|
+or |supscr| or |denominator| or |numerator| fields of noads. For example,
+the current string would be `\.{.\^.\_/}' if |p| points to the |ord_noad| for
+|x| in the (ridiculous) formula
+`\.{\$\\sqrt\{a\^\{\\mathinner\{b\_\{c\\over x+y\}\}\}\}\$}'.
+
+@<Cases of |show_node_list| that arise...@>=
+style_node:print_style(subtype(p));
+choice_node:@<Display choice node |p|@>;
+ord_noad,op_noad,bin_noad,rel_noad,open_noad,close_noad,punct_noad,inner_noad,
+ radical_noad,over_noad,under_noad,vcenter_noad,accent_noad,
+ left_noad,right_noad:@<Display normal noad |p|@>;
+fraction_noad:@<Display fraction noad |p|@>;
+
+@ Here are some simple routines used in the display of noads.
+
+@<Declare procedures needed for displaying the elements of mlists@>=
+procedure print_fam_and_char(@!p:pointer); {prints family and character}
+begin print_esc("fam"); print_int(fam(p)); print_char(" ");
+print(qo(mcharacter(p)));
+end;
+@#
+procedure print_delimiter(@!p:pointer); {prints a delimiter as 24-bit hex value}
+{TH: FIX to do: print 48-bit integer where needed!}
+var a:integer; {accumulator}
+begin a:=small_fam(p)*256+qo(small_char(p));
+a:=a*@"1000+large_fam(p)*256+qo(large_char(p));
+if a<0 then print_int(a) {this should never happen}
+else print_hex(a);
+end;
+
+@ The next subroutine will descend to another level of recursion when a
+subsidiary mlist needs to be displayed. The parameter |c| indicates what
+character is to become part of the recursion history. An empty mlist is
+distinguished from a field with |math_type(p)=empty|, because these are
+not equivalent (as explained above).
+@^recursion@>
+
+@<Declare procedures needed for displaying...@>=
+procedure@?show_info; forward;@t\2@>@?{|show_node_list(vinfo(temp_ptr))|}
+procedure print_subsidiary_data(@!p:pointer;@!c:ASCII_code);
+ {display a noad field}
+begin if cur_length>=depth_threshold then
+ begin if math_type(p)<>empty then print(" []");
+ end
+else begin append_char(c); {include |c| in the recursion history}
+ temp_ptr:=p; {prepare for |show_info| if recursion is needed}
+ case math_type(p) of
+ math_char: begin print_ln; print_current_string; print_fam_and_char(p);
+ end;
+ sub_box: show_info; {recursive call}
+ sub_mlist: if vinfo(p)=null then
+ begin print_ln; print_current_string; print("{}");
+ end
+ else show_info; {recursive call}
+ othercases do_nothing {|empty|}
+ endcases;@/
+ flush_char; {remove |c| from the recursion history}
+ end;
+end;
+
+@ The inelegant introduction of |show_info| in the code above seems better
+than the alternative of using \PASCAL's strange |forward| declaration for a
+procedure with parameters. The \PASCAL\ convention about dropping parameters
+from a post-|forward| procedure is, frankly, so intolerable to the author
+of \TeX\ that he would rather stoop to communication via a global temporary
+variable. (A similar stoopidity occurred with respect to |hlist_out| and
+|vlist_out| above, and it will occur with respect to |mlist_to_hlist| below.)
+@^Knuth, Donald Ervin@>
+@:PASCAL}{\PASCAL@>
+
+@p procedure show_info; {the reader will kindly forgive this}
+begin show_node_list(vinfo(temp_ptr));
+end;
+
+@ @<Declare procedures needed for displaying...@>=
+procedure print_style(@!c:integer);
+begin case c div 2 of
+0: print_esc("displaystyle"); {|display_style=0|}
+1: print_esc("textstyle"); {|text_style=2|}
+2: print_esc("scriptstyle"); {|script_style=4|}
+3: print_esc("scriptscriptstyle"); {|script_script_style=6|}
+othercases print("Unknown style!")
+endcases;
+end;
+
+@ @<Display choice node |p|@>=
+begin print_esc("mathchoice");
+append_char("D"); show_node_list(display_mlist(p)); flush_char;
+append_char("T"); show_node_list(text_mlist(p)); flush_char;
+append_char("S"); show_node_list(script_mlist(p)); flush_char;
+append_char("s"); show_node_list(script_script_mlist(p)); flush_char;
+end
+
+@ @<Display normal noad |p|@>=
+begin case type(p) of
+ord_noad: print_esc("mathord");
+op_noad: print_esc("mathop");
+bin_noad: print_esc("mathbin");
+rel_noad: print_esc("mathrel");
+open_noad: print_esc("mathopen");
+close_noad: print_esc("mathclose");
+punct_noad: print_esc("mathpunct");
+inner_noad: print_esc("mathinner");
+over_noad: print_esc("overline");
+under_noad: print_esc("underline");
+vcenter_noad: print_esc("vcenter");
+radical_noad: begin
+ {TH: TODO print oradical where needed and fix otherwise}
+ print_esc("radical"); print_delimiter(left_delimiter(p));
+ end;
+accent_noad: begin print_esc("accent"); print_fam_and_char(accent_chr(p));
+ end;
+left_noad: begin print_esc("left"); print_delimiter(nucleus(p));
+ end;
+right_noad: begin if subtype(p)=normal then print_esc("right")
+ else print_esc("middle");
+ print_delimiter(nucleus(p));
+ end;
+end;
+if type(p)<left_noad then
+ begin if subtype(p)<>normal then
+ if subtype(p)=limits then print_esc("limits")
+ else print_esc("nolimits");
+ print_subsidiary_data(nucleus(p),".");
+ end;
+print_subsidiary_data(supscr(p),"^");
+print_subsidiary_data(subscr(p),"_");
+end
+
+@ @<Display fraction noad |p|@>=
+begin print_esc("fraction, thickness ");
+if thickness(p)=default_code then print("= default")
+else print_scaled(thickness(p));
+if (small_fam(left_delimiter(p))<>0)or@+
+ (small_char(left_delimiter(p))<>min_quarterword)or@|
+ (large_fam(left_delimiter(p))<>0)or@|
+ (large_char(left_delimiter(p))<>min_quarterword) then
+ begin print(", left-delimiter "); print_delimiter(left_delimiter(p));
+ end;
+if (small_fam(right_delimiter(p))<>0)or@|
+ (small_char(right_delimiter(p))<>min_quarterword)or@|
+ (large_fam(right_delimiter(p))<>0)or@|
+ (large_char(right_delimiter(p))<>min_quarterword) then
+ begin print(", right-delimiter "); print_delimiter(right_delimiter(p));
+ end;
+print_subsidiary_data(numerator(p),"\");
+print_subsidiary_data(denominator(p),"/");
+end
+
+@* \[35] Subroutines for math mode.
+In order to convert mlists to hlists, i.e., noads to nodes, we need several
+subroutines that are conveniently dealt with now.
+
+Let us first introduce the macros that make it easy to get at the parameters and
+other font information. A size code, which is a multiple of 16, is added to a
+family number to get an index into the table of internal font numbers
+for each combination of family and size. (Be alert: Size codes get
+larger as the type gets smaller.)
+
+@<Basic printing procedures@>=
+procedure print_size(@!s:integer);
+begin if s=0 then print_esc("textfont")
+else if s=script_size then print_esc("scriptfont")
+else print_esc("scriptscriptfont");
+end;
+
+@ Before an mlist is converted to an hlist, \TeX\ makes sure that
+the fonts in family~2 have enough parameters to be math-symbol
+fonts, and that the fonts in family~3 have enough parameters to be
+math-extension fonts. The math-symbol parameters are referred to by using the
+following macros, which take a size code as their parameter; for example,
+|num1(cur_size)| gives the value of the |num1| parameter for the current size.
+@^parameters for symbols@>
+@^font parameters@>
+
+@d mathsy_end(#)==
+@d mathsy(#)==font_param(fam_fnt(2+cur_size),#) mathsy_end
+@d math_x_height==mathsy(5) {height of `\.x'}
+@d math_quad==mathsy(6) {\.{18mu}}
+@d num1==mathsy(8) {numerator shift-up in display styles}
+@d num2==mathsy(9) {numerator shift-up in non-display, non-\.{\\atop}}
+@d num3==mathsy(10) {numerator shift-up in non-display \.{\\atop}}
+@d denom1==mathsy(11) {denominator shift-down in display styles}
+@d denom2==mathsy(12) {denominator shift-down in non-display styles}
+@d sup1==mathsy(13) {superscript shift-up in uncramped display style}
+@d sup2==mathsy(14) {superscript shift-up in uncramped non-display}
+@d sup3==mathsy(15) {superscript shift-up in cramped styles}
+@d sub1==mathsy(16) {subscript shift-down if superscript is absent}
+@d sub2==mathsy(17) {subscript shift-down if superscript is present}
+@d sup_drop==mathsy(18) {superscript baseline below top of large box}
+@d sub_drop==mathsy(19) {subscript baseline below bottom of large box}
+@d delim1==mathsy(20) {size of \.{\\atopwithdelims} delimiters
+ in display styles}
+@d delim2==mathsy(21) {size of \.{\\atopwithdelims} delimiters in non-displays}
+@d axis_height==mathsy(22) {height of fraction lines above the baseline}
+@d total_mathsy_params=22
+
+@ The math-extension parameters have similar macros, but the size code is
+omitted (since it is always |cur_size| when we refer to such parameters).
+@^parameters for symbols@>
+@^font parameters@>
+
+@d mathex(#)==font_param(fam_fnt(3+cur_size),#)
+@d default_rule_thickness==mathex(8) {thickness of \.{\\over} bars}
+@d big_op_spacing1==mathex(9) {minimum clearance above a displayed op}
+@d big_op_spacing2==mathex(10) {minimum clearance below a displayed op}
+@d big_op_spacing3==mathex(11) {minimum baselineskip above displayed op}
+@d big_op_spacing4==mathex(12) {minimum baselineskip below displayed op}
+@d big_op_spacing5==mathex(13) {padding above and below displayed limits}
+@d total_mathex_params=13
+
+@ We also need to compute the change in style between mlists and their
+subsidiaries. The following macros define the subsidiary style for
+an overlined nucleus (|cramped_style|), for a subscript or a superscript
+(|sub_style| or |sup_style|), or for a numerator or denominator (|num_style|
+or |denom_style|).
+
+@d cramped_style(#)==2*(# div 2)+cramped {cramp the style}
+@d sub_style(#)==2*(# div 4)+script_style+cramped {smaller and cramped}
+@d sup_style(#)==2*(# div 4)+script_style+(# mod 2) {smaller}
+@d num_style(#)==#+2-2*(# div 6) {smaller unless already script-script}
+@d denom_style(#)==2*(# div 2)+cramped+2-2*(# div 6) {smaller, cramped}
+
+@ When the style changes, the following piece of program computes associated
+information:
+
+@<Set up the values of |cur_size| and |cur_mu|, based on |cur_style|@>=
+begin if cur_style<script_style then cur_size:=text_size
+else cur_size:=script_size*((cur_style-text_style) div 2);
+cur_mu:=x_over_n(math_quad(cur_size),18);
+end
+
+@ Here is a function that returns a pointer to a rule node having a given
+thickness |t|. The rule will extend horizontally to the boundary of the vlist
+that eventually contains it.
+
+@p function fraction_rule(@!t:scaled):pointer;
+ {construct the bar for a fraction}
+var p:pointer; {the new node}
+begin p:=new_rule; rule_dir(p):=math_direction;
+height(p):=t; depth(p):=0; fraction_rule:=p;
+end;
+
+@ The |overbar| function returns a pointer to a vlist box that consists of
+a given box |b|, above which has been placed a kern of height |k| under a
+fraction rule of thickness |t| under additional space of height |t|.
+
+@p function overbar(@!b:pointer;@!k,@!t:scaled):pointer;
+var p,@!q:pointer; {nodes being constructed}
+begin p:=new_kern(k); vlink(p):=b; q:=fraction_rule(t); vlink(q):=p;
+p:=new_kern(t); vlink(p):=q;
+pack_direction:=math_direction; overbar:=vpack(p,natural);
+end;
+
+@ The |var_delimiter| function, which finds or constructs a sufficiently
+large delimiter, is the most interesting of the auxiliary functions that
+currently concern us. Given a pointer |d| to a delimiter field in some noad,
+together with a size code |s| and a vertical distance |v|, this function
+returns a pointer to a box that contains the smallest variant of |d| whose
+height plus depth is |v| or more. (And if no variant is large enough, it
+returns the largest available variant.) In particular, this routine will
+construct arbitrarily large delimiters from extensible components, if
+|d| leads to such characters.
+
+The value returned is a box whose |shift_amount| has been set so that
+the box is vertically centered with respect to the axis in the given size.
+If a built-up symbol is returned, the height of the box before shifting
+will be the height of its topmost component.
+
+@p@t\4@>@<Declare subprocedures for |var_delimiter|@>
+function var_delimiter(@!d:pointer;@!s:integer;@!v:scaled):pointer;
+label found,continue;
+var b:pointer; {the box that will be constructed}
+@!f,@!g: internal_font_number; {best-so-far and tentative font codes}
+@!c,@!x,@!y: integer; {best-so-far and tentative character codes}
+@!cc: integer; { a temporary character code for extensibles }
+@!m,@!n: integer; {the number of extensible pieces}
+@!u: scaled; {height-plus-depth of a tentative character}
+@!w: scaled; {largest height-plus-depth so far}
+@!z: integer; {runs through font family members}
+@!large_attempt: boolean; {are we trying the ``large'' variant?}
+begin f:=null_font; c:=0; w:=0; large_attempt:=false;
+z:=small_fam(d); x:=small_char(d);
+loop@+ begin @<Look at the variants of |(z,x)|; set |f| and |c| whenever
+ a better character is found; |goto found| as soon as a
+ large enough variant is encountered@>;
+ if large_attempt then goto found; {there were none large enough}
+ large_attempt:=true; z:=large_fam(d); x:=large_char(d);
+ end;
+found: if f<>null_font then
+ @<Make variable |b| point to a box for |(f,c)|@>
+else begin b:=new_null_box;
+ width(b):=null_delimiter_space; {use this width if no delimiter was found}
+ end;
+z:=cur_size; cur_size:=s;
+shift_amount(b):=half(height(b)-depth(b)) - axis_height(cur_size);
+cur_size:=z;
+var_delimiter:=b;
+end;
+
+@ The search process is complicated slightly by the facts that some of the
+characters might not be present in some of the fonts, and they might not
+be probed in increasing order of height.
+
+@<Look at the variants of |(z,x)|; set |f| and |c|...@>=
+if (z<>0)or(x<>min_quarterword) then
+ begin z:=z+s+script_size;
+ repeat z:=z-script_size; g:=fam_fnt(z);
+ if g<>null_font then
+ @<Look at the list of characters starting with |x| in
+ font |g|; set |f| and |c| whenever
+ a better character is found; |goto found| as soon as a
+ large enough variant is encountered@>;
+ until z<script_size;
+ end
+
+@ @<Look at the list of characters starting with |x|...@>=
+begin y:=x;
+if (y>=font_bc(g))and(y<=font_ec(g)) then
+ begin continue:
+ if char_exists(g,y) then
+ begin if char_tag(g,y)=ext_tag then
+ begin f:=g; c:=y; goto found;
+ end;
+ u:=char_height(g,y)+char_depth(g,y);
+ if u>w then
+ begin f:=g; c:=y; w:=u;
+ if u>=v then goto found;
+ end;
+ if char_tag(g,y)=list_tag then
+ begin y:=char_remainder(g,y); goto continue;
+ end;
+ end;
+ end;
+end
+
+@ Here is a subroutine that creates a new box, whose list contains a
+single character, and whose width includes the italic correction for
+that character. The height or depth of the box will be negative, if
+the height or depth of the character is negative; thus, this routine
+may deliver a slightly different result than |hpack| would produce.
+
+@<Declare subprocedures for |var_delimiter|@>=
+function char_box(@!f:internal_font_number;@!c:quarterword):pointer;
+var @!b,@!p:pointer; {the new box and its character node}
+begin
+b:=new_null_box; ci:=char_info_short(f,c);
+width(b):=charinfo_width(ci)+char_italic(f,c);
+height(b):=charinfo_height(ci); depth(b):=charinfo_depth(ci);
+p:=new_char(f,c); list_ptr(b):=p; char_box:=b;
+end;
+
+@ When the following code is executed, |char_tag(q)| will be equal to
+|ext_tag| if and only if a built-up symbol is supposed to be returned.
+
+@<Make variable |b| point to a box for |(f,c)|@>=
+if char_tag(f,c)=ext_tag then
+ @<Construct an extensible character in a new box |b|,
+ using recipe |rem_byte(q)| and font |f|@>
+else b:=char_box(f,c)
+
+@ When we build an extensible character, it's handy to have the
+following subroutine, which puts a given character on top
+of the characters already in box |b|:
+
+@<Declare subprocedures for |var_delimiter|@>=
+procedure stack_into_box(@!b:pointer;@!f:internal_font_number;
+ @!c:quarterword);
+var p:pointer; {new node placed into |b|}
+begin p:=char_box(f,c); vlink(p):=list_ptr(b); list_ptr(b):=p;
+height(b):=height(p);
+end;
+
+@ Another handy subroutine computes the height plus depth of
+a given character:
+
+@<Declare subprocedures for |var_delimiter|@>=
+function height_plus_depth(@!f:internal_font_number;@!c:quarterword):scaled;
+begin
+height_plus_depth:=char_height(f,c)+char_depth(f,c);
+end;
+
+@ @<Construct an extensible...@>=
+begin b:=new_null_box;
+type(b):=vlist_node;
+@<Compute the minimum suitable height, |w|, and the corresponding
+ number of extension steps, |n|; also set |width(b)|@>;
+cc:=ext_bot(f,c);
+if cc<>min_quarterword then stack_into_box(b,f,cc);
+cc:=ext_rep(f,c);
+for m:=1 to n do stack_into_box(b,f,cc);
+cc:=ext_mid(f,c);
+if cc<>min_quarterword then
+ begin stack_into_box(b,f,cc); cc:=ext_rep(f,c);
+ for m:=1 to n do stack_into_box(b,f,cc);
+ end;
+cc:=ext_top(f,c);
+if cc<>min_quarterword then stack_into_box(b,f,cc);
+depth(b):=w-height(b);
+end
+
+@ The width of an extensible character is the width of the repeatable
+module. If this module does not have positive height plus depth,
+we don't use any copies of it, otherwise we use as few as possible
+(in groups of two if there is a middle part).
+
+@<Compute the minimum suitable height, |w|, and...@>=
+cc:=ext_rep(f,c); u:=height_plus_depth(f,cc);
+w:=0; width(b):=char_width(f,cc)+char_italic(f,cc);@/
+cc:=ext_bot(f,c);@+if cc<>min_quarterword then w:=w+height_plus_depth(f,cc);
+cc:=ext_mid(f,c);@+if cc<>min_quarterword then w:=w+height_plus_depth(f,cc);
+cc:=ext_top(f,c);@+if cc<>min_quarterword then w:=w+height_plus_depth(f,cc);
+n:=0;
+if u>0 then while w<v do
+ begin w:=w+u; incr(n);
+ if (ext_mid(f,c))<>min_quarterword then w:=w+u;
+ end
+
+@ The next subroutine is much simpler; it is used for numerators and
+denominators of fractions as well as for displayed operators and
+their limits above and below. It takes a given box~|b| and
+changes it so that the new box is centered in a box of width~|w|.
+The centering is done by putting \.{\\hss} glue at the left and right
+of the list inside |b|, then packaging the new box; thus, the
+actual box might not really be centered, if it already contains
+infinite glue.
+
+The given box might contain a single character whose italic correction
+has been added to the width of the box; in this case a compensating
+kern is inserted.
+
+@p function rebox(@!b:pointer;@!w:scaled):pointer;
+var p,q:pointer; {temporary registers for list manipulation}
+@!f:internal_font_number; {font in a one-character box}
+@!v:scaled; {width of a character without italic correction}
+begin if (width(b)<>w)and(list_ptr(b)<>null) then
+ begin if type(b)=vlist_node then b:=hpack(b,natural);
+ p:=list_ptr(b);
+ if (is_char_node(p))and(vlink(p)=null) then
+ begin f:=font(p); v:=char_width(f,character(p));
+ if v<>width(b) then begin
+ q:=new_kern(width(b)-v); vlink(p):=q;
+ end;
+ end;
+ list_ptr(b):=null; flush_node(b);
+ b:=new_glue(ss_glue); vlink(b):=p;
+ while vlink(p)<>null do p:=vlink(p);
+ q:=new_glue(ss_glue); vlink(p):=q;
+ rebox:=hpack(b,w,exactly);
+ end
+else begin width(b):=w; rebox:=b;
+ end;
+end;
+
+@ Here is a subroutine that creates a new glue specification from another
+one that is expressed in `\.{mu}', given the value of the math unit.
+
+@d mu_mult(#)==nx_plus_y(n,#,xn_over_d(#,f,@'200000))
+
+@p function math_glue(@!g:pointer;@!m:scaled):pointer;
+var p:pointer; {the new glue specification}
+@!n:integer; {integer part of |m|}
+@!f:scaled; {fraction part of |m|}
+begin n:=x_over_n(m,@'200000); f:=remainder;@/
+if f<0 then
+ begin decr(n); f:=f+@'200000;
+ end;
+p:=new_node(glue_spec_node,0);
+width(p):=mu_mult(width(g)); {convert \.{mu} to \.{pt}}
+stretch_order(p):=stretch_order(g);
+if stretch_order(p)=normal then stretch(p):=mu_mult(stretch(g))
+else stretch(p):=stretch(g);
+shrink_order(p):=shrink_order(g);
+if shrink_order(p)=normal then shrink(p):=mu_mult(shrink(g))
+else shrink(p):=shrink(g);
+math_glue:=p;
+end;
+
+@ The |math_kern| subroutine removes |mu_glue| from a kern node, given
+the value of the math unit.
+
+@p procedure math_kern(@!p:pointer;@!m:scaled);
+var @!n:integer; {integer part of |m|}
+@!f:scaled; {fraction part of |m|}
+begin if subtype(p)=mu_glue then
+ begin n:=x_over_n(m,@'200000); f:=remainder;@/
+ if f<0 then
+ begin decr(n); f:=f+@'200000;
+ end;
+ width(p):=mu_mult(width(p)); subtype(p):=explicit;
+ end;
+end;
+
+@ Sometimes it is necessary to destroy an mlist. The following
+subroutine empties the current list, assuming that |abs(mode)=mmode|.
+
+@p procedure flush_math;
+begin flush_node_list(vlink(head)); flush_node_list(incompleat_noad);
+vlink(head):=null; tail:=head; incompleat_noad:=null;
+end;
+
+@* \[36] Typesetting math formulas.
+\TeX's most important routine for dealing with formulas is called
+|mlist_to_hlist|. After a formula has been scanned and represented as an
+mlist, this routine converts it to an hlist that can be placed into a box
+or incorporated into the text of a paragraph. There are three implicit
+parameters, passed in global variables: |cur_mlist| points to the first
+node or noad in the given mlist (and it might be |null|); |cur_style| is a
+style code; and |mlist_penalties| is |true| if penalty nodes for potential
+line breaks are to be inserted into the resulting hlist. After
+|mlist_to_hlist| has acted, |vlink(temp_head)| points to the translated hlist.
+
+Since mlists can be inside mlists, the procedure is recursive. And since this
+is not part of \TeX's inner loop, the program has been written in a manner
+that stresses compactness over efficiency.
+@^recursion@>
+
+@<Glob...@>=
+@!cur_mlist:pointer; {beginning of mlist to be translated}
+@!cur_style:integer; {style code at current place in the list}
+@!cur_size:integer; {size code corresponding to |cur_style|}
+@!cur_mu:scaled; {the math unit width corresponding to |cur_size|}
+@!mlist_penalties:boolean; {should |mlist_to_hlist| insert penalties?}
+
+@ The recursion in |mlist_to_hlist| is due primarily to a subroutine
+called |clean_box| that puts a given noad field into a box using a given
+math style; |mlist_to_hlist| can call |clean_box|, which can call
+|mlist_to_hlist|.
+@^recursion@>
+
+The box returned by |clean_box| is ``clean'' in the
+sense that its |shift_amount| is zero.
+
+@p procedure@?mlist_to_hlist; forward;@t\2@>@/
+function clean_box(@!p:pointer;@!s:integer):pointer;
+label found;
+var q:pointer; {beginning of a list to be boxed}
+@!save_style:integer; {|cur_style| to be restored}
+@!x:pointer; {box to be returned}
+@!r:pointer; {temporary pointer}
+begin
+case math_type(p) of
+math_char: begin cur_mlist:=new_noad; vmem(nucleus(cur_mlist)):=vmem(p);
+ end;
+sub_box: begin q:=vinfo(p); goto found;
+ end;
+sub_mlist: cur_mlist:=vinfo(p);
+othercases begin q:=new_null_box; goto found;
+ end
+endcases;@/
+save_style:=cur_style; cur_style:=s; mlist_penalties:=false;@/
+mlist_to_hlist; q:=vlink(temp_head); {recursive call}
+cur_style:=save_style; {restore the style}
+@<Set up the values of |cur_size| and |cur_mu|, based on |cur_style|@>;
+found: if is_char_node(q)or(q=null) then x:=hpack(q,natural)
+ else if (vlink(q)=null)and(type(q)<=vlist_node)and(shift_amount(q)=0) then
+ x:=q {it's already clean}
+ else x:=hpack(q,natural);
+@<Simplify a trivial box@>;
+clean_box:=x;
+end;
+
+@ Here we save memory space in a common case.
+
+@<Simplify a trivial box@>=
+q:=list_ptr(x);
+if is_char_node(q) then
+ begin r:=vlink(q);
+ if r<>null then if vlink(r)=null then if not is_char_node(r) then
+ if type(r)=kern_node then {unneeded italic correction}
+ begin flush_node(r); vlink(q):=null;
+ end;
+ end
+
+@ It is convenient to have a procedure that converts a |math_char|
+field to an ``unpacked'' form. The |fetch| routine sets |cur_f| and |cur_c|
+to the font code and character code of a given noad field.
+It also takes care of issuing error messages for
+nonexistent characters; in such cases, |char_exists(cur_f,cur_c)| will be |false|
+after |fetch| has acted, and the field will also have been reset to |empty|.
+
+@p procedure fetch(@!a:pointer); {unpack the |math_char| field |a|}
+begin cur_c:=mcharacter(a); cur_f:=fam_fnt(fam(a)+cur_size);
+if cur_f=null_font then
+ @<Complain about an undefined family@>
+else begin
+ if not(char_exists(cur_f,cur_c)) then
+ begin char_warning(cur_f,qo(cur_c));
+ math_type(a):=empty;
+ end;
+ end;
+end;
+
+@ @<Complain about an undefined family@>=
+begin print_err(""); print_size(cur_size); print_char(" ");
+print_int(fam(a)); print(" is undefined (character ");
+print(qo(cur_c)); print_char(")");
+help4("Somewhere in the math formula just ended, you used the")@/
+("stated character from an undefined font family. For example,")@/
+("plain TeX doesn't allow \it or \sl in subscripts. Proceed,")@/
+("and I'll try to forget that I needed that character.");
+error; math_type(a):=empty;
+end
+
+@ The outputs of |fetch| are placed in global variables.
+
+@<Glob...@>=
+@!cur_f:internal_font_number; {the |font| field of a |math_char|}
+@!cur_c:quarterword; {the |character| field of a |math_char|}
+
+@ We need to do a lot of different things, so |mlist_to_hlist| makes two
+passes over the given mlist.
+
+The first pass does most of the processing: It removes ``mu'' spacing from
+glue, it recursively evaluates all subsidiary mlists so that only the
+top-level mlist remains to be handled, it puts fractions and square roots
+and such things into boxes, it attaches subscripts and superscripts, and
+it computes the overall height and depth of the top-level mlist so that
+the size of delimiters for a |left_noad| and a |right_noad| will be known.
+The hlist resulting from each noad is recorded in that noad's |new_hlist|
+field, an integer field that replaces the |nucleus| or |thickness|.
+@^recursion@>
+
+The second pass eliminates all noads and inserts the correct glue and
+penalties between nodes.
+
+@d new_hlist(#)==vmem(nucleus(#)).int {the translation of an mlist}
+
+@ Here is the overall plan of |mlist_to_hlist|, and the list of its
+local variables.
+
+@d done_with_noad=80 {go here when a noad has been fully translated}
+@d done_with_node=81 {go here when a node has been fully converted}
+@d check_dimensions=82 {go here to update |max_h| and |max_d|}
+@d delete_q=83 {go here to delete |q| and move to the next node}
+
+@p@t\4@>@<Declare math construction procedures@>
+procedure mlist_to_hlist;
+label reswitch, check_dimensions, done_with_noad, done_with_node, delete_q,
+ done;
+var mlist:pointer; {beginning of the given list}
+@!penalties:boolean; {should penalty nodes be inserted?}
+@!style:integer; {the given style}
+@!save_style:integer; {holds |cur_style| during recursion}
+@!q:pointer; {runs through the mlist}
+@!r:pointer; {the most recent noad preceding |q|}
+@!r_type:integer; {the |type| of noad |r|, or |op_noad| if |r=null|}
+@!t:integer; {the effective |type| of noad |q| during the second pass}
+@!p,@!x,@!y,@!z: pointer; {temporary registers for list construction}
+@!pen:integer; {a penalty to be inserted}
+@!s:integer; {the size of a noad to be deleted}
+@!max_hl,@!max_d:scaled; {maximum height and depth of the list translated so far}
+@!delta:scaled; {offset between subscript and superscript}
+begin mlist:=cur_mlist; penalties:=mlist_penalties;
+style:=cur_style; {tuck global parameters away as local variables}
+q:=mlist; r:=null; r_type:=op_noad; max_hl:=0; max_d:=0; x:=null; p:=null;
+@<Set up the values of |cur_size| and |cur_mu|, based on |cur_style|@>;
+while q<>null do @<Process node-or-noad |q| as much as possible in preparation
+ for the second pass of |mlist_to_hlist|, then move to the next
+ item in the mlist@>;
+@<Convert \(a)a final |bin_noad| to an |ord_noad|@>;
+@<Make a second pass over the mlist, removing all noads and inserting the
+ proper spacing and penalties@>;
+end;
+
+@ We use the fact that no character nodes appear in an mlist, hence
+the field |type(q)| is always present.
+
+@<Process node-or-noad...@>=
+begin @<Do first-pass processing based on |type(q)|; |goto done_with_noad|
+ if a noad has been fully processed, |goto check_dimensions| if it
+ has been translated into |new_hlist(q)|, or |goto done_with_node|
+ if a node has been fully processed@>;
+check_dimensions: z:=hpack(new_hlist(q),natural);
+if height(z)>max_hl then max_hl:=height(z);
+if depth(z)>max_d then max_d:=depth(z);
+list_ptr(z):=null; flush_node(z);
+done_with_noad: r:=q; r_type:=type(r);
+if r_type=right_noad then
+ begin r_type:=left_noad; cur_style:=style; @<Set up the values...@>;
+ end;
+done_with_node: q:=vlink(q);
+end
+
+@ One of the things we must do on the first pass is change a |bin_noad| to
+an |ord_noad| if the |bin_noad| is not in the context of a binary operator.
+The values of |r| and |r_type| make this fairly easy.
+
+@<Do first-pass processing...@>=
+reswitch: delta:=0;
+case type(q) of
+bin_noad: case r_type of
+ bin_noad,op_noad,rel_noad,open_noad,punct_noad,left_noad:
+ begin type(q):=ord_noad; goto reswitch;
+ end;
+ othercases do_nothing
+ endcases;
+rel_noad,close_noad,punct_noad,right_noad: begin@t@>@;@/
+ @<Convert \(a)a final |bin_noad| to an |ord_noad|@>;
+ if type(q)=right_noad then goto done_with_noad;
+ end;
+@t\4@>@<Cases for noads that can follow a |bin_noad|@>@;
+@t\4@>@<Cases for nodes that can appear in an mlist, after which we
+ |goto done_with_node|@>@;
+othercases confusion("mlist1")
+@:this can't happen mlist1}{\quad mlist1@>
+endcases;@/
+@<Convert \(n)|nucleus(q)| to an hlist and attach the sub/superscripts@>
+
+@ @<Convert \(a)a final |bin_noad| to an |ord_noad|@>=
+if r_type=bin_noad then type(r):=ord_noad
+
+@ @<Cases for nodes that can appear in an mlist...@>=
+style_node: begin cur_style:=subtype(q);
+ @<Set up the values of |cur_size| and |cur_mu|, based on |cur_style|@>;
+ goto done_with_node;
+ end;
+choice_node: @<Change this node to a style node followed by the correct choice,
+ then |goto done_with_node|@>;
+ins_node,mark_node,adjust_node,
+ whatsit_node,penalty_node,disc_node: goto done_with_node;
+rule_node: begin if height(q)>max_hl then max_hl:=height(q);
+ if depth(q)>max_d then max_d:=depth(q); goto done_with_node;
+ end;
+glue_node: begin @<Convert \(m)math glue to ordinary glue@>;
+ goto done_with_node;
+ end;
+kern_node: begin math_kern(q,cur_mu); goto done_with_node;
+ end;
+
+@ @d choose_mlist(#)==begin p:=#(q); #(q):=null;@+end
+
+@<Change this node to a style node...@>=
+begin case cur_style div 2 of
+0: choose_mlist(display_mlist); {|display_style=0|}
+1: choose_mlist(text_mlist); {|text_style=2|}
+2: choose_mlist(script_mlist); {|script_style=4|}
+3: choose_mlist(script_script_mlist); {|script_script_style=6|}
+end; {there are no other cases}
+flush_node_list(display_mlist(q));
+flush_node_list(text_mlist(q));
+flush_node_list(script_mlist(q));
+flush_node_list(script_script_mlist(q));@/
+type(q):=style_node; subtype(q):=cur_style; width(q):=0; depth(q):=0;
+if p<>null then
+ begin z:=vlink(q); vlink(q):=p;
+ while vlink(p)<>null do p:=vlink(p);
+ vlink(p):=z;
+ end;
+goto done_with_node;
+end
+
+@ Conditional math glue (`\.{\\nonscript}') results in a |glue_node|
+pointing to |zero_glue|, with |subtype(q)=cond_math_glue|; in such a case
+the node following will be eliminated if it is a glue or kern node and if the
+current size is different from |text_size|. Unconditional math glue
+(`\.{\\muskip}') is converted to normal glue by multiplying the dimensions
+by |cur_mu|.
+@!@:non_script_}{\.{\\nonscript} primitive@>
+
+@<Convert \(m)math glue to ordinary glue@>=
+if subtype(q)=mu_glue then
+ begin x:=glue_ptr(q);
+ y:=math_glue(x,cur_mu); delete_glue_ref(x); glue_ptr(q):=y;
+ subtype(q):=normal;
+ end
+else if (cur_size<>text_size)and(subtype(q)=cond_math_glue) then
+ begin p:=vlink(q);
+ if p<>null then if (type(p)=glue_node)or(type(p)=kern_node) then
+ begin vlink(q):=vlink(p); vlink(p):=null; flush_node_list(p);
+ end;
+ end
+
+@ @<Cases for noads that can follow a |bin_noad|@>=
+left_noad: goto done_with_noad;
+fraction_noad: begin make_fraction(q); goto check_dimensions;
+ end;
+op_noad: begin delta:=make_op(q);
+ if subtype(q)=limits then goto check_dimensions;
+ end;
+ord_noad: make_ord(q);
+open_noad,inner_noad: do_nothing;
+radical_noad: make_radical(q);
+over_noad: make_over(q);
+under_noad: make_under(q);
+accent_noad: make_math_accent(q);
+vcenter_noad: make_vcenter(q);
+
+@ Most of the actual construction work of |mlist_to_hlist| is done
+by procedures with names
+like |make_fraction|, |make_radical|, etc. To illustrate
+the general setup of such procedures, let's begin with a couple of
+simple ones.
+
+@<Declare math...@>=
+procedure make_over(@!q:pointer);
+var p:pointer;
+begin p:=overbar(clean_box(nucleus(q),cramped_style(cur_style)),@|
+ 3*default_rule_thickness,default_rule_thickness);
+vinfo(nucleus(q)):=p;
+math_type(nucleus(q)):=sub_box;
+end;
+
+@ @<Declare math...@>=
+procedure make_under(@!q:pointer);
+var p,@!x,@!y,@!r: pointer; {temporary registers for box construction}
+@!delta:scaled; {overall height plus depth}
+begin x:=clean_box(nucleus(q),cur_style);
+p:=new_kern(3*default_rule_thickness); vlink(x):=p;
+r:=fraction_rule(default_rule_thickness); vlink(p):=r;
+pack_direction:=math_direction; y:=vpack(x,natural);
+delta:=height(y)+depth(y)+default_rule_thickness;
+height(y):=height(x); depth(y):=delta-height(y);
+vinfo(nucleus(q)):=y; math_type(nucleus(q)):=sub_box;
+end;
+
+@ @<Declare math...@>=
+procedure make_vcenter(@!q:pointer);
+var v:pointer; {the box that should be centered vertically}
+@!delta:scaled; {its height plus depth}
+begin v:=vinfo(nucleus(q));
+if type(v)<>vlist_node then confusion("vcenter");
+@:this can't happen vcenter}{\quad vcenter@>
+delta:=height(v)+depth(v);
+height(v):=axis_height(cur_size)+half(delta);
+depth(v):=delta-height(v);
+end;
+
+@ According to the rules in the \.{DVI} file specifications, we ensure alignment
+@^square roots@>
+between a square root sign and the rule above its nucleus by assuming that the
+baseline of the square-root symbol is the same as the bottom of the rule. The
+height of the square-root symbol will be the thickness of the rule, and the
+depth of the square-root symbol should exceed or equal the height-plus-depth
+of the nucleus plus a certain minimum clearance~|clr|. The symbol will be
+placed so that the actual clearance is |clr| plus half the excess.
+
+@<Declare math...@>=
+procedure make_radical(@!q:pointer);
+var x,@!y,@!p:pointer; {temporary registers for box construction}
+@!delta,@!clr:scaled; {dimensions involved in the calculation}
+begin x:=clean_box(nucleus(q),cramped_style(cur_style));
+if cur_style<text_style then {display style}
+ clr:=default_rule_thickness+(abs(math_x_height(cur_size)) div 4)
+else begin clr:=default_rule_thickness; clr:=clr + (abs(clr) div 4);
+ end;
+y:=var_delimiter(left_delimiter(q),cur_size,height(x)+depth(x)+clr+
+ default_rule_thickness);
+delta:=depth(y)-(height(x)+depth(x)+clr);
+if delta>0 then clr:=clr+half(delta); {increase the actual clearance}
+shift_amount(y):=-(height(x)+clr);
+p:=overbar(x,clr,height(y)); vlink(y):=p;
+p:=hpack(y,natural); vinfo(nucleus(q)):=p;
+math_type(nucleus(q)):=sub_box;
+end;
+
+@ Slants are not considered when placing accents in math mode. The accenter is
+centered over the accentee, and the accent width is treated as zero with
+respect to the size of the final box.
+
+@<Declare math...@>=
+procedure make_math_accent(@!q:pointer);
+label done;
+var p,@!x,@!y:pointer; {temporary registers for box construction}
+@!c:quarterword; {accent character}
+@!f:internal_font_number; {its font}
+@!s:scaled; {amount to skew the accent to the right}
+@!h:scaled; {height of character being accented}
+@!delta:scaled; {space to remove between accent and accentee}
+@!w:scaled; {width of the accentee, not including sub/superscripts}
+begin fetch(accent_chr(q));
+if char_exists(cur_f,cur_c) then
+ begin c:=cur_c; f:=cur_f;@/
+ @<Compute the amount of skew@>;
+ x:=clean_box(nucleus(q),cramped_style(cur_style)); w:=width(x); h:=height(x);
+ @<Switch to a larger accent if available and appropriate@>;
+ if h<x_height(f) then delta:=h@+else delta:=x_height(f);
+ if (math_type(supscr(q))<>empty)or(math_type(subscr(q))<>empty) then
+ if math_type(nucleus(q))=math_char then
+ @<Swap the subscript and superscript into box |x|@>;
+ y:=char_box(f,c);
+ shift_amount(y):=s+half(w-width(y));
+ width(y):=0; p:=new_kern(-delta); vlink(p):=x; vlink(y):=p;
+ pack_direction:=math_direction;
+ y:=vpack(y,natural); width(y):=width(x);
+ if height(y)<h then @<Make the height of box |y| equal to |h|@>;
+ vinfo(nucleus(q)):=y;
+ math_type(nucleus(q)):=sub_box;
+ end;
+end;
+
+@ @<Make the height of box |y|...@>=
+begin p:=new_kern(h-height(y)); vlink(p):=list_ptr(y); list_ptr(y):=p;
+height(y):=h;
+end
+
+@ @<Switch to a larger accent if available and appropriate@>=
+loop@+ begin if char_tag(f,c)<>list_tag then goto done;
+ y:=char_remainder(f,c);
+ if not char_exists(f,y) then goto done;
+ if char_width(f,y)>w then goto done;
+ c:=y;
+ end;
+done:
+
+@ @<Compute the amount of skew@>=
+s:=0;
+if math_type(nucleus(q))=math_char then
+ begin fetch(nucleus(q));
+ s := get_kern(cur_f,cur_c,skew_char(cur_f));
+ end
+
+@ @<Swap the subscript and superscript into box |x|@>=
+begin flush_node_list(x); x:=new_noad;
+vmem(nucleus(x)):=vmem(nucleus(q));
+vmem(supscr(x)):=vmem(supscr(q));
+vmem(subscr(x)):=vmem(subscr(q));@/
+vmem(supscr(q)).hh:=empty_field;
+vmem(subscr(q)).hh:=empty_field;@/
+math_type(nucleus(q)):=sub_mlist; vinfo(nucleus(q)):=x;
+x:=clean_box(nucleus(q),cur_style); delta:=delta+height(x)-h; h:=height(x);
+end
+
+@ The |make_fraction| procedure is a bit different because it sets
+|new_hlist(q)| directly rather than making a sub-box.
+
+@<Declare math...@>=
+procedure make_fraction(@!q:pointer);
+var p,@!v,@!x,@!y,@!z:pointer; {temporary registers for box construction}
+@!delta,@!delta1,@!delta2,@!shift_up,@!shift_down,@!clr:scaled;
+ {dimensions for box calculations}
+begin if thickness(q)=default_code then thickness(q):=default_rule_thickness;
+@<Create equal-width boxes |x| and |z| for the numerator and denominator,
+ and compute the default amounts |shift_up| and |shift_down| by which they
+ are displaced from the baseline@>;
+if thickness(q)=0 then @<Adjust \(s)|shift_up| and |shift_down| for the case
+ of no fraction line@>
+else @<Adjust \(s)|shift_up| and |shift_down| for the case of a fraction line@>;
+@<Construct a vlist box for the fraction, according to |shift_up| and
+ |shift_down|@>;
+@<Put the \(f)fraction into a box with its delimiters, and make |new_hlist(q)|
+ point to it@>;
+end;
+
+@ @<Create equal-width boxes |x| and |z| for the numerator and denom...@>=
+x:=clean_box(numerator(q),num_style(cur_style));
+z:=clean_box(denominator(q),denom_style(cur_style));
+vinfo(numerator(q)):=null;
+vinfo(denominator(q)):=null;
+if width(x)<width(z) then x:=rebox(x,width(z))
+else z:=rebox(z,width(x));
+if cur_style<text_style then {display style}
+ begin shift_up:=num1(cur_size); shift_down:=denom1(cur_size);
+ end
+else begin shift_down:=denom2(cur_size);
+ if thickness(q)<>0 then shift_up:=num2(cur_size)
+ else shift_up:=num3(cur_size);
+ end
+
+@ The numerator and denominator must be separated by a certain minimum
+clearance, called |clr| in the following program. The difference between
+|clr| and the actual clearance is |2delta|.
+
+@<Adjust \(s)|shift_up| and |shift_down| for the case of no fraction line@>=
+begin if cur_style<text_style then clr:=7*default_rule_thickness
+else clr:=3*default_rule_thickness;
+delta:=half(clr-((shift_up-depth(x))-(height(z)-shift_down)));
+if delta>0 then
+ begin shift_up:=shift_up+delta;
+ shift_down:=shift_down+delta;
+ end;
+end
+
+@ In the case of a fraction line, the minimum clearance depends on the actual
+thickness of the line.
+
+@<Adjust \(s)|shift_up| and |shift_down| for the case of a fraction line@>=
+begin if cur_style<text_style then clr:=3*thickness(q)
+else clr:=thickness(q);
+delta:=half(thickness(q));
+delta1:=clr-((shift_up-depth(x))-(axis_height(cur_size)+delta));
+delta2:=clr-((axis_height(cur_size)-delta)-(height(z)-shift_down));
+if delta1>0 then shift_up:=shift_up+delta1;
+if delta2>0 then shift_down:=shift_down+delta2;
+end
+
+@ @<Construct a vlist box for the fraction...@>=
+v:=new_null_box; type(v):=vlist_node;
+height(v):=shift_up+height(x); depth(v):=depth(z)+shift_down;
+width(v):=width(x); {this also equals |width(z)|}
+if thickness(q)=0 then
+ begin p:=new_kern((shift_up-depth(x))-(height(z)-shift_down));
+ vlink(p):=z;
+ end
+else begin y:=fraction_rule(thickness(q));@/
+ p:=new_kern((axis_height(cur_size)-delta)-@|(height(z)-shift_down));@/
+ vlink(y):=p; vlink(p):=z;@/
+ p:=new_kern((shift_up-depth(x))-(axis_height(cur_size)+delta));
+ vlink(p):=y;
+ end;
+vlink(x):=p; list_ptr(v):=x
+
+@ @<Put the \(f)fraction into a box with its delimiters...@>=
+if cur_style<text_style then delta:=delim1(cur_size)
+else delta:=delim2(cur_size);
+x:=var_delimiter(left_delimiter(q), cur_size, delta); vlink(x):=v;@/
+z:=var_delimiter(right_delimiter(q), cur_size, delta); vlink(v):=z;@/
+y:=hpack(x,natural);
+new_hlist(q):=y
+
+@ If the nucleus of an |op_noad| is a single character, it is to be
+centered vertically with respect to the axis, after first being enlarged
+(via a character list in the font) if we are in display style. The normal
+convention for placing displayed limits is to put them above and below the
+operator in display style.
+
+The italic correction is removed from the character if there is a subscript
+and the limits are not being displayed. The |make_op|
+routine returns the value that should be used as an offset between
+subscript and superscript.
+
+After |make_op| has acted, |subtype(q)| will be |limits| if and only if
+the limits have been set above and below the operator. In that case,
+|new_hlist(q)| will already contain the desired final box.
+
+@<Declare math...@>=
+function make_op(@!q:pointer):scaled;
+var delta:scaled; {offset between subscript and superscript}
+@!p,@!v,@!x,@!y,@!z:pointer; {temporary registers for box construction}
+@!c:quarterword; {register for character examination}
+@!shift_up,@!shift_down:scaled; {dimensions for box calculation}
+begin if (subtype(q)=normal)and(cur_style<text_style) then
+ subtype(q):=limits;
+if math_type(nucleus(q))=math_char then
+ begin fetch(nucleus(q));
+ if (cur_style<text_style)and(char_tag(cur_f,cur_c)=list_tag) then {make it larger}
+ begin c:=char_remainder(cur_f,cur_c);
+ if char_exists(cur_f,c) then
+ begin cur_c:=c; mcharacter(nucleus(q)):=c;
+ end;
+ end;
+ delta:=char_italic(cur_f,cur_c); x:=clean_box(nucleus(q),cur_style);
+ if (math_type(subscr(q))<>empty)and(subtype(q)<>limits) then
+ width(x):=width(x)-delta; {remove italic correction}
+ shift_amount(x):=half(height(x)-depth(x)) - axis_height(cur_size);
+ {center vertically}
+ math_type(nucleus(q)):=sub_box; vinfo(nucleus(q)):=x;
+ end
+else delta:=0;
+if subtype(q)=limits then
+ @<Construct a box with limits above and below it, skewed by |delta|@>;
+make_op:=delta;
+end;
+
+@ The following program builds a vlist box |v| for displayed limits. The
+width of the box is not affected by the fact that the limits may be skewed.
+
+@<Construct a box with limits above and below it...@>=
+begin x:=clean_box(supscr(q),sup_style(cur_style));
+y:=clean_box(nucleus(q),cur_style);
+z:=clean_box(subscr(q),sub_style(cur_style));
+v:=new_null_box; type(v):=vlist_node; width(v):=width(y);
+if width(x)>width(v) then width(v):=width(x);
+if width(z)>width(v) then width(v):=width(z);
+x:=rebox(x,width(v)); y:=rebox(y,width(v)); z:=rebox(z,width(v));@/
+shift_amount(x):=half(delta); shift_amount(z):=-shift_amount(x);
+height(v):=height(y); depth(v):=depth(y);
+@<Attach the limits to |y| and adjust |height(v)|, |depth(v)| to
+ account for their presence@>;
+new_hlist(q):=v;
+end
+
+@ We use |shift_up| and |shift_down| in the following program for the
+amount of glue between the displayed operator |y| and its limits |x| and
+|z|. The vlist inside box |v| will consist of |x| followed by |y| followed
+by |z|, with kern nodes for the spaces between and around them.
+
+@<Attach the limits to |y| and adjust |height(v)|, |depth(v)|...@>=
+if math_type(supscr(q))=empty then
+ begin list_ptr(x):=null; flush_node(x); list_ptr(v):=y;
+ end
+else begin shift_up:=big_op_spacing3-depth(x);
+ if shift_up<big_op_spacing1 then shift_up:=big_op_spacing1;
+ p:=new_kern(shift_up); vlink(p):=y; vlink(x):=p;@/
+ p:=new_kern(big_op_spacing5); vlink(p):=x; list_ptr(v):=p;
+ height(v):=height(v)+big_op_spacing5+height(x)+depth(x)+shift_up;
+ end;
+if math_type(subscr(q))=empty then begin list_ptr(z):=null; flush_node(z); end
+else begin shift_down:=big_op_spacing4-height(z);
+ if shift_down<big_op_spacing2 then shift_down:=big_op_spacing2;
+ p:=new_kern(shift_down); vlink(y):=p; vlink(p):=z;@/
+ p:=new_kern(big_op_spacing5); vlink(z):=p;
+ depth(v):=depth(v)+big_op_spacing5+height(z)+depth(z)+shift_down;
+ end
+
+@ A ligature found in a math formula does not create a ligature, because
+there is no question of hyphenation afterwards; the ligature will simply be
+stored in an ordinary |glyph_node|, after residing in an |ord_noad|.
+
+The |math_type| is converted to |math_text_char| here if we would not want to
+apply an italic correction to the current character unless it belongs
+to a math font (i.e., a font with |space=0|).
+
+No boundary characters enter into these ligatures.
+
+@<Declare math...@>=
+procedure make_ord(@!q:pointer);
+label restart,exit;
+var a:integer; { the left-side character for lig/kern testing }
+@!p,@!r:pointer; {temporary registers for list manipulation}
+k:scaled; { a kern }
+lig:liginfo; { a ligature }
+begin restart:@t@>@;@/
+if math_type(subscr(q))=empty then if math_type(supscr(q))=empty then
+ if math_type(nucleus(q))=math_char then
+ begin p:=vlink(q);
+ if p<>null then if (type(p)>=ord_noad)and(type(p)<=punct_noad) then
+ if math_type(nucleus(p))=math_char then
+ if fam(nucleus(p))=fam(nucleus(q)) then
+ begin math_type(nucleus(q)):=math_text_char;
+ fetch(nucleus(q)); a:=cur_c;
+ if (has_kern(cur_f,a))or(has_lig(cur_f,a)) then
+ begin cur_c:=mcharacter(nucleus(p));
+ @<If character |a| has a kern with |cur_c|, attach
+ the kern after~|q|; or if it has a ligature with |cur_c|, combine
+ noads |q| and~|p| appropriately; then |return| if the cursor has
+ moved past a noad, or |goto restart|@>;
+ end;
+ end;
+ end;
+exit:end;
+
+@ Note that a ligature between an |ord_noad| and another kind of noad
+is replaced by an |ord_noad|, when the two noads collapse into one.
+But we could make a parenthesis (say) change shape when it follows
+certain letters. Presumably a font designer will define such
+ligatures only when this convention makes sense.
+
+\chardef\?='174 % vertical line to indicate character retention
+
+@<If character |a| has a kern with |cur_c|, ...@>=
+begin
+if disable_lig=0 and has_lig(cur_f,a) then begin
+ lig:=get_ligature(cur_f,a,cur_c);
+ if is_valid_ligature(lig) then begin
+ check_interrupt; {allow a way out of infinite ligature loop}
+ case lig_type(lig) of
+ qi(1),qi(5): mcharacter(nucleus(q)):=lig_replacement(lig); {\.{=:\?}, \.{=:\?>}}
+ qi(2),qi(6): mcharacter(nucleus(p)):=lig_replacement(lig); {\.{\?=:}, \.{\?=:>}}
+ qi(3),qi(7),qi(11):begin r:=new_noad; {\.{\?=:\?}, \.{\?=:\?>}, \.{\?=:\?>>}}
+ mcharacter(nucleus(r)):=lig_replacement(lig);
+ fam(nucleus(r)):=fam(nucleus(q));@/
+ vlink(q):=r; vlink(r):=p;
+ if lig_type(lig)<qi(11) then math_type(nucleus(r)):=math_char
+ else math_type(nucleus(r)):=math_text_char; {prevent combination}
+ end;
+ othercases begin vlink(q):=vlink(p);
+ mcharacter(nucleus(q)):=lig_replacement(lig); {\.{=:}}
+ vmem(subscr(q)):=vmem(subscr(p)); vmem(supscr(q)):=vmem(supscr(p));@/
+ flush_node(p);
+ end
+ endcases;
+ if lig_type(lig)>qi(3) then return;
+ math_type(nucleus(q)):=math_char; goto restart;
+ end;
+ end;
+if disable_kern=0 and has_kern(cur_f,a) then begin
+ k:=get_kern(cur_f,a,cur_c);
+ if k<>0 then begin
+ p:=new_kern(k); vlink(p):=vlink(q); vlink(q):=p; return;
+ end;
+ end;
+end
+
+@ When we get to the following part of the program, we have ``fallen through''
+from cases that did not lead to |check_dimensions| or |done_with_noad| or
+|done_with_node|. Thus, |q|~points to a noad whose nucleus may need to be
+converted to an hlist, and whose subscripts and superscripts need to be
+appended if they are present.
+
+If |nucleus(q)| is not a |math_char|, the variable |delta| is the amount
+by which a superscript should be moved right with respect to a subscript
+when both are present.
+@^subscripts@>
+@^superscripts@>
+
+@<Convert \(n)|nucleus(q)| to an hlist and attach the sub/superscripts@>=
+case math_type(nucleus(q)) of
+math_char, math_text_char:
+ @<Create a character node |p| for |nucleus(q)|, possibly followed
+ by a kern node for the italic correction, and set |delta| to the
+ italic correction if a subscript is present@>;
+empty: p:=null;
+sub_box: p:=vinfo(nucleus(q));
+sub_mlist: begin cur_mlist:=vinfo(nucleus(q)); save_style:=cur_style;
+ mlist_penalties:=false; mlist_to_hlist; {recursive call}
+@^recursion@>
+ cur_style:=save_style; @<Set up the values...@>;
+ p:=hpack(vlink(temp_head),natural);
+ end;
+othercases confusion("mlist2")
+@:this can't happen mlist2}{\quad mlist2@>
+endcases;@/
+new_hlist(q):=p;
+if (math_type(subscr(q))=empty)and(math_type(supscr(q))=empty) then
+ goto check_dimensions;
+make_scripts(q,delta)
+
+@ @<Create a character node |p| for |nucleus(q)|...@>=
+begin fetch(nucleus(q));
+if char_exists(cur_f,cur_c) then
+ begin delta:=char_italic(cur_f,cur_c); p:=new_glyph(cur_f,cur_c);
+ if (math_type(nucleus(q))=math_text_char)and(space(cur_f)<>0) then
+ delta:=0; {no italic correction in mid-word of text font}
+ if (math_type(subscr(q))=empty)and(delta<>0) then
+ begin x:=new_kern(delta); vlink(p):=x; delta:=0;
+ end;
+ end
+else p:=null;
+end
+
+@ The purpose of |make_scripts(q,delta)| is to attach the subscript and/or
+superscript of noad |q| to the list that starts at |new_hlist(q)|,
+given that subscript and superscript aren't both empty. The superscript
+will appear to the right of the subscript by a given distance |delta|.
+
+We set |shift_down| and |shift_up| to the minimum amounts to shift the
+baseline of subscripts and superscripts based on the given nucleus.
+
+@<Declare math...@>=
+procedure make_scripts(@!q:pointer;@!delta:scaled);
+var p,@!x,@!y,@!z:pointer; {temporary registers for box construction}
+@!shift_up,@!shift_down,@!clr:scaled; {dimensions in the calculation}
+@!t:integer; {subsidiary size code}
+begin p:=new_hlist(q);
+if is_char_node(p) then
+ begin shift_up:=0; shift_down:=0;
+ end
+else begin z:=hpack(p,natural);
+ t:=cur_size;
+ if cur_style<script_style
+ then cur_size:=script_size@+else cur_size:=script_script_size;
+ shift_up:=height(z)-sup_drop(cur_size);
+ shift_down:=depth(z)+sub_drop(cur_size);
+ cur_size:=t;
+ list_ptr(z):=null; flush_node(z);
+ end;
+if math_type(supscr(q))=empty then
+ @<Construct a subscript box |x| when there is no superscript@>
+else begin @<Construct a superscript box |x|@>;
+ if math_type(subscr(q))=empty then shift_amount(x):=-shift_up
+ else @<Construct a sub/superscript combination box |x|, with the
+ superscript offset by |delta|@>;
+ end;
+if new_hlist(q)=null then new_hlist(q):=x
+else begin p:=new_hlist(q);
+ while vlink(p)<>null do p:=vlink(p);
+ vlink(p):=x;
+ end;
+end;
+
+@ When there is a subscript without a superscript, the top of the subscript
+should not exceed the baseline plus four-fifths of the x-height.
+
+@<Construct a subscript box |x| when there is no superscript@>=
+begin x:=clean_box(subscr(q),sub_style(cur_style));
+width(x):=width(x)+script_space;
+if shift_down<sub1(cur_size) then shift_down:=sub1(cur_size);
+clr:=height(x)-(abs(math_x_height(cur_size)*4) div 5);
+if shift_down<clr then shift_down:=clr;
+shift_amount(x):=shift_down;
+end
+
+@ The bottom of a superscript should never descend below the baseline plus
+one-fourth of the x-height.
+
+@<Construct a superscript box |x|@>=
+begin x:=clean_box(supscr(q),sup_style(cur_style));
+width(x):=width(x)+script_space;
+if odd(cur_style) then clr:=sup3(cur_size)
+else if cur_style<text_style then clr:=sup1(cur_size)
+else clr:=sup2(cur_size);
+if shift_up<clr then shift_up:=clr;
+clr:=depth(x)+(abs(math_x_height(cur_size)) div 4);
+if shift_up<clr then shift_up:=clr;
+end
+
+@ When both subscript and superscript are present, the subscript must be
+separated from the superscript by at least four times |default_rule_thickness|.
+If this condition would be violated, the subscript moves down, after which
+both subscript and superscript move up so that the bottom of the superscript
+is at least as high as the baseline plus four-fifths of the x-height.
+
+@<Construct a sub/superscript combination box |x|...@>=
+begin y:=clean_box(subscr(q),sub_style(cur_style));
+width(y):=width(y)+script_space;
+if shift_down<sub2(cur_size) then shift_down:=sub2(cur_size);
+clr:=4*default_rule_thickness-
+ ((shift_up-depth(x))-(height(y)-shift_down));
+if clr>0 then
+ begin shift_down:=shift_down+clr;
+ clr:=(abs(math_x_height(cur_size)*4) div 5)-(shift_up-depth(x));
+ if clr>0 then
+ begin shift_up:=shift_up+clr;
+ shift_down:=shift_down-clr;
+ end;
+ end;
+shift_amount(x):=delta; {superscript is |delta| to the right of the subscript}
+p:=new_kern((shift_up-depth(x))-(height(y)-shift_down)); vlink(x):=p; vlink(p):=y;
+pack_direction:=math_direction;
+x:=vpack(x,natural); shift_amount(x):=shift_down;
+end
+
+@ We have now tied up all the loose ends of the first pass of |mlist_to_hlist|.
+The second pass simply goes through and hooks everything together with the
+proper glue and penalties. It also handles the |left_noad| and |right_noad| that
+might be present, since |max_hl| and |max_d| are now known. Variable |p| points
+to a node at the current end of the final hlist.
+
+@<Make a second pass over the mlist, ...@>=
+p:=temp_head; vlink(p):=null; q:=mlist; r_type:=0; cur_style:=style;
+@<Set up the values of |cur_size| and |cur_mu|, based on |cur_style|@>;
+while q<>null do
+ begin @<If node |q| is a style node, change the style and |goto delete_q|;
+ otherwise if it is not a noad, put it into the hlist,
+ advance |q|, and |goto done|; otherwise set |s| to the size
+ of noad |q|, set |t| to the associated type (|ord_noad..
+ inner_noad|), and set |pen| to the associated penalty@>;
+ @<Append inter-element spacing based on |r_type| and |t|@>;
+ @<Append any |new_hlist| entries for |q|, and any appropriate penalties@>;
+ if type(q)=right_noad then t:=open_noad;
+ r_type:=t;
+ delete_q: r:=q; q:=vlink(q);
+ flush_node(r); {|r| had better be a noad-like thing }
+ done: end
+
+@ Just before doing the big |case| switch in the second pass, the program
+sets up default values so that most of the branches are short.
+
+@<If node |q| is a style node, change the style...@>=
+t:=ord_noad; s:=noad_size; pen:=inf_penalty;
+case type(q) of
+op_noad,open_noad,close_noad,punct_noad,inner_noad: t:=type(q);
+bin_noad: begin t:=bin_noad; pen:=bin_op_penalty;
+ end;
+rel_noad: begin t:=rel_noad; pen:=rel_penalty;
+ end;
+ord_noad,vcenter_noad,over_noad,under_noad: do_nothing;
+radical_noad: s:=radical_noad_size;
+accent_noad: s:=accent_noad_size;
+fraction_noad: begin t:=inner_noad; s:=fraction_noad_size;
+ end;
+left_noad,right_noad: t:=make_left_right(q,style,max_d,max_hl);
+style_node: @<Change the current style and |goto delete_q|@>;
+whatsit_node,penalty_node,rule_node,disc_node,adjust_node,ins_node,mark_node,
+ glue_node,kern_node:@t@>@;@/
+ begin vlink(p):=q; p:=q; q:=vlink(q); vlink(p):=null; goto done;
+ end;
+othercases confusion("mlist3")
+@:this can't happen mlist3}{\quad mlist3@>
+endcases
+
+@ The |make_left_right| function constructs a left or right delimiter of
+the required size and returns the value |open_noad| or |close_noad|. The
+|right_noad| and |left_noad| will both be based on the original |style|,
+so they will have consistent sizes.
+
+We use the fact that |right_noad-left_noad=close_noad-open_noad|.
+
+@<Declare math...@>=
+function make_left_right(@!q:pointer;@!style:integer;
+ @!max_d,@!max_hv:scaled):small_number;
+var delta,@!delta1,@!delta2:scaled; {dimensions used in the calculation}
+tmp:pointer;
+begin cur_style:=style; @<Set up the values...@>;
+delta2:=max_d+axis_height(cur_size);
+delta1:=max_hv+max_d-delta2;
+if delta2>delta1 then delta1:=delta2; {|delta1| is max distance from axis}
+delta:=(delta1 div 500)*delimiter_factor;
+delta2:=delta1+delta1-delimiter_shortfall;
+if delta<delta2 then delta:=delta2;
+tmp:=var_delimiter(delimiter(q),cur_size,delta);
+new_hlist(q):=tmp;
+make_left_right:=type(q)-(left_noad-open_noad); {|open_noad| or |close_noad|}
+end;
+
+@ @<Change the current style and |goto delete_q|@>=
+begin cur_style:=subtype(q); s:=style_node_size;
+@<Set up the values of |cur_size| and |cur_mu|, based on |cur_style|@>;
+goto delete_q;
+end
+
+@ The inter-element spacing in math formulas depends on a $8\times8$ table that
+\TeX\ preloads as a 64-digit string. The elements of this string have the
+following significance:
+$$\vbox{\halign{#\hfil\cr
+\.0 means no space;\cr
+\.1 means a conditional thin space (\.{\\nonscript\\mskip\\thinmuskip});\cr
+\.2 means a thin space (\.{\\mskip\\thinmuskip});\cr
+\.3 means a conditional medium space
+ (\.{\\nonscript\\mskip\\medmuskip});\cr
+\.4 means a conditional thick space
+ (\.{\\nonscript\\mskip\\thickmuskip});\cr
+\.* means an impossible case.\cr}}$$
+This is all pretty cryptic, but {\sl The \TeX book\/} explains what is
+supposed to happen, and the string makes it happen.
+@:TeXbook}{\sl The \TeX book@>
+
+A global variable |magic_offset| is computed so that if |a| and |b| are
+in the range |ord_noad..inner_noad|, then |str_pool[a*8+b+magic_offset]|
+is the digit for spacing between noad types |a| and |b|.
+
+If \PASCAL\ had provided a good way to preload constant arrays, this part of
+the program would not have been so strange.
+@:PASCAL}{\PASCAL@>
+
+@d math_spacing=@;@/
+@t\hskip-35pt@>
+"0234000122*4000133**3**344*0400400*000000234000111*1111112341011"
+@t$ \hskip-35pt$@>
+
+@<Glob...@>=
+@!magic_offset:integer; {used to find inter-element spacing}
+
+@ @<Compute the magic offset@>=
+magic_offset:=str_start_macro(math_spacing)-9*ord_noad
+
+@ @<Append inter-element spacing based on |r_type| and |t|@>=
+if r_type>0 then {not the first noad}
+ begin case so(str_pool[r_type*8+t+magic_offset]) of
+ "0": x:=0;
+ "1": if cur_style<script_style then x:=thin_mu_skip_code@+else x:=0;
+ "2": x:=thin_mu_skip_code;
+ "3": if cur_style<script_style then x:=med_mu_skip_code@+else x:=0;
+ "4": if cur_style<script_style then x:=thick_mu_skip_code@+else x:=0;
+ othercases confusion("mlist4")
+@:this can't happen mlist4}{\quad mlist4@>
+ endcases;
+ if x<>0 then
+ begin y:=math_glue(glue_par(x),cur_mu);
+ z:=new_glue(y); glue_ref_count(y):=null; vlink(p):=z; p:=z;@/
+ subtype(z):=x+1; {store a symbolic subtype}
+ end;
+ end
+
+@ We insert a penalty node after the hlist entries of noad |q| if |pen|
+is not an ``infinite'' penalty, and if the node immediately following |q|
+is not a penalty node or a |rel_noad| or absent entirely.
+
+@<Append any |new_hlist| entries for |q|, and any appropriate penalties@>=
+if new_hlist(q)<>null then
+ begin vlink(p):=new_hlist(q);
+ repeat p:=vlink(p);
+ until vlink(p)=null;
+ end;
+if penalties then if vlink(q)<>null then if pen<inf_penalty then
+ begin r_type:=type(vlink(q));
+ if r_type<>penalty_node then if r_type<>rel_noad then
+ begin z:=new_penalty(pen); vlink(p):=z; p:=z;
+ end;
+ end
+
+@* \[37] Alignment.
+It's sort of a miracle whenever \.{\\halign} and \.{\\valign} work, because
+they cut across so many of the control structures of \TeX.
+
+Therefore the
+present page is probably not the best place for a beginner to start reading
+this program; it is better to master everything else first.
+
+Let us focus our thoughts on an example of what the input might be, in order
+to get some idea about how the alignment miracle happens. The example doesn't
+do anything useful, but it is sufficiently general to indicate all of the
+special cases that must be dealt with; please do not be disturbed by its
+apparent complexity and meaninglessness.
+$$\vbox{\halign{\.{#}\hfil\cr
+{}\\tabskip 2pt plus 3pt\cr
+{}\\halign to 300pt\{u1\#v1\&\cr
+\hskip 50pt\\tabskip 1pt plus 1fil u2\#v2\&\cr
+\hskip 50pt u3\#v3\\cr\cr
+\hskip 25pt a1\&\\omit a2\&\\vrule\\cr\cr
+\hskip 25pt \\noalign\{\\vskip 3pt\}\cr
+\hskip 25pt b1\\span b2\\cr\cr
+\hskip 25pt \\omit\&c2\\span\\omit\\cr\}\cr}}$$
+Here's what happens:
+
+\yskip
+(0) When `\.{\\halign to 300pt\{}' is scanned, the |scan_spec| routine
+places the 300pt dimension onto the |save_stack|, and an |align_group|
+code is placed above it. This will make it possible to complete the alignment
+when the matching `\.\}' is found.
+
+(1) The preamble is scanned next. Macros in the preamble are not expanded,
+@^preamble@>
+except as part of a tabskip specification. For example, if \.{u2} had been
+a macro in the preamble above, it would have been expanded, since \TeX\
+must look for `\.{minus...}' as part of the tabskip glue. A ``preamble list''
+is constructed based on the user's preamble; in our case it contains the
+following seven items:
+$$\vbox{\halign{\.{#}\hfil\qquad&(#)\hfil\cr
+{}\\glue 2pt plus 3pt&the tabskip preceding column 1\cr
+{}\\alignrecord, width $-\infty$&preamble info for column 1\cr
+{}\\glue 2pt plus 3pt&the tabskip between columns 1 and 2\cr
+{}\\alignrecord, width $-\infty$&preamble info for column 2\cr
+{}\\glue 1pt plus 1fil&the tabskip between columns 2 and 3\cr
+{}\\alignrecord, width $-\infty$&preamble info for column 3\cr
+{}\\glue 1pt plus 1fil&the tabskip following column 3\cr}}$$
+These ``alignrecord'' entries have the same size as an |unset_node|,
+since they will later be converted into such nodes. These alignrecord
+nodes have no |depth| field; this is split into |u_part| and |v_part|,
+and they point to token lists for the templates of the alignment. For
+example, the |u_part| field in the first alignrecord points to the
+token list `\.{u1}', i.e., the template preceding the `\.\#' for
+column~1. Furthermore, They have a |span_ptr| instead of a |node_attr|
+field, and these |span_ptr| fields are initially set to the value
+|end_span|, for reasons explained below.
+
+(2) \TeX\ now looks at what follows the \.{\\cr} that ended the preamble.
+It is not `\.{\\noalign}' or `\.{\\omit}', so this input is put back to
+be read again, and the template `\.{u1}' is fed to the scanner. Just
+before reading `\.{u1}', \TeX\ goes into restricted horizontal mode.
+Just after reading `\.{u1}', \TeX\ will see `\.{a1}', and then (when the
+{\.\&} is sensed) \TeX\ will see `\.{v1}'. Then \TeX\ scans an |endv|
+token, indicating the end of a column. At this point an |unset_node| is
+created, containing the contents of the current hlist (i.e., `\.{u1a1v1}').
+The natural width of this unset node replaces the |width| field of the
+alignrecord for column~1; in general, the alignrecords will record the
+maximum natural width that has occurred so far in a given column.
+
+(3) Since `\.{\\omit}' follows the `\.\&', the templates for column~2
+are now bypassed. Again \TeX\ goes into restricted horizontal mode and
+makes an |unset_node| from the resulting hlist; but this time the
+hlist contains simply `\.{a2}'. The natural width of the new unset box
+is remembered in the |width| field of the alignrecord for column~2.
+
+(4) A third |unset_node| is created for column 3, using essentially the
+mechanism that worked for column~1; this unset box contains `\.{u3\\vrule
+v3}'. The vertical rule in this case has running dimensions that will later
+extend to the height and depth of the whole first row, since each |unset_node|
+in a row will eventually inherit the height and depth of its enclosing box.
+
+(5) The first row has now ended; it is made into a single unset box
+comprising the following seven items:
+$$\vbox{\halign{\hbox to 325pt{\qquad\.{#}\hfil}\cr
+{}\\glue 2pt plus 3pt\cr
+{}\\unsetbox for 1 column: u1a1v1\cr
+{}\\glue 2pt plus 3pt\cr
+{}\\unsetbox for 1 column: a2\cr
+{}\\glue 1pt plus 1fil\cr
+{}\\unsetbox for 1 column: u3\\vrule v3\cr
+{}\\glue 1pt plus 1fil\cr}}$$
+The width of this unset row is unimportant, but it has the correct height
+and depth, so the correct baselineskip glue will be computed as the row
+is inserted into a vertical list.
+
+(6) Since `\.{\\noalign}' follows the current \.{\\cr}, \TeX\ appends
+additional material (in this case \.{\\vskip 3pt}) to the vertical list.
+While processing this material, \TeX\ will be in internal vertical
+mode, and |no_align_group| will be on |save_stack|.
+
+(7) The next row produces an unset box that looks like this:
+$$\vbox{\halign{\hbox to 325pt{\qquad\.{#}\hfil}\cr
+{}\\glue 2pt plus 3pt\cr
+{}\\unsetbox for 2 columns: u1b1v1u2b2v2\cr
+{}\\glue 1pt plus 1fil\cr
+{}\\unsetbox for 1 column: {\rm(empty)}\cr
+{}\\glue 1pt plus 1fil\cr}}$$
+The natural width of the unset box that spans columns 1~and~2 is stored
+in a ``span node,'' which we will explain later; the |span_ptr| field of the
+alignrecord for column~1 now points to the new span node, and the |span_ptr|
+of the span node points to |end_span|.
+
+(8) The final row produces the unset box
+$$\vbox{\halign{\hbox to 325pt{\qquad\.{#}\hfil}\cr
+{}\\glue 2pt plus 3pt\cr
+{}\\unsetbox for 1 column: {\rm(empty)}\cr
+{}\\glue 2pt plus 3pt\cr
+{}\\unsetbox for 2 columns: u2c2v2\cr
+{}\\glue 1pt plus 1fil\cr}}$$
+A new span node is attached to the alignrecord for column 2.
+
+(9) The last step is to compute the true column widths and to change all the
+unset boxes to hboxes, appending the whole works to the vertical list that
+encloses the \.{\\halign}. The rules for deciding on the final widths of
+each unset column box will be explained below.
+
+\yskip\noindent
+Note that as \.{\\halign} is being processed, we fearlessly give up control
+to the rest of \TeX. At critical junctures, an alignment routine is
+called upon to step in and do some little action, but most of the time
+these routines just lurk in the background. It's something like
+post-hypnotic suggestion.
+
+@ We have mentioned that alignrecords contain no |height| or |depth| fields.
+Their |glue_sign| and |glue_order| are pre-empted as well, since it
+is necessary to store information about what to do when a template ends.
+This information is called the |extra_info| field.
+
+@d align_record_node=34
+@d u_part(#)==vlink(#+depth_offset) {pointer to \<u_j> token list}
+@d v_part(#)==vinfo(#+depth_offset) {pointer to \<v_j> token list}
+@d span_ptr(#)==vinfo(#+1) {column spanning list}
+@d extra_info(#)==vinfo(#+list_offset) {info to remember during template}
+
+@ Alignments can occur within alignments, so a small stack is used to access
+the alignrecord information. At each level we have a |preamble| pointer,
+indicating the beginning of the preamble list; a |cur_align| pointer,
+indicating the current position in the preamble list; a |cur_span| pointer,
+indicating the value of |cur_align| at the beginning of a sequence of
+spanned columns; a |cur_loop| pointer, indicating the tabskip glue before
+an alignrecord that should be copied next if the current list is extended;
+and the |align_state| variable, which indicates the nesting of braces so
+that \.{\\cr} and \.{\\span} and tab marks are properly intercepted.
+There also are pointers |cur_head| and |cur_tail| to the head and tail
+of a list of adjustments being moved out from horizontal mode to
+vertical~mode, and alike |cur_pre_head| and |cur_pre_tail| for pre-adjust
+lists.
+
+The current values of these nine quantities appear in global variables;
+when they have to be pushed down, they are stored in 6-word nodes, and
+|align_ptr| points to the topmost such node.
+
+@d preamble==vlink(align_head) {the current preamble list}
+@d align_stack_node=47
+
+@<Glob...@>=
+@!cur_align:pointer; {current position in preamble list}
+@!cur_span:pointer; {start of currently spanned columns in preamble list}
+@!cur_loop:pointer; {place to copy when extending a periodic preamble}
+@!align_ptr:pointer; {most recently pushed-down alignment stack node}
+@!cur_head,@!cur_tail:pointer; {adjustment list pointers}
+@!cur_pre_head,@!cur_pre_tail:pointer; {pre-adjustment list pointers}
+
+@ The |align_state| and |preamble| variables are initialized elsewhere.
+
+@<Set init...@>=
+align_ptr:=null; cur_align:=null; cur_span:=null; cur_loop:=null;
+cur_head:=null; cur_tail:=null;
+cur_pre_head:=null; cur_pre_tail:=null;
+
+@ Alignment stack maintenance is handled by a pair of trivial routines
+called |push_alignment| and |pop_alignment|.
+
+@p procedure push_alignment;
+var p:pointer; {the new alignment stack node}
+begin p:=new_node(align_stack_node,0);
+vinfo(p+1):=align_ptr; vlink(p+1):=cur_align;
+vinfo(p+2):=preamble; vlink(p+2):=cur_span;
+vinfo(p+3):=cur_loop; vlink(p+3):=align_state;
+vinfo(p+4):=cur_head; vlink(p+4):=cur_tail;
+vinfo(p+5):=cur_pre_head; vlink(p+5):=cur_pre_tail;
+align_ptr:=p;
+cur_head:=new_node(temp_node,0);
+end;
+@#
+procedure pop_alignment;
+var p:pointer; {the top alignment stack node}
+begin flush_node(cur_head);
+p:=align_ptr;
+cur_pre_tail:=vlink(p+5); cur_pre_head:=vinfo(p+5);
+cur_tail :=vlink(p+4); cur_head :=vinfo(p+4);
+align_state :=vlink(p+3); cur_loop :=vinfo(p+3);
+cur_span :=vlink(p+2); preamble :=vinfo(p+2);
+cur_align :=vlink(p+1); align_ptr :=vinfo(p+1);
+flush_node(p);
+end;
+
+@ \TeX\ has eight procedures that govern alignments: |init_align| and
+|fin_align| are used at the very beginning and the very end; |init_row| and
+|fin_row| are used at the beginning and end of individual rows; |init_span|
+is used at the beginning of a sequence of spanned columns (possibly involving
+only one column); |init_col| and |fin_col| are used at the beginning and
+end of individual columns; and |align_peek| is used after \.{\\cr} to see
+whether the next item is \.{\\noalign}.
+
+We shall consider these routines in the order they are first used during
+the course of a complete \.{\\halign}, namely |init_align|, |align_peek|,
+|init_row|, |init_span|, |init_col|, |fin_col|, |fin_row|, |fin_align|.
+
+@ When \.{\\halign} or \.{\\valign} has been scanned in an appropriate
+mode, \TeX\ calls |init_align|, whose task is to get everything off to a
+good start. This mostly involves scanning the preamble and putting its
+information into the preamble list.
+@^preamble@>
+
+@p @t\4@>@<Declare the procedure called |get_preamble_token|@>@t@>@/
+procedure@?align_peek; forward;@t\2@>@/
+procedure@?normal_paragraph; forward;@t\2@>@/
+procedure init_align;
+label done, done1, done2, continue;
+var save_cs_ptr:pointer; {|warning_index| value for error messages}
+@!p,r:pointer; {for short-term temporary use}
+begin save_cs_ptr:=cur_cs; {\.{\\halign} or \.{\\valign}, usually}
+push_alignment; align_state:=-1000000; {enter a new alignment level}
+@<Check for improper alignment in displayed math@>;
+push_nest; {enter a new semantic level}
+@<Change current mode to |-vmode| for \.{\\halign}, |-hmode| for \.{\\valign}@>;
+scan_spec(align_group,false);@/
+@<Scan the preamble and record it in the |preamble| list@>;
+new_save_level(align_group);
+if every_cr<>null then begin_token_list(every_cr,every_cr_text);
+align_peek; {look for \.{\\noalign} or \.{\\omit}}
+end;
+
+@ In vertical modes, |prev_depth| already has the correct value. But
+if we are in |mmode| (displayed formula mode), we reach out to the
+enclosing vertical mode for the |prev_depth| value that produces the
+correct baseline calculations.
+
+@<Change current mode...@>=
+if mode=mmode then
+ begin mode:=-vmode; prev_depth:=nest[nest_ptr-2].aux_field.sc;
+ end
+else if mode>0 then negate(mode)
+
+@ When \.{\\halign} is used as a displayed formula, there should be
+no other pieces of mlists present.
+
+@<Check for improper alignment in displayed math@>=
+if (mode=mmode)and((tail<>head)or(incompleat_noad<>null)) then
+ begin print_err("Improper "); print_esc("halign"); print(" inside $$'s");
+@.Improper \\halign...@>
+ help3("Displays can use special alignments (like \eqalignno)")@/
+ ("only if nothing but the alignment itself is between $$'s.")@/
+ ("So I've deleted the formulas that preceded this alignment.");
+ error; flush_math;
+ end
+
+@ @<Scan the preamble and record it in the |preamble| list@>=
+preamble:=null; cur_align:=align_head; cur_loop:=null; scanner_status:=aligning;
+warning_index:=save_cs_ptr; align_state:=-1000000;
+ {at this point, |cur_cmd=left_brace|}
+loop@+ begin @<Append the current tabskip glue to the preamble list@>;
+ if cur_cmd=car_ret then goto done; {\.{\\cr} ends the preamble}
+ @<Scan preamble text until |cur_cmd| is |tab_mark| or |car_ret|,
+ looking for changes in the tabskip glue; append an
+ alignrecord to the preamble list@>;
+ end;
+done: scanner_status:=normal
+
+@ @<Append the current tabskip glue to the preamble list@>=
+r:=new_param_glue(tab_skip_code); vlink(cur_align):=r;
+cur_align:=vlink(cur_align)
+
+@ @<Scan preamble text until |cur_cmd| is |tab_mark| or |car_ret|...@>=
+@<Scan the template \<u_j>, putting the resulting token list in |hold_token_head|@>;
+r:=new_node(align_record_node,0); vlink(cur_align):=r;
+cur_align:=vlink(cur_align); {a new alignrecord}
+span_ptr(cur_align):=end_span; width(cur_align):=null_flag;
+u_part(cur_align):=link(hold_token_head);
+@<Scan the template \<v_j>, putting the resulting token list in |hold_token_head|@>;
+v_part(cur_align):=link(hold_token_head)
+
+@ We enter `\.{\\span}' into |eqtb| with |tab_mark| as its command code,
+and with |span_code| as the command modifier. This makes \TeX\ interpret it
+essentially the same as an alignment delimiter like `\.\&', yet it is
+recognizably different when we need to distinguish it from a normal delimiter.
+It also turns out to be useful to give a special |cr_code| to `\.{\\cr}',
+and an even larger |cr_cr_code| to `\.{\\crcr}'.
+
+The end of a template is represented by two ``frozen'' control sequences
+called \.{\\endtemplate}. The first has the command code |end_template|, which
+is |>outer_call|, so it will not easily disappear in the presence of errors.
+The |get_x_token| routine converts the first into the second, which has |endv|
+as its command code.
+
+@d span_code=special_char {distinct from any character}
+@d cr_code=span_code+1 {distinct from |span_code| and from any character}
+@d cr_cr_code=cr_code+1 {this distinguishes \.{\\crcr} from \.{\\cr}}
+@d end_template_token==cs_token_flag+frozen_end_template
+
+@<Put each of \TeX's primitives into the hash table@>=
+primitive("span",tab_mark,span_code);@/
+@!@:span_}{\.{\\span} primitive@>
+primitive("cr",car_ret,cr_code);
+@!@:cr_}{\.{\\cr} primitive@>
+text(frozen_cr):="cr"; eqtb[frozen_cr]:=eqtb[cur_val];@/
+primitive("crcr",car_ret,cr_cr_code);
+@!@:cr_cr_}{\.{\\crcr} primitive@>
+text(frozen_end_template):="endtemplate"; text(frozen_endv):="endtemplate";
+eq_type(frozen_endv):=endv; equiv(frozen_endv):=null_list;
+eq_level(frozen_endv):=level_one;@/
+eqtb[frozen_end_template]:=eqtb[frozen_endv];
+eq_type(frozen_end_template):=end_template;
+
+@ @<Cases of |print_cmd_chr|...@>=
+tab_mark: if chr_code=span_code then print_esc("span")
+ else chr_cmd("alignment tab character ");
+car_ret: if chr_code=cr_code then print_esc("cr")
+ else print_esc("crcr");
+
+@ The preamble is copied directly, except that \.{\\tabskip} causes a change
+to the tabskip glue, thereby possibly expanding macros that immediately
+follow it. An appearance of \.{\\span} also causes such an expansion.
+
+Note that if the preamble contains `\.{\\global\\tabskip}', the `\.{\\global}'
+token survives in the preamble and the `\.{\\tabskip}' defines new
+tabskip glue (locally).
+
+@<Declare the procedure called |get_preamble_token|@>=
+procedure get_preamble_token;
+label restart;
+begin restart: get_token;
+while (cur_chr=span_code)and(cur_cmd=tab_mark) do
+ begin get_token; {this token will be expanded once}
+ if cur_cmd>max_command then
+ begin expand; get_token;
+ end;
+ end;
+if cur_cmd=endv then
+ fatal_error("(interwoven alignment preambles are not allowed)");
+@.interwoven alignment preambles...@>
+if (cur_cmd=assign_glue)and(cur_chr=glue_base+tab_skip_code) then
+ begin scan_optional_equals; scan_glue(glue_val);
+ if global_defs>0 then geq_define(glue_base+tab_skip_code,glue_ref,cur_val)
+ else eq_define(glue_base+tab_skip_code,glue_ref,cur_val);
+ goto restart;
+ end;
+end;
+
+@ Spaces are eliminated from the beginning of a template.
+
+@<Scan the template \<u_j>...@>=
+p:=hold_token_head; link(p):=null;
+loop@+ begin get_preamble_token;
+ if cur_cmd=mac_param then goto done1;
+ if (cur_cmd<=car_ret)and(cur_cmd>=tab_mark)and(align_state=-1000000) then
+ if (p=hold_token_head)and(cur_loop=null)and(cur_cmd=tab_mark)
+ then cur_loop:=cur_align
+ else begin print_err("Missing # inserted in alignment preamble");
+@.Missing \# inserted...@>
+ help3("There should be exactly one # between &'s, when an")@/
+ ("\halign or \valign is being set up. In this case you had")@/
+ ("none, so I've put one in; maybe that will work.");
+ back_error; goto done1;
+ end
+ else if (cur_cmd<>spacer)or(p<>hold_token_head) then
+ begin r:=get_avail; link(p):=r; p:=link(p); info(p):=cur_tok;
+ end;
+ end;
+done1:
+
+@ @<Scan the template \<v_j>...@>=
+p:=hold_token_head; link(p):=null;
+loop@+ begin continue: get_preamble_token;
+ if (cur_cmd<=car_ret)and(cur_cmd>=tab_mark)and(align_state=-1000000) then
+ goto done2;
+ if cur_cmd=mac_param then
+ begin print_err("Only one # is allowed per tab");
+@.Only one \# is allowed...@>
+ help3("There should be exactly one # between &'s, when an")@/
+ ("\halign or \valign is being set up. In this case you had")@/
+ ("more than one, so I'm ignoring all but the first.");
+ error; goto continue;
+ end;
+ r:=get_avail; link(p):=r; p:=link(p); info(p):=cur_tok;
+ end;
+done2: r:=get_avail; link(p):=r; p:=link(p);
+info(p):=end_template_token {put \.{\\endtemplate} at the end}
+
+@ The tricky part about alignments is getting the templates into the
+scanner at the right time, and recovering control when a row or column
+is finished.
+
+We usually begin a row after each \.{\\cr} has been sensed, unless that
+\.{\\cr} is followed by \.{\\noalign} or by the right brace that terminates
+the alignment. The |align_peek| routine is used to look ahead and do
+the right thing; it either gets a new row started, or gets a \.{\\noalign}
+started, or finishes off the alignment.
+
+@<Declare the procedure called |align_peek|@>=
+procedure align_peek;
+label restart;
+begin restart: align_state:=1000000;
+repeat get_x_or_protected;
+until cur_cmd<>spacer;
+if cur_cmd=no_align then
+ begin scan_left_brace; new_save_level(no_align_group);
+ if mode=-vmode then normal_paragraph;
+ end
+else if cur_cmd=right_brace then fin_align
+else if (cur_cmd=car_ret)and(cur_chr=cr_cr_code) then
+ goto restart {ignore \.{\\crcr}}
+else begin init_row; {start a new row}
+ init_col; {start a new column and replace what we peeked at}
+ end;
+end;
+
+@ To start a row (i.e., a `row' that rhymes with `dough' but not with `bough'),
+we enter a new semantic level, copy the first tabskip glue, and change
+from internal vertical mode to restricted horizontal mode or vice versa.
+The |space_factor| and |prev_depth| are not used on this semantic level,
+but we clear them to zero just to be tidy.
+
+@p @t\4@>@<Declare the procedure called |init_span|@>@t@>@/
+procedure init_row;
+begin push_nest; mode:=(-hmode-vmode)-mode;
+if mode=-hmode then space_factor:=0 @+else prev_depth:=0;
+tail_append(new_glue(glue_ptr(preamble)));
+subtype(tail):=tab_skip_code+1;@/
+cur_align:=vlink(preamble); cur_tail:=cur_head; cur_pre_tail:=cur_pre_head;
+init_span(cur_align);
+end;
+
+@ The parameter to |init_span| is a pointer to the alignrecord where the
+next column or group of columns will begin. A new semantic level is
+entered, so that the columns will generate a list for subsequent packaging.
+
+@<Declare the procedure called |init_span|@>=
+procedure init_span(@!p:pointer);
+begin push_nest;
+if mode=-hmode then space_factor:=1000
+else begin prev_depth:=ignore_depth; normal_paragraph;
+ end;
+cur_span:=p;
+end;
+
+@ When a column begins, we assume that |cur_cmd| is either |omit| or else
+the current token should be put back into the input until the \<u_j>
+template has been scanned. (Note that |cur_cmd| might be |tab_mark| or
+|car_ret|.) We also assume that |align_state| is approximately 1000000 at
+this time. We remain in the same mode, and start the template if it is
+called for.
+
+@p procedure init_col;
+begin extra_info(cur_align):=cur_cmd;
+if cur_cmd=omit then align_state:=0
+else begin back_input; begin_token_list(u_part(cur_align),u_template);
+ end; {now |align_state=1000000|}
+end;
+
+@ The scanner sets |align_state| to zero when the \<u_j> template ends. When
+a subsequent \.{\\cr} or \.{\\span} or tab mark occurs with |align_state=0|,
+the scanner activates the following code, which fires up the \<v_j> template.
+We need to remember the |cur_chr|, which is either |cr_cr_code|, |cr_code|,
+|span_code|, or a character code, depending on how the column text has ended.
+
+This part of the program had better not be activated when the preamble
+to another alignment is being scanned, or when no alignment preamble is active.
+
+@p procedure insert_vj_template;
+begin if (scanner_status=aligning) or (cur_align=null) then
+ fatal_error("(interwoven alignment preambles are not allowed)");
+@.interwoven alignment preambles...@>
+cur_cmd:=extra_info(cur_align); extra_info(cur_align):=cur_chr;
+if cur_cmd=omit then begin_token_list(omit_template,v_template)
+else begin_token_list(v_part(cur_align),v_template);
+align_state:=1000000;
+end;
+
+@ The token list |omit_template| just referred to is a constant token
+list that contains the special control sequence \.{\\endtemplate} only.
+
+@<Initialize the special...@>=
+info(omit_template):=end_template_token; {|link(omit_template)=null|}
+
+@ When the |endv| command at the end of a \<v_j> template comes through the
+scanner, things really start to happen; and it is the |fin_col| routine
+that makes them happen. This routine returns |true| if a row as well as a
+column has been finished.
+
+@p function fin_col:boolean;
+label exit;
+var p:pointer; {the alignrecord after the current one}
+@!q,@!r:pointer; {temporary pointers for list manipulation}
+@!s:pointer; {a new span node}
+@!u:pointer; {a new unset box}
+@!w:scaled; {natural width}
+@!o:glue_ord; {order of infinity}
+@!n:halfword; {span counter}
+begin if cur_align=null then confusion("endv");
+q:=vlink(cur_align);@+if q=null then confusion("endv");
+@:this can't happen endv}{\quad endv@>
+if align_state<500000 then
+ fatal_error("(interwoven alignment preambles are not allowed)");
+@.interwoven alignment preambles...@>
+p:=vlink(q);
+@<If the preamble list has been traversed, check that the row has ended@>;
+if extra_info(cur_align)<>span_code then
+ begin unsave; new_save_level(align_group);@/
+ @<Package an unset box for the current column and record its width@>;
+ @<Copy the tabskip glue between columns@>;
+ if extra_info(cur_align)>=cr_code then
+ begin fin_col:=true; return;
+ end;
+ init_span(p);
+ end;
+align_state:=1000000;
+repeat get_x_or_protected;
+until cur_cmd<>spacer;
+cur_align:=p;
+init_col; fin_col:=false;
+exit: end;
+
+@ @<If the preamble list has been traversed, check that the row has ended@>=
+if (p=null)and(extra_info(cur_align)<cr_code) then
+ if cur_loop<>null then @<Lengthen the preamble periodically@>
+ else begin print_err("Extra alignment tab has been changed to ");
+@.Extra alignment tab...@>
+ print_esc("cr");
+ help3("You have given more \span or & marks than there were")@/
+ ("in the preamble to the \halign or \valign now in progress.")@/
+ ("So I'll assume that you meant to type \cr instead.");
+ extra_info(cur_align):=cr_code; error;
+ end
+
+@ @<Lengthen the preamble...@>=
+begin r:=new_node(align_record_node,0); vlink(q):=r; p:=vlink(q); {a new alignrecord}
+span_ptr(p):=end_span; width(p):=null_flag; cur_loop:=vlink(cur_loop);
+@<Copy the templates from node |cur_loop| into node |p|@>;
+cur_loop:=vlink(cur_loop);
+r:=new_glue(glue_ptr(cur_loop)); vlink(p):=r;
+end
+
+@ @<Copy the templates from node |cur_loop| into node |p|@>=
+q:=hold_token_head; r:=u_part(cur_loop);
+while r<>null do
+ begin s:=get_avail; link(q):=s; q:=link(q); info(q):=info(r); r:=link(r);
+ end;
+link(q):=null; u_part(p):=link(hold_token_head);
+q:=hold_token_head; r:=v_part(cur_loop);
+while r<>null do
+ begin s:=get_avail; link(q):=s; q:=link(q); info(q):=info(r); r:=link(r);
+ end;
+link(q):=null; v_part(p):=link(hold_token_head)
+
+@ @<Copy the tabskip glue...@>=
+tail_append(new_glue(glue_ptr(vlink(cur_align))));
+subtype(tail):=tab_skip_code+1
+
+@ @<Package an unset...@>=
+begin if mode=-hmode then
+ begin adjust_tail:=cur_tail; pre_adjust_tail:=cur_pre_tail;
+ u:=filtered_hpack(head,tail,natural,align_set_group); w:=width(u);
+ cur_tail:=adjust_tail; adjust_tail:=null;
+ cur_pre_tail:=pre_adjust_tail; pre_adjust_tail:=null;
+ end
+else begin u:=filtered_vpackage(vlink(head),natural,0,align_set_group); w:=height(u);
+ end;
+n:=min_quarterword; {this represents a span count of 1}
+if cur_span<>cur_align then @<Update width entry for spanned columns@>
+else if w>width(cur_align) then width(cur_align):=w;
+type(u):=unset_node; span_count(u):=n;@/
+@<Determine the stretch order@>;
+glue_order(u):=o; glue_stretch(u):=total_stretch[o];@/
+@<Determine the shrink order@>;
+glue_sign(u):=o; glue_shrink(u):=total_shrink[o];@/
+pop_nest; vlink(tail):=u; tail:=u;
+end
+
+@ A span node is a 3-word record containing |width|, |span_span|, and
+|span_ptr| fields. The |span_span| field indicates the number of
+spanned columns; the |span_ptr| field points to a span node for the same
+starting column, having a greater extent of spanning, or to
+|end_span|, which has the largest possible |span_span| field; the |width|
+field holds the largest natural width corresponding to a particular
+set of spanned columns.
+
+A list of the maximum widths so far, for spanned columns starting at a
+given column, begins with the |span_ptr| field of the alignrecord for
+that column. The code has to make sure that there is room for
+|span_ptr| in both the alignrecord and the span nodes, which is why
+|span_ptr| replaces |node_attr|.
+@^data structure assumptions@>
+
+The |new_span_node| function is defined in |texnodes.c|.
+
+@d span_node==41
+@d span_node_size==3 {number of |mem| words for a span node}
+@d span_span(#)==vlink(#+1) {that is normally |alink| }
+
+@<Initialize the special list heads...@>=
+span_span(end_span):=max_quarterword+1; span_ptr(end_span):=null;
+
+@ @<Update width entry for spanned columns@>=
+begin q:=cur_span;
+repeat incr(n); q:=vlink(vlink(q));
+until q=cur_align;
+if n>max_quarterword then confusion("too many spans"); {this can happen, but won't}
+@^system dependencies@>
+@:this can't happen too many spans}{\quad too many spans@>
+q:=cur_span;
+while span_span(span_ptr(q))<n do begin
+ q:=span_ptr(q);
+ end;
+if span_span(span_ptr(q))>n then begin
+ s:=new_span_node(span_ptr(q),n,w);
+ span_ptr(q):=s;
+ end
+else if width(span_ptr(q))<w then width(span_ptr(q)):=w;
+end
+
+@ At the end of a row, we append an unset box to the current vlist (for
+\.{\\halign}) or the current hlist (for \.{\\valign}). This unset box
+contains the unset boxes for the columns, separated by the tabskip glue.
+Everything will be set later.
+
+@p procedure fin_row;
+var p:pointer; {the new unset box}
+begin if mode=-hmode then
+ begin p:=filtered_hpack(head,tail,natural,fin_row_group);
+ pop_nest;
+ if cur_pre_head <> cur_pre_tail then
+ append_list(cur_pre_head)(cur_pre_tail);
+ append_to_vlist(p);
+ if cur_head <> cur_tail then
+ append_list(cur_head)(cur_tail);
+ end
+else begin p:=filtered_vpackage(vlink(head),natural,max_depth,fin_row_group);
+ pop_nest; vlink(tail):=p; tail:=p; space_factor:=1000;
+ end;
+type(p):=unset_node; glue_stretch(p):=0;
+if every_cr<>null then begin_token_list(every_cr,every_cr_text);
+align_peek;
+end; {note that |glue_shrink(p)=0| since |glue_shrink==shift_amount|}
+
+@ Finally, we will reach the end of the alignment, and we can breathe a
+sigh of relief that memory hasn't overflowed. All the unset boxes will now be
+set so that the columns line up, taking due account of spanned columns.
+
+@p procedure@?do_assignments; forward;@t\2@>@/
+procedure@?resume_after_display; forward;@t\2@>@/
+procedure@?build_page; forward;@t\2@>@/
+procedure fin_align;
+var @!p,@!q,@!r,@!s,@!u,@!v,@!rr: pointer; {registers for the list operations}
+@!t,@!w:scaled; {width of column}
+@!o:scaled; {shift offset for unset boxes}
+@!n:halfword; {matching span amount}
+@!rule_save:scaled; {temporary storage for |overfull_rule|}
+@!aux_save:memory_word; {temporary storage for |aux|}
+begin if cur_group<>align_group then confusion("align1");
+@:this can't happen align}{\quad align@>
+unsave; {that |align_group| was for individual entries}
+if cur_group<>align_group then confusion("align0");
+unsave; {that |align_group| was for the whole alignment}
+if nest[nest_ptr-1].mode_field=mmode then o:=display_indent
+ else o:=0;
+@<Go through the preamble list, determining the column widths and
+ changing the alignrecords to dummy unset boxes@>;
+@<Package the preamble list, to determine the actual tabskip glue amounts,
+ and let |p| point to this prototype box@>;
+@<Set the glue in all the unset boxes of the current list@>;
+flush_node_list(p); pop_alignment;
+@<Insert the \(c)current list into its environment@>;
+end;@/
+@t\4@>@<Declare the procedure called |align_peek|@>
+
+@ It's time now to dismantle the preamble list and to compute the column
+widths. Let $w_{ij}$ be the maximum of the natural widths of all entries
+that span columns $i$ through $j$, inclusive. The alignrecord for column~$i$
+contains $w_{ii}$ in its |width| field, and there is also a linked list of
+the nonzero $w_{ij}$ for increasing $j$, accessible via the |info| field;
+these span nodes contain the value $j-i-1+|min_quarterword|$ in their
+|link| fields. The values of $w_{ii}$ were initialized to |null_flag|, which
+we regard as $-\infty$.
+
+The final column widths are defined by the formula
+$$w_j=\max_{1\L i\L j}\biggl( w_{ij}-\sum_{i\L k<j}(t_k+w_k)\biggr),$$
+where $t_k$ is the natural width of the tabskip glue between columns
+$k$ and~$k+1$. However, if $w_{ij}=-\infty$ for all |i| in the range
+|1<=i<=j| (i.e., if every entry that involved column~|j| also involved
+column~|j+1|), we let $w_j=0$, and we zero out the tabskip glue after
+column~|j|.
+
+\TeX\ computes these values by using the following scheme: First $w_1=w_{11}$.
+Then replace $w_{2j}$ by $\max(w_{2j},w_{1j}-t_1-w_1)$, for all $j>1$.
+Then $w_2=w_{22}$. Then replace $w_{3j}$ by $\max(w_{3j},w_{2j}-t_2-w_2)$
+for all $j>2$; and so on. If any $w_j$ turns out to be $-\infty$, its
+value is changed to zero and so is the next tabskip.
+
+@<Go through the preamble list,...@>=
+q:=vlink(preamble);
+repeat flush_list(u_part(q)); flush_list(v_part(q));
+p:=vlink(vlink(q));
+if width(q)=null_flag then
+ @<Nullify |width(q)| and the tabskip glue following this column@>;
+if span_ptr(q)<>end_span then
+ @<Merge the widths in the span nodes of |q| with those of |p|,
+ destroying the span nodes of |q|@>;
+type(q):=unset_node; span_count(q):=min_quarterword; height(q):=0;
+depth(q):=0; glue_order(q):=normal; glue_sign(q):=normal;
+glue_stretch(q):=0; glue_shrink(q):=0; q:=p;
+until q=null
+
+@ @<Nullify |width(q)| and the tabskip glue following this column@>=
+begin width(q):=0; r:=vlink(q); s:=glue_ptr(r);
+if s<>zero_glue then
+ begin add_glue_ref(zero_glue); delete_glue_ref(s);
+ glue_ptr(r):=zero_glue;
+ end;
+end
+
+@ Merging of two span-node lists is a typical exercise in the manipulation of
+linearly linked data structures. The essential invariant in the following
+|repeat| loop is that we want to dispense with node |r|, in |q|'s list,
+and |u| is its successor; all nodes of |p|'s list up to and including |s|
+have been processed, and the successor of |s| matches |r| or precedes |r|
+or follows |r|, according as |link(r)=n| or |link(r)>n| or |link(r)<n|.
+
+@<Merge the widths...@>=
+begin t:=width(q)+width(glue_ptr(vlink(q)));
+r:=span_ptr(q); s:=end_span; span_ptr(s):=p; n:=min_quarterword+1;
+repeat width(r):=width(r)-t; u:=span_ptr(r);
+while span_span(r)>n do
+ begin s:=span_ptr(s); n:=span_span(span_ptr(s))+1;
+ end;
+if span_span(r)<n then
+ begin span_ptr(r):=span_ptr(s); span_ptr(s):=r; decr(span_span(r)); s:=r;
+ end
+else begin if width(r)>width(span_ptr(s)) then width(span_ptr(s)):=width(r);
+ flush_node(r);
+ end;
+r:=u;
+until r=end_span;
+end
+
+@ Now the preamble list has been converted to a list of alternating unset
+boxes and tabskip glue, where the box widths are equal to the final
+column sizes. In case of \.{\\valign}, we change the widths to heights,
+so that a correct error message will be produced if the alignment is
+overfull or underfull.
+
+@<Package the preamble list...@>=
+save_ptr:=save_ptr-2; pack_begin_line:=-mode_line;
+if mode=-vmode then
+ begin rule_save:=overfull_rule;
+ overfull_rule:=0; {prevent rule from being packaged}
+ p:=hpack(preamble,saved(1),saved(0));
+ overfull_rule:=rule_save;
+ end
+else begin q:=vlink(preamble);
+ repeat height(q):=width(q); width(q):=0; q:=vlink(vlink(q));
+ until q=null;
+ p:=filtered_vpackage(preamble,saved(1),saved(0),max_depth,preamble_group);
+ q:=vlink(preamble);
+ repeat width(q):=height(q); height(q):=0; q:=vlink(vlink(q));
+ until q=null;
+ end;
+pack_begin_line:=0
+
+@ @<Set the glue in all the unset...@>=
+q:=vlink(head); s:=head;
+while q<>null do
+ begin if not is_char_node(q) then
+ if type(q)=unset_node then
+ @<Set the unset box |q| and the unset boxes in it@>
+ else if type(q)=rule_node then
+ @<Make the running dimensions in rule |q| extend to the
+ boundaries of the alignment@>;
+ s:=q; q:=vlink(q);
+ end
+
+@ @<Make the running dimensions in rule |q| extend...@>=
+begin if is_running(width(q)) then width(q):=width(p);
+if is_running(height(q)) then height(q):=height(p);
+if is_running(depth(q)) then depth(q):=depth(p);
+if o<>0 then
+ begin r:=vlink(q); vlink(q):=null; q:=hpack(q,natural);
+ shift_amount(q):=o; vlink(q):=r; vlink(s):=q;
+ end;
+end
+
+@ The unset box |q| represents a row that contains one or more unset boxes,
+depending on how soon \.{\\cr} occurred in that row.
+
+@<Set the unset box |q| and the unset boxes in it@>=
+begin if mode=-vmode then
+ begin type(q):=hlist_node; width(q):=width(p);
+ end
+else begin type(q):=vlist_node; height(q):=height(p);
+ end;
+glue_order(q):=glue_order(p); glue_sign(q):=glue_sign(p);
+glue_set(q):=glue_set(p); shift_amount(q):=o;
+r:=vlink(list_ptr(q)); s:=vlink(list_ptr(p));
+repeat @<Set the glue in node |r| and change it from an unset node@>;
+r:=vlink(vlink(r)); s:=vlink(vlink(s));
+until r=null;
+end
+
+@ A box made from spanned columns will be followed by tabskip glue nodes and
+by empty boxes as if there were no spanning. This permits perfect alignment
+of subsequent entries, and it prevents values that depend on floating point
+arithmetic from entering into the dimensions of any boxes.
+
+@<Set the glue in node |r|...@>=
+n:=span_count(r); t:=width(s); w:=t; u:=hold_head;
+while n>min_quarterword do
+ begin decr(n);
+ @<Append tabskip glue and an empty box to list |u|,
+ and update |s| and |t| as the prototype nodes are passed@>;
+ end;
+if mode=-vmode then
+ @<Make the unset node |r| into an |hlist_node| of width |w|,
+ setting the glue as if the width were |t|@>
+else @<Make the unset node |r| into a |vlist_node| of height |w|,
+ setting the glue as if the height were |t|@>;
+shift_amount(r):=0;
+if u<>hold_head then {append blank boxes to account for spanned nodes}
+ begin vlink(u):=vlink(r); vlink(r):=vlink(hold_head); r:=u;
+ end
+
+@ @<Append tabskip glue and an empty box to list |u|...@>=
+s:=vlink(s); v:=glue_ptr(s); vlink(u):=new_glue(v); u:=vlink(u);
+subtype(u):=tab_skip_code+1; t:=t+width(v);
+if glue_sign(p)=stretching then
+ begin if stretch_order(v)=glue_order(p) then
+ t:=t+round(float(glue_set(p))*stretch(v));
+@^real multiplication@>
+ end
+else if glue_sign(p)=shrinking then
+ begin if shrink_order(v)=glue_order(p) then
+ t:=t-round(float(glue_set(p))*shrink(v));
+ end;
+s:=vlink(s); rr:=new_null_box; vlink(u):=rr; u:=vlink(u); t:=t+width(s);
+if mode=-vmode then width(u):=width(s)@+else
+ begin type(u):=vlist_node; height(u):=width(s);
+ end
+
+@ @<Make the unset node |r| into an |hlist_node| of width |w|...@>=
+begin height(r):=height(q); depth(r):=depth(q);
+if t=width(r) then
+ begin glue_sign(r):=normal; glue_order(r):=normal;
+ set_glue_ratio_zero(glue_set(r));
+ end
+else if t>width(r) then
+ begin glue_sign(r):=stretching;
+ if glue_stretch(r)=0 then set_glue_ratio_zero(glue_set(r))
+ else glue_set(r):=unfloat((t-width(r))/glue_stretch(r));
+@^real division@>
+ end
+else begin glue_order(r):=glue_sign(r); glue_sign(r):=shrinking;
+ if glue_shrink(r)=0 then set_glue_ratio_zero(glue_set(r))
+ else if (glue_order(r)=normal)and(width(r)-t>glue_shrink(r)) then
+ set_glue_ratio_one(glue_set(r))
+ else glue_set(r):=unfloat((width(r)-t)/glue_shrink(r));
+ end;
+width(r):=w; type(r):=hlist_node;
+end
+
+@ @<Make the unset node |r| into a |vlist_node| of height |w|...@>=
+begin width(r):=width(q);
+if t=height(r) then
+ begin glue_sign(r):=normal; glue_order(r):=normal;
+ set_glue_ratio_zero(glue_set(r));
+ end
+else if t>height(r) then
+ begin glue_sign(r):=stretching;
+ if glue_stretch(r)=0 then set_glue_ratio_zero(glue_set(r))
+ else glue_set(r):=unfloat((t-height(r))/glue_stretch(r));
+@^real division@>
+ end
+else begin glue_order(r):=glue_sign(r); glue_sign(r):=shrinking;
+ if glue_shrink(r)=0 then set_glue_ratio_zero(glue_set(r))
+ else if (glue_order(r)=normal)and(height(r)-t>glue_shrink(r)) then
+ set_glue_ratio_one(glue_set(r))
+ else glue_set(r):=unfloat((height(r)-t)/glue_shrink(r));
+ end;
+height(r):=w; type(r):=vlist_node;
+end
+
+@ We now have a completed alignment, in the list that starts at |head|
+and ends at |tail|. This list will be merged with the one that encloses
+it. (In case the enclosing mode is |mmode|, for displayed formulas,
+we will need to insert glue before and after the display; that part of the
+program will be deferred until we're more familiar with such operations.)
+
+@<Insert the \(c)current list into its environment@>=
+aux_save:=aux; p:=vlink(head); q:=tail; pop_nest;
+if mode=mmode then @<Finish an alignment in a display@>
+else begin aux:=aux_save; vlink(tail):=p;
+ if p<>null then tail:=q;
+ if mode=vmode then begin check_filter('alignment'); build_page; end;
+ end
+
+@* \[38] Breaking paragraphs into lines.
+We come now to what is probably the most interesting algorithm of \TeX:
+the mechanism for choosing the ``best possible'' breakpoints that yield
+the individual lines of a paragraph. \TeX's line-breaking algorithm takes
+a given horizontal list and converts it to a sequence of boxes that are
+appended to the current vertical list. In the course of doing this, it
+creates a special data structure containing three kinds of records that are
+not used elsewhere in \TeX. Such nodes are created while a paragraph is
+being processed, and they are destroyed afterwards; thus, the other parts
+of \TeX\ do not need to know anything about how line-breaking is done.
+
+The method used here is based on an approach devised by Michael F. Plass and
+@^Plass, Michael Frederick@>
+@^Knuth, Donald Ervin@>
+the author in 1977, subsequently generalized and improved by the same two
+people in 1980. A detailed discussion appears in {\sl SOFTWARE---Practice
+\AM\ Experience \bf11} (1981), 1119--1184, where it is shown that the
+line-breaking problem can be regarded as a special case of the problem of
+computing the shortest path in an acyclic network. The cited paper includes
+numerous examples and describes the history of line breaking as it has been
+practiced by printers through the ages. The present implementation adds two
+new ideas to the algorithm of 1980: memory space requirements are considerably
+reduced by using smaller records for inactive nodes than for active ones,
+and arithmetic overflow is avoided by using ``delta distances'' instead of
+keeping track of the total distance from the beginning of the paragraph to the
+current point.
+
+@ The |line_break| procedure should be invoked only in horizontal mode; it
+leaves that mode and places its output into the current vlist of the
+enclosing vertical mode (or internal vertical mode).
+There is one explicit parameter: |d| is true for partial paragraphs
+preceding display math mode; in this case the amount of additional
+penalty inserted before the final line is |display_widow_penalty|
+instead of |widow_penalty|.
+
+There are also a number of implicit parameters: The hlist to be broken
+starts at |vlink(head)|, and it is nonempty. The value of |prev_graf| in the
+enclosing semantic level tells where the paragraph should begin in the
+sequence of line numbers, in case hanging indentation or \.{\\parshape}
+are in use; |prev_graf| is zero unless this paragraph is being continued
+after a displayed formula. Other implicit parameters, such as the
+|par_shape_ptr| and various penalties to use for hyphenation, etc., appear
+in |eqtb|.
+
+After |line_break| has acted, it will have updated the current vlist and the
+value of |prev_graf|. Furthermore, the global variable |just_box| will
+point to the final box created by |line_break|, so that the width of this
+line can be ascertained when it is necessary to decide whether to use
+|above_display_skip| or |above_display_short_skip| before a displayed formula.
+
+@<Glob...@>=
+@!just_box:pointer; {the |hlist_node| for the last line of the new paragraph}
+@!paragraph_dir:integer; {main direction of paragraph}
+@!line_break_dir:integer; {current direction within paragraph}
+@!line_break_context:integer; {the surrounding state for |line_break| calls}
+@!break_c_htdp:quarterword; {height-depth entry in |char_info|}
+@!temp_no_whatsits:integer; {used when closing group}
+@!temp_no_dirs:integer; {used when closing group}
+@!temporary_dir:integer;
+@!dir_ptr,@!dir_tmp,@!dir_rover:pointer;
+
+@ @<Set init...@>=
+temp_no_whatsits:=0; temp_no_dirs:=0; temporary_dir:=0;
+dir_ptr:=null; dir_tmp:=null; dir_rover:=null;
+line_break_context := bottom_level;
+
+@ In it's complete form, |line_break| is a rather lengthy
+procedure---sort of a small world unto itself---we must build it up
+little by little. Below you see only te general outline.
+
+The main task performed here is to move the list from |head| to
+|temp_head| and go into the enclosing semantic level. We also append
+the \.{\\parfillskip} glue to the end of the paragraph, removing a
+space (or other glue node) if it was there, since spaces usually
+precede blank lines and instances of `\.{\$\$}'. The |par_fill_skip|
+is preceded by an infinite penalty, so it will never be considered as
+a potential breakpoint.
+
+That code assumes that a |glue_node| and a |penalty_node| occupy the
+same number of |mem|~words.
+@^data structure assumptions@>
+
+Most other processing is delegated to external functions.
+
+@p procedure line_break(@!d:boolean);
+var final_par_glue:pointer;
+start_of_par:pointer;
+begin pack_begin_line:=mode_line; {this is for over/underfull box messages}
+vlink(temp_head):=vlink(head);
+new_hyphenation(temp_head, tail);
+if (not is_char_node(vlink(head))) and ((type(vlink(head))=whatsit_node)
+ and (subtype(vlink(head))=local_par_node)) then
+ paragraph_dir:=local_par_dir(vlink(head))
+else
+ paragraph_dir:=0;
+line_break_dir:=paragraph_dir;
+tail:=new_ligkern(temp_head,tail);
+if is_char_node(tail) then new_tail_append(new_penalty(inf_penalty))
+else if type(tail)<>glue_node then new_tail_append(new_penalty(inf_penalty))
+else begin
+ type(tail):=penalty_node;
+ delete_glue_ref(glue_ptr(tail));
+ if leader_ptr(tail)<>null then
+ flush_node_list(leader_ptr(tail));
+ penalty(tail):=inf_penalty;
+ end;
+final_par_glue:=new_param_glue(par_fill_skip_code);
+couple_nodes(tail,final_par_glue);
+if not output_active then
+ lua_node_filter(pre_linebreak_filter_callback,
+ line_break_context,temp_head,addressof(tail));
+last_line_fill:=vlink(tail);
+pop_nest;
+start_of_par:=tail;
+ext_do_line_break(d,pretolerance,tracing_paragraphs,tolerance,emergency_stretch,
+ looseness,hyphen_penalty,ex_hyphen_penalty,
+ pdf_adjust_spacing, par_shape_ptr, adj_demerits,
+ pdf_protrude_chars, line_penalty, last_line_fit,
+ double_hyphen_demerits, final_hyphen_demerits,
+ hang_indent, hsize, hang_after, left_skip, right_skip,
+ pdf_each_line_height,pdf_each_line_depth,
+ pdf_first_line_height, pdf_last_line_depth,
+ inter_line_penalties_ptr, inter_line_penalty,
+ club_penalty, club_penalties_ptr,
+ display_widow_penalties_ptr,widow_penalties_ptr,
+ display_widow_penalty, widow_penalty,
+ broken_penalty, final_par_glue);
+if not output_active then
+ lua_node_filter(post_linebreak_filter_callback,
+ line_break_context,start_of_par,addressof(tail));
+pack_begin_line:=0;
+end;
+@#
+@t\4@>@<Declare \eTeX\ procedures for use by |main_control|@>
+
+@ It is possible that the user wants to interfere at some point.
+
+The choice between |check_head_filter| and |check_contrib_filter| is not
+quite clear to me yet, but it seems that the latter is the better choice.
+
+@d check_head_filter(#)==if (not output_active) and (vlink(head)<>null) then
+lua_node_filter_s(buildpage_filter_callback,#,head,addressof(tail))
+
+@d check_contrib_filter(#)==if (not output_active) and (vlink(contrib_head)<>null) then
+lua_node_filter_s(buildpage_filter_callback,#,contrib_head,addressof(garbage))
+
+@d check_filter==check_head_filter
+
+@* \[39] Breaking paragraphs into lines, continued.
+
+Hyphenation and line breaking are now all handled in C. Only the
+section heads are kept here.
+
+@* \[40] Pre-hyphenation.
+
+@* \[41] Post-hyphenation.
+
+@* \[42] Hyphenation.
+
+@ When \TeX\ has scanned `\.{\\hyphenation}', it calls on a procedure named
+|new_hyph_exceptions| to do the right thing.
+
+@p procedure new_hyph_exceptions; {enters new exceptions}
+var p:halfword; {just to catch the return value of |scan_toks|}
+begin p:=scan_toks(false,true);
+load_tex_hyphenation(language,def_ref);
+flush_list(def_ref);
+end;
+
+@ Similarly, when \TeX\ has scanned `\.{\\patterns}', it calls on a
+procedure named |new_patterns|.
+
+@p procedure new_patterns; {initializes the hyphenation pattern data}
+var p:halfword; {just to catch the return value of |scan_toks|}
+begin p:=scan_toks(false,true);
+load_tex_patterns(language,def_ref);
+flush_list(def_ref);
+end;
+
+@ `\.{\\prehyphenchar}', sets the |pre_break| character, and
+`\.{\\posthyphenchar}' the |post_break| character. Their respective
+defaults are ascii hyphen ("-") and zero (nul).
+
+@p procedure new_pre_hyphen_char;
+begin scan_optional_equals; scan_int;
+ set_pre_hyphen_char(language,cur_val);
+end;
+@#
+procedure new_post_hyphen_char;
+begin scan_optional_equals; scan_int;
+ set_post_hyphen_char(language,cur_val);
+end;
+
+@* \[43] Initializing the hyphenation tables.
+
+None of the trie-related stuff is applicable any more in luatex.
+
+@* \[44] Breaking vertical lists into pages.
+The |vsplit| procedure, which implements \TeX's \.{\\vsplit} operation,
+is considerably simpler than |line_break| because it doesn't have to
+worry about hyphenation, and because its mission is to discover a single
+break instead of an optimum sequence of breakpoints. But before we get
+into the details of |vsplit|, we need to consider a few more basic things.
+
+@ A subroutine called |prune_page_top| takes a pointer to a vlist and
+returns a pointer to a modified vlist in which all glue, kern, and penalty nodes
+have been deleted before the first box or rule node. However, the first
+box or rule is actually preceded by a newly created glue node designed so that
+the topmost baseline will be at distance |split_top_skip| from the top,
+whenever this is possible without backspacing.
+
+When the second argument |s| is |false| the deleted nodes are destroyed,
+otherwise they are collected in a list starting at |split_disc|.
+
+@d discard_or_move = 60
+@p function prune_page_top(@!p:pointer;@!s:boolean):pointer;
+var prev_p:pointer; {lags one step behind |p|}
+@!q,@!r:pointer; {temporary variables for list manipulation}
+begin prev_p:=temp_head; vlink(temp_head):=p; r:=null;
+while p<>null do
+ case type(p) of
+ hlist_node,vlist_node,rule_node:@<Insert glue for |split_top_skip|
+ and set~|p:=null|@>;
+ whatsit_node,mark_node,ins_node: begin
+ prev_p:=p; p:=vlink(prev_p);
+ end;
+ glue_node,kern_node,penalty_node: begin
+ q:=p; p:=vlink(q); vlink(q):=null;
+ vlink(prev_p):=p;
+ if s then
+ begin if split_disc=null then split_disc:=q else vlink(r):=q;
+ r:=q;
+ end
+ else flush_node_list(q);
+ end;
+ othercases confusion("pruning")
+@:this can't happen pruning}{\quad pruning@>
+ endcases;
+prune_page_top:=vlink(temp_head);
+end;
+
+@ @<Insert glue for |split_top_skip|...@>=
+begin q:=new_skip_param(split_top_skip_code); vlink(prev_p):=q; vlink(q):=p;
+ {now |temp_ptr=glue_ptr(q)|}
+if width(temp_ptr)>height(p) then width(temp_ptr):=width(temp_ptr)-height(p)
+else width(temp_ptr):=0;
+p:=null;
+end
+
+@ The next subroutine finds the best place to break a given vertical list
+so as to obtain a box of height~|h|, with maximum depth~|d|.
+A pointer to the beginning of the vertical list is given,
+and a pointer to the optimum breakpoint is returned. The list is effectively
+followed by a forced break, i.e., a penalty node with the |eject_penalty|;
+if the best break occurs at this artificial node, the value |null| is returned.
+
+@<Glob...@>=
+@!active_height:array[1..9] of scaled;
+ {distance from first active node to~|cur_p|}
+
+@ An array of six |scaled| distances is used to keep track of the height
+from the beginning of the list to the current place, just as in |line_break|.
+In fact, we use one of the same arrays, only changing its name to reflect
+its new significance.
+
+@d do_all_six(#)==#(1);#(2);#(3);#(4);#(5);#(6);#(7)
+
+@d cur_height==active_height[1] {the natural height}
+@d set_height_zero(#)==active_height[#]:=0 {initialize the height to zero}
+@#
+@d update_heights=90 {go here to record glue in the |active_height| table}
+@d awful_bad=@'7777777777 { more than a billion demerits }
+
+@p function vert_break(@!p:pointer; @!h,@!d:scaled):pointer;
+ {finds optimum page break}
+label done,not_found,update_heights;
+var prev_p:pointer; {if |p| is a glue node, |type(prev_p)| determines
+ whether |p| is a legal breakpoint}
+@!q,@!r:pointer; {glue specifications}
+@!pi:integer; {penalty value}
+@!b:integer; {badness at a trial breakpoint}
+@!least_cost:integer; {the smallest badness plus penalties found so far}
+@!best_place:pointer; {the most recent break that leads to |least_cost|}
+@!prev_dp:scaled; {depth of previous box in the list}
+@!t:small_number; {|type| of the node following a kern}
+begin prev_p:=p; {an initial glue node is not a legal breakpoint}
+least_cost:=awful_bad; do_all_six(set_height_zero); prev_dp:=0;
+best_place:=null; pi:=0;
+loop@+ begin @<If node |p| is a legal breakpoint, check if this break is
+ the best known, and |goto done| if |p| is null or
+ if the page-so-far is already too full to accept more stuff@>;
+ prev_p:=p; p:=vlink(prev_p);
+ end;
+done: vert_break:=best_place;
+end;
+
+@ A global variable |best_height_plus_depth| will be set to the natural size
+of the box that corresponds to the optimum breakpoint found by |vert_break|.
+(This value is used by the insertion-splitting algorithm of the page builder.)
+
+@<Glob...@>=
+@!best_height_plus_depth:scaled; {height of the best box, without stretching or
+ shrinking}
+
+@ A subtle point to be noted here is that the maximum depth~|d| might be
+negative, so |cur_height| and |prev_dp| might need to be corrected even
+after a glue or kern node.
+
+@<If node |p| is a legal breakpoint, check...@>=
+if p=null then pi:=eject_penalty
+else @<Use node |p| to update the current height and depth measurements;
+ if this node is not a legal breakpoint, |goto not_found|
+ or |update_heights|,
+ otherwise set |pi| to the associated penalty at the break@>;
+@<Check if node |p| is a new champion breakpoint; then \(go)|goto done|
+ if |p| is a forced break or if the page-so-far is already too full@>;
+if (type(p)<glue_node)or(type(p)>kern_node) then goto not_found;
+update_heights: @<Update the current height and depth measurements with
+ respect to a glue or kern node~|p|@>;
+not_found: if prev_dp>d then
+ begin cur_height:=cur_height+prev_dp-d;
+ prev_dp:=d;
+ end;
+
+@ @<Use node |p| to update the current height and depth measurements...@>=
+case type(p) of
+hlist_node,vlist_node,rule_node: begin@t@>@;@/
+ cur_height:=cur_height+prev_dp+height(p); prev_dp:=depth(p);
+ goto not_found;
+ end;
+whatsit_node:@<Process whatsit |p| in |vert_break| loop, |goto not_found|@>;
+glue_node: if precedes_break(prev_p) then pi:=0
+ else goto update_heights;
+kern_node: begin if vlink(p)=null then t:=penalty_node
+ else t:=type(vlink(p));
+ if t=glue_node then pi:=0@+else goto update_heights;
+ end;
+penalty_node: pi:=penalty(p);
+mark_node,ins_node: goto not_found;
+othercases confusion("vertbreak")
+@:this can't happen vertbreak}{\quad vertbreak@>
+endcases
+
+@ @d deplorable==100000 {more than |inf_bad|, but less than |awful_bad|}
+
+@<Check if node |p| is a new champion breakpoint; then \(go)...@>=
+if pi<inf_penalty then
+ begin @<Compute the badness, |b|, using |awful_bad|
+ if the box is too full@>;
+ if b<awful_bad then
+ if pi<=eject_penalty then b:=pi
+ else if b<inf_bad then b:=b+pi
+ else b:=deplorable;
+ if b<=least_cost then
+ begin best_place:=p; least_cost:=b;
+ best_height_plus_depth:=cur_height+prev_dp;
+ end;
+ if (b=awful_bad)or(pi<=eject_penalty) then goto done;
+ end
+
+@ @<Compute the badness, |b|, using |awful_bad| if the box is too full@>=
+if cur_height<h then
+ if (active_height[3]<>0) or (active_height[4]<>0) or
+ (active_height[5]<>0) or (active_height[6]<>0) then b:=0
+ else b:=badness(h-cur_height,active_height[2])
+else if cur_height-h>active_height[7] then b:=awful_bad
+else b:=badness(cur_height-h,active_height[7])
+
+@ Vertical lists that are subject to the |vert_break| procedure should not
+contain infinite shrinkability, since that would permit any amount of
+information to ``fit'' on one page.
+
+@<Update the current height and depth measurements with...@>=
+if type(p)=kern_node then q:=p
+else begin q:=glue_ptr(p);
+ active_height[2+stretch_order(q)]:=@|
+ active_height[2+stretch_order(q)]+stretch(q);@/
+ active_height[7]:=active_height[7]+shrink(q);
+ if (shrink_order(q)<>normal)and(shrink(q)<>0) then
+ begin@t@>@;@/
+ print_err("Infinite glue shrinkage found in box being split");@/
+@.Infinite glue shrinkage...@>
+ help4("The box you are \vsplitting contains some infinitely")@/
+ ("shrinkable glue, e.g., `\vss' or `\vskip 0pt minus 1fil'.")@/
+ ("Such glue doesn't belong there; but you can safely proceed,")@/
+ ("since the offensive shrinkability has been made finite.");
+ error; r:=new_spec(q); shrink_order(r):=normal; delete_glue_ref(q);
+ glue_ptr(p):=r; q:=r;
+ end;
+ end;
+cur_height:=cur_height+prev_dp+width(q); prev_dp:=0
+
+@ Now we are ready to consider |vsplit| itself. Most of
+its work is accomplished by the two subroutines that we have just considered.
+
+Given the number of a vlist box |n|, and given a desired page height |h|,
+the |vsplit| function finds the best initial segment of the vlist and
+returns a box for a page of height~|h|. The remainder of the vlist, if
+any, replaces the original box, after removing glue and penalties and
+adjusting for |split_top_skip|. Mark nodes in the split-off box are used to
+set the values of |split_first_mark| and |split_bot_mark|; we use the
+fact that |split_first_mark(x)=null| if and only if |split_bot_mark(x)=null|.
+
+The original box becomes ``void'' if and only if it has been entirely
+extracted. The extracted box is ``void'' if and only if the original
+box was void (or if it was, erroneously, an hlist box).
+
+@p function vsplit(@!n:halfword; @!h:scaled):pointer;
+ {extracts a page of height |h| from box |n|}
+label exit,done;
+var v:pointer; {the box to be split}
+vdir:integer; {the direction of the box to be split}
+p:pointer; {runs through the vlist}
+q:pointer; {points to where the break occurs}
+i:halfword; {for traversing marks lists}
+begin v:=box(n); vdir:=box_dir(v);
+flush_node_list(split_disc); split_disc:=null;
+for i:=0 to biggest_used_mark do begin
+ delete_split_first_mark(i);
+ delete_split_bot_mark(i);
+end;
+@<Dispense with trivial cases of void or bad boxes@>;
+q:=vert_break(list_ptr(v),h,split_max_depth);
+@<Look at all the marks in nodes before the break, and set the final
+ link to |null| at the break@>;
+q:=prune_page_top(q,saving_vdiscards>0);
+p:=list_ptr(v); list_ptr(v):=null; flush_node(v);
+pack_direction:=vdir;
+if q=null then box(n):=null {the |eq_level| of the box stays the same}
+else box(n):=filtered_vpackage(q,0,additional,max_depth,split_keep_group);
+vsplit:=filtered_vpackage(p,h,exactly,split_max_depth,split_off_group);
+exit: end;
+
+@ @<Dispense with trivial cases of void or bad boxes@>=
+if v=null then
+ begin vsplit:=null; return;
+ end;
+if type(v)<>vlist_node then
+ begin print_err(""); print_esc("vsplit"); print(" needs a ");
+ print_esc("vbox");
+@:vsplit_}{\.{\\vsplit needs a \\vbox}@>
+ help2("The box you are trying to split is an \hbox.")@/
+ ("I can't split such a box, so I'll leave it alone.");
+ error; vsplit:=null; return;
+ end
+
+@ It's possible that the box begins with a penalty node that is the
+``best'' break, so we must be careful to handle this special case correctly.
+
+@<Look at all the marks...@>=
+p:=list_ptr(v);
+if p=q then list_ptr(v):=null
+else loop@+begin if type(p)=mark_node then
+ if split_first_mark(mark_class(p))=null then
+ begin split_first_mark(mark_class(p)):=mark_ptr(p);
+ split_bot_mark(mark_class(p)):=split_first_mark(mark_class(p));
+ token_ref_count(split_first_mark(mark_class(p))):=@|
+ token_ref_count(split_first_mark(mark_class(p)))+2;
+ end
+ else begin delete_token_ref(split_bot_mark(mark_class(p)));
+ split_bot_mark(mark_class(p)):=mark_ptr(p);
+ add_token_ref(split_bot_mark(mark_class(p)));
+ end;
+ if vlink(p)=q then
+ begin vlink(p):=null; goto done;
+ end;
+ p:=vlink(p);
+ end;
+done:
+
+@* \[45] The page builder.
+When \TeX\ appends new material to its main vlist in vertical mode, it uses
+a method something like |vsplit| to decide where a page ends, except that
+the calculations are done ``on line'' as new items come in.
+The main complication in this process is that insertions must be put
+into their boxes and removed from the vlist, in a more-or-less optimum manner.
+
+We shall use the term ``current page'' for that part of the main vlist that
+is being considered as a candidate for being broken off and sent to the
+user's output routine. The current page starts at |vlink(page_head)|, and
+it ends at |page_tail|. We have |page_head=page_tail| if this list is empty.
+@^current page@>
+
+Utter chaos would reign if the user kept changing page specifications
+while a page is being constructed, so the page builder keeps the pertinent
+specifications frozen as soon as the page receives its first box or
+insertion. The global variable |page_contents| is |empty| when the
+current page contains only mark nodes and content-less whatsit nodes; it
+is |inserts_only| if the page contains only insertion nodes in addition to
+marks and whatsits. Glue nodes, kern nodes, and penalty nodes are
+discarded until a box or rule node appears, at which time |page_contents|
+changes to |box_there|. As soon as |page_contents| becomes non-|empty|,
+the current |vsize| and |max_depth| are squirreled away into |page_goal|
+and |page_max_depth|; the latter values will be used until the page has
+been forwarded to the user's output routine. The \.{\\topskip} adjustment
+is made when |page_contents| changes to |box_there|.
+
+Although |page_goal| starts out equal to |vsize|, it is decreased by the
+scaled natural height-plus-depth of the insertions considered so far, and by
+the \.{\\skip} corrections for those insertions. Therefore it represents
+the size into which the non-inserted material should fit, assuming that
+all insertions in the current page have been made.
+
+The global variables |best_page_break| and |least_page_cost| correspond
+respectively to the local variables |best_place| and |least_cost| in the
+|vert_break| routine that we have already studied; i.e., they record the
+location and value of the best place currently known for breaking the
+current page. The value of |page_goal| at the time of the best break is
+stored in |best_size|.
+
+@d inserts_only=1
+ {|page_contents| when an insert node has been contributed, but no boxes}
+@d box_there=2 {|page_contents| when a box or rule has been contributed}
+
+@<Glob...@>=
+@!page_tail:pointer; {the final node on the current page}
+@!page_contents:empty..box_there; {what is on the current page so far?}
+@!page_max_depth:scaled; {maximum box depth on page being built}
+@!best_page_break:pointer; {break here to get the best page known so far}
+@!least_page_cost:integer; {the score for this currently best page}
+@!best_size:scaled; {its |page_goal|}
+
+@ The page builder has another data structure to keep track of insertions.
+This is a list of four-word nodes, starting and ending at |page_ins_head|.
+That is, the first element of the list is node |r@t$_1$@>=vlink(page_ins_head)|;
+node $r_j$ is followed by |r@t$_{j+1}$@>=vlink(r@t$_j$@>)|; and if there are
+|n| items we have |r@t$_{n+1}$@>=page_ins_head|. The |subtype| field of
+each node in this list refers to an insertion number; for example, `\.{\\insert
+250}' would correspond to a node whose |subtype| is |qi(250)|
+(the same as the |subtype| field of the relevant |ins_node|). These |subtype|
+fields are in increasing order, and |subtype(page_ins_head)=
+qi(255)|, so |page_ins_head| serves as a convenient sentinel
+at the end of the list. A record is present for each insertion number that
+appears in the current page.
+
+The |type| field in these nodes distinguishes two possibilities that
+might occur as we look ahead before deciding on the optimum page break.
+If |type(r)=inserting_node|, then |height(r)| contains the total of the
+height-plus-depth dimensions of the box and all its inserts seen so far.
+If |type(r)=split_up_node|, then no more insertions will be made into this box,
+because at least one previous insertion was too big to fit on the current
+page; |broken_ptr(r)| points to the node where that insertion will be
+split, if \TeX\ decides to split it, |broken_ins(r)| points to the
+insertion node that was tentatively split, and |height(r)| includes also the
+natural height plus depth of the part that would be split off.
+
+In both cases, |last_ins_ptr(r)| points to the last |ins_node|
+encountered for box |qo(subtype(r))| that would be at least partially
+inserted on the next page; and |best_ins_ptr(r)| points to the last
+such |ins_node| that should actually be inserted, to get the page with
+minimum badness among all page breaks considered so far. We have
+|best_ins_ptr(r)=null| if and only if no insertion for this box should
+be made to produce this optimum page.
+
+The data structure definitions here use the fact that the |@!height| field
+appears in the fourth word of a box node.
+@^data structure assumptions@>
+
+@d inserting_node=37 {an insertion class that has not yet overflowed}
+@d split_up_node=38 {an overflowed insertion class}
+@d broken_ptr(#)==vlink(#+2)
+ {an insertion for this class will break here if anywhere}
+@d broken_ins(#)==vinfo(#+2) {this insertion might break at |broken_ptr|}
+@d last_ins_ptr(#)==vlink(#+3) {the most recent insertion for this |subtype|}
+@d best_ins_ptr(#)==vinfo(#+3) {the optimum most recent insertion}
+
+@<Initialize the special list heads...@>=
+subtype(page_ins_head):=qi(255);
+type(page_ins_head):=split_up_node; vlink(page_ins_head):=page_ins_head;
+
+@ An array |page_so_far| records the heights and depths of everything
+on the current page. This array contains six |scaled| numbers, like the
+similar arrays already considered in |line_break| and |vert_break|; and it
+also contains |page_goal| and |page_depth|, since these values are
+all accessible to the user via |set_page_dimen| commands. The
+value of |page_so_far[1]| is also called |page_total|. The stretch
+and shrink components of the \.{\\skip} corrections for each insertion are
+included in |page_so_far|, but the natural space components of these
+corrections are not, since they have been subtracted from |page_goal|.
+
+The variable |page_depth| records the depth of the current page; it has been
+adjusted so that it is at most |page_max_depth|. The variable
+|last_glue| points to the glue specification of the most recent node
+contributed from the contribution list, if this was a glue node; otherwise
+|last_glue=max_halfword|. (If the contribution list is nonempty,
+however, the value of |last_glue| is not necessarily accurate.)
+The variables |last_penalty|, |last_kern|, and |last_node_type|
+are similar. And
+finally, |insert_penalties| holds the sum of the penalties associated with
+all split and floating insertions.
+
+@d page_goal==page_so_far[0] {desired height of information on page being built}
+@d page_total==page_so_far[1] {height of the current page}
+@d page_shrink==page_so_far[6] {shrinkability of the current page}
+@d page_depth==page_so_far[7] {depth of the current page}
+
+@<Glob...@>=
+@!page_so_far:array [0..7] of scaled; {height and glue of the current page}
+@!last_glue:pointer; {used to implement \.{\\lastskip}}
+@!last_penalty:integer; {used to implement \.{\\lastpenalty}}
+@!last_kern:scaled; {used to implement \.{\\lastkern}}
+@!last_node_type:integer; {used to implement \.{\\lastnodetype}}
+@!insert_penalties:integer; {sum of the penalties for held-over insertions}
+
+@ @<Put each...@>=
+primitive("pagegoal",set_page_dimen,0);
+@!@:page_goal_}{\.{\\pagegoal} primitive@>
+primitive("pagetotal",set_page_dimen,1);
+@!@:page_total_}{\.{\\pagetotal} primitive@>
+primitive("pagestretch",set_page_dimen,2);
+@!@:page_stretch_}{\.{\\pagestretch} primitive@>
+primitive("pagefilstretch",set_page_dimen,3);
+@!@:page_fil_stretch_}{\.{\\pagefilstretch} primitive@>
+primitive("pagefillstretch",set_page_dimen,4);
+@!@:page_fill_stretch_}{\.{\\pagefillstretch} primitive@>
+primitive("pagefilllstretch",set_page_dimen,5);
+@!@:page_filll_stretch_}{\.{\\pagefilllstretch} primitive@>
+primitive("pageshrink",set_page_dimen,6);
+@!@:page_shrink_}{\.{\\pageshrink} primitive@>
+primitive("pagedepth",set_page_dimen,7);
+@!@:page_depth_}{\.{\\pagedepth} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+set_page_dimen: case chr_code of
+0: print_esc("pagegoal");
+1: print_esc("pagetotal");
+2: print_esc("pagestretch");
+3: print_esc("pagefilstretch");
+4: print_esc("pagefillstretch");
+5: print_esc("pagefilllstretch");
+6: print_esc("pageshrink");
+othercases print_esc("pagedepth")
+endcases;
+
+@ @d print_plus_end(#)==print(#);@+end
+@d print_plus(#)==if page_so_far[#]<>0 then
+ begin print(" plus "); print_scaled(page_so_far[#]); print_plus_end
+
+@p procedure print_totals;
+begin print_scaled(page_total);
+print_plus(2)("");
+print_plus(3)("fil");
+print_plus(4)("fill");
+print_plus(5)("filll");
+if page_shrink<>0 then
+ begin print(" minus "); print_scaled(page_shrink);
+ end;
+end;
+
+@ @<Show the status of the current page@>=
+if page_head<>page_tail then
+ begin print_nl("### current page:");
+ if output_active then print(" (held over for next output)");
+@.held over for next output@>
+ show_box(vlink(page_head));
+ if page_contents>empty then
+ begin print_nl("total height "); print_totals;
+@:total_height}{\.{total height}@>
+ print_nl(" goal height "); print_scaled(page_goal);
+@.goal height@>
+ r:=vlink(page_ins_head);
+ while r<>page_ins_head do
+ begin print_ln; print_esc("insert"); t:=qo(subtype(r));
+ print_int(t); print(" adds ");
+ t:=x_over_n(height(r),1000)*count(t); print_scaled(t);
+ if type(r)=split_up_node then
+ begin q:=page_head; t:=0;
+ repeat q:=vlink(q);
+ if (type(q)=ins_node)and(subtype(q)=subtype(r)) then incr(t);
+ until q=broken_ins(r);
+ print(", #"); print_int(t); print(" might split");
+ end;
+ r:=vlink(r);
+ end;
+ end;
+ end
+
+@ Here is a procedure that is called when the |page_contents| is changing
+from |empty| to |inserts_only| or |box_there|.
+
+@d set_page_so_far_zero(#)==page_so_far[#]:=0
+
+@p procedure freeze_page_specs(@!s:small_number);
+begin page_contents:=s;
+page_goal:=vsize; page_max_depth:=max_depth;
+page_depth:=0; do_all_six(set_page_so_far_zero);
+least_page_cost:=awful_bad;
+@!stat if tracing_pages>0 then
+ begin begin_diagnostic;
+ print_nl("%% goal height="); print_scaled(page_goal);
+@.goal height@>
+ print(", max depth="); print_scaled(page_max_depth);
+ end_diagnostic(false);
+ end;@;@+tats@;@/
+end;
+
+@ Pages are built by appending nodes to the current list in \TeX's
+vertical mode, which is at the outermost level of the semantic nest. This
+vlist is split into two parts; the ``current page'' that we have been
+talking so much about already, and the ``contribution list'' that receives
+new nodes as they are created. The current page contains everything that
+the page builder has accounted for in its data structures, as described
+above, while the contribution list contains other things that have been
+generated by other parts of \TeX\ but have not yet been
+seen by the page builder.
+The contribution list starts at |vlink(contrib_head)|, and it ends at the
+current node in \TeX's vertical mode.
+
+When \TeX\ has appended new material in vertical mode, it calls the procedure
+|build_page|, which tries to catch up by moving nodes from the contribution
+list to the current page. This procedure will succeed in its goal of
+emptying the contribution list, unless a page break is discovered, i.e.,
+unless the current page has grown to the point where the optimum next
+page break has been determined. In the latter case, the nodes after the
+optimum break will go back onto the contribution list, and control will
+effectively pass to the user's output routine.
+
+We make |type(page_head)=glue_node|, so that an initial glue node on
+the current page will not be considered a valid breakpoint.
+
+@<Initialize the special list...@>=
+type(page_head):=glue_node; subtype(page_head):=normal;
+
+@ The global variable |output_active| is true during the time the
+user's output routine is driving \TeX.
+
+@<Glob...@>=
+@!output_active:boolean; {are we in the midst of an output routine?}
+
+@ @<Set init...@>=
+output_active:=false; insert_penalties:=0;
+
+@ The page builder is ready to start a fresh page if we initialize
+the following state variables. (However, the page insertion list is initialized
+elsewhere.)
+
+@<Start a new current page@>=
+page_contents:=empty; page_tail:=page_head; vlink(page_head):=null;@/
+last_glue:=max_halfword; last_penalty:=0; last_kern:=0;
+last_node_type:=-1;
+page_depth:=0; page_max_depth:=0
+
+@ At certain times box 255 is supposed to be void (i.e., |null|),
+or an insertion box is supposed to be ready to accept a vertical list.
+If not, an error message is printed, and the following subroutine
+flushes the unwanted contents, reporting them to the user.
+
+@p procedure box_error(@!n:eight_bits);
+begin error; begin_diagnostic;
+print_nl("The following box has been deleted:");
+@.The following...deleted@>
+show_box(box(n)); end_diagnostic(true);
+flush_node_list(box(n)); box(n):=null;
+end;
+
+@ The following procedure guarantees that a given box register
+does not contain an \.{\\hbox}.
+
+@p procedure ensure_vbox(@!n:eight_bits);
+var p:pointer; {the box register contents}
+begin p:=box(n);
+if p<>null then if type(p)=hlist_node then
+ begin print_err("Insertions can only be added to a vbox");
+@.Insertions can only...@>
+ help3("Tut tut: You're trying to \insert into a")@/
+ ("\box register that now contains an \hbox.")@/
+ ("Proceed, and I'll discard its present contents.");
+ box_error(n);
+ end;
+end;
+
+@ \TeX\ is not always in vertical mode at the time |build_page|
+is called; the current mode reflects what \TeX\ should return to, after
+the contribution list has been emptied. A call on |build_page| should
+be immediately followed by `|goto big_switch|', which is \TeX's central
+control point.
+
+@d contribute=80 {go here to link a node into the current page}
+
+@p @t\4@>@<Declare the procedure called |fire_up|@>@;@/
+procedure build_page; {append contributions to the current page}
+label exit,done,done1,continue,contribute,update_heights;
+var p:pointer; {the node being appended}
+@!q,@!r:pointer; {nodes being examined}
+@!b,@!c:integer; {badness and cost of current page}
+@!pi:integer; {penalty to be added to the badness}
+@!n:min_quarterword..255; {insertion box number}
+@!delta,@!h,@!w:scaled; {sizes used for insertion calculations}
+begin pi:=0;
+if (vlink(contrib_head)=null)or output_active then return;
+repeat continue: p:=vlink(contrib_head);@/
+@<Update the values of |last_glue|, |last_penalty|, and |last_kern|@>;
+@<Move node |p| to the current page; if it is time for a page break,
+ put the nodes following the break back onto the contribution list,
+ and |return| to the user's output routine if there is one@>;
+until vlink(contrib_head)=null;
+@<Make the contribution list empty by setting its tail to |contrib_head|@>;
+exit:end;
+
+@ @d contrib_tail==nest[0].tail_field {tail of the contribution list}
+
+@<Make the contribution list empty...@>=
+if nest_ptr=0 then tail:=contrib_head {vertical mode}
+else contrib_tail:=contrib_head {other modes}
+
+@ @<Update the values of |last_glue|...@>=
+if last_glue<>max_halfword then delete_glue_ref(last_glue);
+last_penalty:=0; last_kern:=0;
+last_node_type:=type(p)+1;
+if type(p)=glue_node then
+ begin last_glue:=glue_ptr(p); add_glue_ref(last_glue);
+ end
+else begin last_glue:=max_halfword;
+ if type(p)=penalty_node then last_penalty:=penalty(p)
+ else if type(p)=kern_node then last_kern:=width(p);
+ end
+
+@ The code here is an example of a many-way switch into routines that
+merge together in different places. Some people call this unstructured
+programming, but the author doesn't see much wrong with it, as long as
+@^Knuth, Donald Ervin@>
+the various labels have a well-understood meaning.
+
+@<Move node |p| to the current page; ...@>=
+@<If the current page is empty and node |p| is to be deleted, |goto done1|;
+ otherwise use node |p| to update the state of the current page;
+ if this node is an insertion, |goto contribute|; otherwise if this node
+ is not a legal breakpoint, |goto contribute| or |update_heights|;
+ otherwise set |pi| to the penalty associated with this breakpoint@>;
+@<Check if node |p| is a new champion breakpoint; then \(if)if it is time for
+ a page break, prepare for output, and either fire up the user's
+ output routine and |return| or ship out the page and |goto done|@>;
+if (type(p)<glue_node)or(type(p)>kern_node) then goto contribute;
+update_heights:@<Update the current page measurements with respect to the
+ glue or kern specified by node~|p|@>;
+contribute: @<Make sure that |page_max_depth| is not exceeded@>;
+@<Link node |p| into the current page and |goto done|@>;
+done1:@<Recycle node |p|@>;
+done:
+
+@ @<Link node |p| into the current page and |goto done|@>=
+vlink(page_tail):=p; page_tail:=p;
+vlink(contrib_head):=vlink(p); vlink(p):=null; goto done
+
+@ @<Recycle node |p|@>=
+vlink(contrib_head):=vlink(p); vlink(p):=null;
+if saving_vdiscards>0 then
+ begin if page_disc=null then page_disc:=p@+else vlink(tail_page_disc):=p;
+ tail_page_disc:=p;
+ end
+else flush_node_list(p)
+
+@ The title of this section is already so long, it seems best to avoid
+making it more accurate but still longer, by mentioning the fact that a
+kern node at the end of the contribution list will not be contributed until
+we know its successor.
+
+@<If the current page is empty...@>=
+case type(p) of
+hlist_node,vlist_node,rule_node: if page_contents<box_there then
+ @<Initialize the current page, insert the \.{\\topskip} glue
+ ahead of |p|, and |goto continue|@>
+ else @<Prepare to move a box or rule node to the current page,
+ then |goto contribute|@>;
+whatsit_node: @<Prepare to move whatsit |p| to the current page,
+ then |goto contribute|@>;
+glue_node: if page_contents<box_there then goto done1
+ else if precedes_break(page_tail) then pi:=0
+ else goto update_heights;
+kern_node: if page_contents<box_there then goto done1
+ else if vlink(p)=null then return
+ else if type(vlink(p))=glue_node then pi:=0
+ else goto update_heights;
+penalty_node: if page_contents<box_there then goto done1@+else pi:=penalty(p);
+mark_node: goto contribute;
+ins_node: @<Append an insertion to the current page and |goto contribute|@>;
+othercases confusion("page")
+@:this can't happen page}{\quad page@>
+endcases
+
+@ @<Initialize the current page, insert the \.{\\topskip} glue...@>=
+begin if page_contents=empty then freeze_page_specs(box_there)
+else page_contents:=box_there;
+q:=new_skip_param(top_skip_code); {now |temp_ptr=glue_ptr(q)|}
+if (type(p)=hlist_node) and (is_mirrored(body_direction)) then begin
+ if width(temp_ptr)>depth(p) then width(temp_ptr):=width(temp_ptr)-depth(p)
+ else width(temp_ptr):=0;
+ end
+else begin
+ if width(temp_ptr)>height(p) then width(temp_ptr):=width(temp_ptr)-height(p)
+ else width(temp_ptr):=0;
+ end;
+vlink(q):=p; vlink(contrib_head):=q; goto continue;
+end
+
+@ @<Prepare to move a box or rule node to the current page...@>=
+begin
+if (type(p)=hlist_node) and (is_mirrored(body_direction)) then begin
+ page_total:=page_total+page_depth+depth(p);
+ page_depth:=height(p);
+ end
+else begin
+ page_total:=page_total+page_depth+height(p);
+ page_depth:=depth(p);
+ end;
+goto contribute;
+end
+
+@ @<Make sure that |page_max_depth| is not exceeded@>=
+if page_depth>page_max_depth then
+ begin page_total:=@|
+ page_total+page_depth-page_max_depth;@/
+ page_depth:=page_max_depth;
+ end;
+
+@ @<Update the current page measurements with respect to the glue...@>=
+if type(p)=kern_node then q:=p
+else begin q:=glue_ptr(p);
+if stretch_order(q)>1 then
+ page_so_far[1+stretch_order(q)]:=@|
+ page_so_far[1+stretch_order(q)]+stretch(q)@/
+else
+ page_so_far[2+stretch_order(q)]:=@|
+ page_so_far[2+stretch_order(q)]+stretch(q);@/
+ page_shrink:=page_shrink+shrink(q);
+ if (shrink_order(q)<>normal)and(shrink(q)<>0) then
+ begin@t@>@;@/
+ print_err("Infinite glue shrinkage found on current page");@/
+@.Infinite glue shrinkage...@>
+ help4("The page about to be output contains some infinitely")@/
+ ("shrinkable glue, e.g., `\vss' or `\vskip 0pt minus 1fil'.")@/
+ ("Such glue doesn't belong there; but you can safely proceed,")@/
+ ("since the offensive shrinkability has been made finite.");
+ error;
+ r:=new_spec(q); shrink_order(r):=normal; delete_glue_ref(q);
+ glue_ptr(p):=r; q:=r;
+ end;
+ end;
+page_total:=page_total+page_depth+width(q); page_depth:=0
+
+@ @<Check if node |p| is a new champion breakpoint; then \(if)...@>=
+if pi<inf_penalty then
+ begin @<Compute the badness, |b|, of the current page,
+ using |awful_bad| if the box is too full@>;
+ if b<awful_bad then
+ if pi<=eject_penalty then c:=pi
+ else if b<inf_bad then c:=b+pi+insert_penalties
+ else c:=deplorable
+ else c:=b;
+ if insert_penalties>=10000 then c:=awful_bad;
+ @!stat if tracing_pages>0 then @<Display the page break cost@>;@+tats@;@/
+ if c<=least_page_cost then
+ begin best_page_break:=p; best_size:=page_goal;
+ least_page_cost:=c;
+ r:=vlink(page_ins_head);
+ while r<>page_ins_head do
+ begin best_ins_ptr(r):=last_ins_ptr(r);
+ r:=vlink(r);
+ end;
+ end;
+ if (c=awful_bad)or(pi<=eject_penalty) then
+ begin fire_up(p); {output the current page at the best place}
+ if output_active then return; {user's output routine will act}
+ goto done; {the page has been shipped out by default output routine}
+ end;
+ end
+
+@ @<Display the page break cost@>=
+begin begin_diagnostic; print_nl("%");
+print(" t="); print_totals;@/
+print(" g="); print_scaled(page_goal);@/
+print(" b=");
+if b=awful_bad then print_char("*")@+else print_int(b);
+@.*\relax@>
+print(" p="); print_int(pi);
+print(" c=");
+if c=awful_bad then print_char("*")@+else print_int(c);
+if c<=least_page_cost then print_char("#");
+end_diagnostic(false);
+end
+
+@ @<Compute the badness, |b|, of the current page...@>=
+if page_total<page_goal then
+ if (page_so_far[3]<>0) or (page_so_far[4]<>0) or@|
+ (page_so_far[5]<>0) then b:=0
+ else b:=badness(page_goal-page_total,page_so_far[2])
+else if page_total-page_goal>page_shrink then b:=awful_bad
+else b:=badness(page_total-page_goal,page_shrink)
+
+@ @<Append an insertion to the current page and |goto contribute|@>=
+begin if page_contents=empty then freeze_page_specs(inserts_only);
+n:=subtype(p); r:=page_ins_head;
+while n>=subtype(vlink(r)) do r:=vlink(r);
+n:=qo(n);
+if subtype(r)<>qi(n) then
+ @<Create a page insertion node with |subtype(r)=qi(n)|, and
+ include the glue correction for box |n| in the
+ current page state@>;
+if type(r)=split_up_node then insert_penalties:=insert_penalties+float_cost(p)
+else begin last_ins_ptr(r):=p;
+ delta:=page_goal-page_total-page_depth+page_shrink;
+ {this much room is left if we shrink the maximum}
+ if count(n)=1000 then h:=height(p)
+ else h:=x_over_n(height(p),1000)*count(n); {this much room is needed}
+ if ((h<=0)or(h<=delta))and(height(p)+height(r)<=dimen(n)) then
+ begin page_goal:=page_goal-h; height(r):=height(r)+height(p);
+ end
+ else @<Find the best way to split the insertion, and change
+ |type(r)| to |split_up_node|@>;
+ end;
+goto contribute;
+end
+
+@ We take note of the value of \.{\\skip} |n| and the height plus depth
+of \.{\\box}~|n| only when the first \.{\\insert}~|n| node is
+encountered for a new page. A user who changes the contents of \.{\\box}~|n|
+after that first \.{\\insert}~|n| had better be either extremely careful
+or extremely lucky, or both.
+
+@<Create a page insertion node...@>=
+begin q:=new_node(inserting_node,n); vlink(q):=vlink(r); vlink(r):=q; r:=q;
+ensure_vbox(n);
+if box(n)=null then height(r):=0
+else height(r):=height(box(n))+depth(box(n));
+best_ins_ptr(r):=null;@/
+q:=skip(n);
+if count(n)=1000 then h:=height(r)
+else h:=x_over_n(height(r),1000)*count(n);
+page_goal:=page_goal-h-width(q);@/
+if stretch_order(q)>1 then
+ page_so_far[1+stretch_order(q)]:=@|page_so_far[1+stretch_order(q)]+stretch(q)@/
+else
+ page_so_far[2+stretch_order(q)]:=@|page_so_far[2+stretch_order(q)]+stretch(q);@/
+page_shrink:=page_shrink+shrink(q);
+if (shrink_order(q)<>normal)and(shrink(q)<>0) then
+ begin print_err("Infinite glue shrinkage inserted from "); print_esc("skip");
+@.Infinite glue shrinkage...@>
+ print_int(n);
+ help3("The correction glue for page breaking with insertions")@/
+ ("must have finite shrinkability. But you may proceed,")@/
+ ("since the offensive shrinkability has been made finite.");
+ error;
+ end;
+end
+
+@ Here is the code that will split a long footnote between pages, in an
+emergency. The current situation deserves to be recapitulated: Node |p|
+is an insertion into box |n|; the insertion will not fit, in its entirety,
+either because it would make the total contents of box |n| greater than
+\.{\\dimen} |n|, or because it would make the incremental amount of growth
+|h| greater than the available space |delta|, or both. (This amount |h| has
+been weighted by the insertion scaling factor, i.e., by \.{\\count} |n|
+over 1000.) Now we will choose the best way to break the vlist of the
+insertion, using the same criteria as in the \.{\\vsplit} operation.
+
+@<Find the best way to split the insertion...@>=
+begin if count(n)<=0 then w:=max_dimen
+else begin w:=page_goal-page_total-page_depth;
+ if count(n)<>1000 then w:=x_over_n(w,count(n))*1000;
+ end;
+if w>dimen(n)-height(r) then w:=dimen(n)-height(r);
+q:=vert_break(ins_ptr(p),w,depth(p));
+height(r):=height(r)+best_height_plus_depth;
+@!stat if tracing_pages>0 then @<Display the insertion split cost@>;@+tats@;@/
+if count(n)<>1000 then
+ best_height_plus_depth:=x_over_n(best_height_plus_depth,1000)*count(n);
+page_goal:=page_goal-best_height_plus_depth;
+type(r):=split_up_node; broken_ptr(r):=q; broken_ins(r):=p;
+if q=null then insert_penalties:=insert_penalties+eject_penalty
+else if type(q)=penalty_node then insert_penalties:=insert_penalties+penalty(q);
+end
+
+@ @<Display the insertion split cost@>=
+begin begin_diagnostic; print_nl("% split"); print_int(n);
+@.split@>
+print(" to "); print_scaled(w);
+print_char(","); print_scaled(best_height_plus_depth);@/
+print(" p=");
+if q=null then print_int(eject_penalty)
+else if type(q)=penalty_node then print_int(penalty(q))
+else print_char("0");
+end_diagnostic(false);
+end
+
+@ When the page builder has looked at as much material as could appear before
+the next page break, it makes its decision. The break that gave minimum
+badness will be used to put a completed ``page'' into box 255, with insertions
+appended to their other boxes.
+
+We also set the values of |top_mark|, |first_mark|, and |bot_mark|. The
+program uses the fact that |bot_mark(x)<>null| implies |first_mark(x)<>null|;
+it also knows that |bot_mark(x)=null| implies |top_mark(x)=first_mark(x)=null|.
+
+The |fire_up| subroutine prepares to output the current page at the best
+place; then it fires up the user's output routine, if there is one,
+or it simply ships out the page. There is one parameter, |c|, which represents
+the node that was being contributed to the page when the decision to
+force an output was made.
+
+@<Declare the procedure called |fire_up|@>=
+procedure fire_up(@!c:pointer);
+label exit;
+var p,@!q,@!r,@!s:pointer; {nodes being examined and/or changed}
+@!prev_p:pointer; {predecessor of |p|}
+@!n:min_quarterword..255; {insertion box number}
+@!wait:boolean; {should the present insertion be held over?}
+@!save_vbadness:integer; {saved value of |vbadness|}
+@!save_vfuzz: scaled; {saved value of |vfuzz|}
+@!save_split_top_skip: pointer; {saved value of |split_top_skip|}
+@!i: halfword; { for looping through the marks}
+begin @<Set the value of |output_penalty|@>;
+for i:=0 to biggest_used_mark do begin
+ if bot_mark(i)<>null then
+ begin if top_mark(i)<>null then delete_token_ref(top_mark(i));
+ top_mark(i):=bot_mark(i); add_token_ref(top_mark(i));
+ delete_first_mark(i);
+ end;
+ end;
+@<Put the \(o)optimal current page into box 255, update |first_mark| and
+ |bot_mark|, append insertions to their boxes, and put the
+ remaining nodes back on the contribution list@>;
+for i:=0 to biggest_used_mark do begin
+ if (top_mark(i)<>null)and(first_mark(i)=null) then
+ begin first_mark(i):=top_mark(i); add_token_ref(top_mark(i));
+ end;
+ end;
+if output_routine<>null then
+ if dead_cycles>=max_dead_cycles then
+ @<Explain that too many dead cycles have occurred in a row@>
+ else @<Fire up the user's output routine and |return|@>;
+@<Perform the default output routine@>;
+exit:end;
+
+@ @<Set the value of |output_penalty|@>=
+if type(best_page_break)=penalty_node then
+ begin geq_word_define(int_base+output_penalty_code,penalty(best_page_break));
+ penalty(best_page_break):=inf_penalty;
+ end
+else geq_word_define(int_base+output_penalty_code,inf_penalty)
+
+@ As the page is finally being prepared for output,
+pointer |p| runs through the vlist, with |prev_p| trailing behind;
+pointer |q| is the tail of a list of insertions that
+are being held over for a subsequent page.
+
+@<Put the \(o)optimal current page into box 255...@>=
+if c=best_page_break then best_page_break:=null; {|c| not yet linked in}
+@<Ensure that box 255 is empty before output@>;
+insert_penalties:=0; {this will count the number of insertions held over}
+save_split_top_skip:=split_top_skip;
+if holding_inserts<=0 then
+ @<Prepare all the boxes involved in insertions to act as queues@>;
+q:=hold_head; vlink(q):=null; prev_p:=page_head; p:=vlink(prev_p);
+while p<>best_page_break do
+ begin if type(p)=ins_node then
+ begin if holding_inserts<=0 then
+ @<Either insert the material specified by node |p| into the
+ appropriate box, or hold it for the next page;
+ also delete node |p| from the current page@>;
+ end
+ else if type(p)=mark_node then @<Update the values of
+ |first_mark| and |bot_mark|@>;
+ prev_p:=p; p:=vlink(prev_p);
+ end;
+split_top_skip:=save_split_top_skip;
+@<Break the current page at node |p|, put it in box~255,
+ and put the remaining nodes on the contribution list@>;
+@<Delete \(t)the page-insertion nodes@>
+
+@ @<Ensure that box 255 is empty before output@>=
+if box(255)<>null then
+ begin print_err(""); print_esc("box"); print("255 is not void");
+@:box255}{\.{\\box255 is not void}@>
+ help2("You shouldn't use \box255 except in \output routines.")@/
+ ("Proceed, and I'll discard its present contents.");
+ box_error(255);
+ end
+
+@ @<Update the values of |first_mark| and |bot_mark|@>=
+begin if first_mark(mark_class(p))=null then
+ begin first_mark(mark_class(p)):=mark_ptr(p);
+ add_token_ref(first_mark(mark_class(p)));
+ end;
+if bot_mark(mark_class(p))<>null then delete_token_ref(bot_mark(mark_class(p)));
+bot_mark(mark_class(p)):=mark_ptr(p); add_token_ref(bot_mark(mark_class(p)));
+end;
+
+@ When the following code is executed, the current page runs from node
+|vlink(page_head)| to node |prev_p|, and the nodes from |p| to |page_tail|
+are to be placed back at the front of the contribution list. Furthermore
+the heldover insertions appear in a list from |vlink(hold_head)| to |q|; we
+will put them into the current page list for safekeeping while the user's
+output routine is active. We might have |q=hold_head|; and |p=null| if
+and only if |prev_p=page_tail|. Error messages are suppressed within
+|vpackage|, since the box might appear to be overfull or underfull simply
+because the stretch and shrink from the \.{\\skip} registers for inserts
+are not actually present in the box.
+
+@<Break the current page at node |p|, put it...@>=
+if p<>null then
+ begin if vlink(contrib_head)=null then
+ if nest_ptr=0 then tail:=page_tail
+ else contrib_tail:=page_tail;
+ vlink(page_tail):=vlink(contrib_head);
+ vlink(contrib_head):=p;
+ vlink(prev_p):=null;
+ end;
+save_vbadness:=vbadness; vbadness:=inf_bad;
+save_vfuzz:=vfuzz; vfuzz:=max_dimen; {inhibit error messages}
+pack_direction:=body_direction;
+box(255):=filtered_vpackage(vlink(page_head),best_size,exactly,page_max_depth,output_group);
+vbadness:=save_vbadness; vfuzz:=save_vfuzz;
+if last_glue<>max_halfword then delete_glue_ref(last_glue);
+@<Start a new current page@>; {this sets |last_glue:=max_halfword|}
+if q<>hold_head then
+ begin vlink(page_head):=vlink(hold_head); page_tail:=q;
+ end
+
+@ If many insertions are supposed to go into the same box, we want to know
+the position of the last node in that box, so that we don't need to waste time
+when linking further information into it. The |last_ins_ptr| fields of the
+page insertion nodes are therefore used for this purpose during the
+packaging phase.
+
+@<Prepare all the boxes involved in insertions to act as queues@>=
+begin r:=vlink(page_ins_head);
+while r<>page_ins_head do
+ begin if best_ins_ptr(r)<>null then
+ begin n:=qo(subtype(r)); ensure_vbox(n);
+ if box(n)=null then box(n):=new_null_box;
+ p:=box(n)+list_offset;
+ while vlink(p)<>null do p:=vlink(p);
+ last_ins_ptr(r):=p;
+ end;
+ r:=vlink(r);
+ end;
+end
+
+@ @<Delete \(t)the page-insertion nodes@>=
+r:=vlink(page_ins_head);
+while r<>page_ins_head do
+ begin q:=vlink(r); flush_node(r); r:=q;
+ end;
+vlink(page_ins_head):=page_ins_head
+
+@ We will set |best_ins_ptr:=null| and package the box corresponding to
+insertion node~|r|, just after making the final insertion into that box.
+If this final insertion is `|split_up_node|', the remainder after splitting
+and pruning (if any) will be carried over to the next page.
+
+@<Either insert the material specified by node |p| into...@>=
+begin r:=vlink(page_ins_head);
+while subtype(r)<>subtype(p) do r:=vlink(r);
+if best_ins_ptr(r)=null then wait:=true
+else begin wait:=false; s:=last_ins_ptr(r); vlink(s):=ins_ptr(p);
+ if best_ins_ptr(r)=p then
+ @<Wrap up the box specified by node |r|, splitting node |p| if
+ called for; set |wait:=true| if node |p| holds a remainder after
+ splitting@>
+ else begin while vlink(s)<>null do s:=vlink(s);
+ last_ins_ptr(r):=s;
+ end;
+ end;
+@<Either append the insertion node |p| after node |q|, and remove it
+ from the current page, or delete |node(p)|@>;
+end
+
+@ @<Wrap up the box specified by node |r|, splitting node |p| if...@>=
+begin if type(r)=split_up_node then
+ if (broken_ins(r)=p)and(broken_ptr(r)<>null) then
+ begin while vlink(s)<>broken_ptr(r) do s:=vlink(s);
+ vlink(s):=null;
+ split_top_skip:=split_top_ptr(p);
+ ins_ptr(p):=prune_page_top(broken_ptr(r),false);
+ if ins_ptr(p)<>null then
+ begin temp_ptr:=vpack(ins_ptr(p),natural);
+ height(p):=height(temp_ptr)+depth(temp_ptr);
+ list_ptr(temp_ptr):=null; flush_node(temp_ptr); wait:=true;
+ end;
+ end;
+best_ins_ptr(r):=null;
+n:=qo(subtype(r));
+temp_ptr:=list_ptr(box(n));
+list_ptr(box(n)):=null; flush_node(box(n));
+pack_direction:=body_direction;
+box(n):=vpack(temp_ptr,natural);
+end
+
+@ @<Either append the insertion node |p|...@>=
+vlink(prev_p):=vlink(p); vlink(p):=null;
+if wait then
+ begin vlink(q):=p; q:=p; incr(insert_penalties);
+ end
+else begin ins_ptr(p):=null; flush_node(p);
+ end;
+p:=prev_p
+
+@ The list of heldover insertions, running from |vlink(page_head)| to
+|page_tail|, must be moved to the contribution list when the user has
+specified no output routine.
+
+@<Perform the default output routine@>=
+begin if vlink(page_head)<>null then
+ begin if vlink(contrib_head)=null then
+ if nest_ptr=0 then tail:=page_tail@+else contrib_tail:=page_tail
+ else vlink(page_tail):=vlink(contrib_head);
+ vlink(contrib_head):=vlink(page_head);
+ vlink(page_head):=null; page_tail:=page_head;
+ end;
+flush_node_list(page_disc); page_disc:=null;
+ship_out(box(255)); box(255):=null;
+end
+
+@ @<Explain that too many dead cycles have occurred in a row@>=
+begin print_err("Output loop---"); print_int(dead_cycles);
+@.Output loop...@>
+print(" consecutive dead cycles");
+help3("I've concluded that your \output is awry; it never does a")@/
+("\shipout, so I'm shipping \box255 out myself. Next time")@/
+("increase \maxdeadcycles if you want me to be more patient!"); error;
+end
+
+@ @<Fire up the user's output routine and |return|@>=
+begin output_active:=true;
+incr(dead_cycles);
+push_nest; mode:=-vmode; prev_depth:=ignore_depth; mode_line:=-line;
+begin_token_list(output_routine,output_text);
+new_save_level(output_group); normal_paragraph;
+scan_left_brace;
+return;
+end
+
+@ When the user's output routine finishes, it has constructed a vlist
+in internal vertical mode, and \TeX\ will do the following:
+
+@<Resume the page builder after an output routine has come to an end@>=
+begin if (loc<>null) or
+ ((token_type<>output_text)and(token_type<>backed_up)) then
+ @<Recover from an unbalanced output routine@>;
+end_token_list; {conserve stack space in case more outputs are triggered}
+end_graf; unsave; output_active:=false; insert_penalties:=0;@/
+@<Ensure that box 255 is empty after output@>;
+if tail<>head then {current list goes after heldover insertions}
+ begin vlink(page_tail):=vlink(head);
+ page_tail:=tail;
+ end;
+if vlink(page_head)<>null then {and both go before heldover contributions}
+ begin if vlink(contrib_head)=null then contrib_tail:=page_tail;
+ vlink(page_tail):=vlink(contrib_head);
+ vlink(contrib_head):=vlink(page_head);
+ vlink(page_head):=null; page_tail:=page_head;
+ end;
+flush_node_list(page_disc); page_disc:=null;
+pop_nest; build_page;
+end
+
+@ @<Recover from an unbalanced output routine@>=
+begin print_err("Unbalanced output routine");
+@.Unbalanced output routine@>
+help2("Your sneaky output routine has problematic {'s and/or }'s.")@/
+("I can't handle that very well; good luck."); error;
+repeat get_token;
+until loc=null;
+end {loops forever if reading from a file, since |null=min_halfword<=0|}
+
+@ @<Ensure that box 255 is empty after output@>=
+if box(255)<>null then
+ begin print_err("Output routine didn't use all of ");
+ print_esc("box"); print_int(255);
+@.Output routine didn't use...@>
+ help3("Your \output commands should empty \box255,")@/
+ ("e.g., by saying `\shipout\box255'.")@/
+ ("Proceed; I'll discard its present contents.");
+ box_error(255);
+ end
+
+@* \[46] The chief executive.
+We come now to the |main_control| routine, which contains the master
+switch that causes all the various pieces of \TeX\ to do their things,
+in the right order.
+
+In a sense, this is the grand climax of the program: It applies all the
+tools that we have worked so hard to construct. In another sense, this is
+the messiest part of the program: It necessarily refers to other pieces
+of code all over the place, so that a person can't fully understand what is
+going on without paging back and forth to be reminded of conventions that
+are defined elsewhere. We are now at the hub of the web, the central nervous
+system that touches most of the other parts and ties them together.
+@^brain@>
+
+The structure of |main_control| itself is quite simple. There's a label
+called |big_switch|, at which point the next token of input is fetched
+using |get_x_token|. Then the program branches at high speed into one of
+about 100 possible directions, based on the value of the current
+mode and the newly fetched command code; the sum |abs(mode)+cur_cmd|
+indicates what to do next. For example, the case `|vmode+letter|' arises
+when a letter occurs in vertical mode (or internal vertical mode); this
+case leads to instructions that initialize a new paragraph and enter
+horizontal mode.
+
+The big |case| statement that contains this multiway switch has been labeled
+|reswitch|, so that the program can |goto reswitch| when the next token
+has already been fetched. Most of the cases are quite short; they call
+an ``action procedure'' that does the work for that case, and then they
+either |goto reswitch| or they ``fall through'' to the end of the |case|
+statement, which returns control back to |big_switch|. Thus, |main_control|
+is not an extremely large procedure, in spite of the multiplicity of things
+it must do; it is small enough to be handled by \PASCAL\ compilers that put
+severe restrictions on procedure size.
+@!@^action procedure@>
+
+One case is singled out for special treatment, because it accounts for most
+of \TeX's activities in typical applications. The process of reading simple
+text and converting it into |char_node| records, while looking for ligatures
+and kerns, is part of \TeX's ``inner loop''; the whole program runs
+efficiently when its inner loop is fast, so this part has been written
+with particular care.
+
+@ We shall concentrate first on the inner loop of |main_control|, deferring
+consideration of the other cases until later.
+@^inner loop@>
+
+@d big_switch=60 {go here to branch on the next token of input}
+
+@p @t\4@>@<Declare action procedures for use by |main_control|@>@;
+@t\4@>@<Declare the procedure called |handle_right_brace|@>@;
+procedure main_control; {governs \TeX's activities}
+label big_switch,reswitch,continue,exit;
+var@!t,k:integer; {general-purpose temporary variables}
+p:pointer; {for whatsit nodes and testing whether an auto kern should be inserted}
+chr_stack:integer; { to temporarily save an |cur_chr| to be appended }
+begin t:=0; {for -Wall}
+chr_stack:=-1;
+if every_job<>null then begin_token_list(every_job,every_job_text);
+big_switch: get_x_token;@/
+reswitch: @<Give diagnostic information, if requested@>;
+case abs(mode)+cur_cmd of
+hmode+letter,hmode+other_char,hmode+char_given,hmode+char_num: begin
+ if abs(mode)+cur_cmd=hmode+char_num then begin
+ scan_char_num; cur_chr:=cur_val;
+ end;
+ if is_last_ocp(current_ocp_lstack,current_ocp_no) then begin
+ @<Append character |cur_chr| and the following characters (if~any)
+ to the current hlist in the current font; |goto reswitch| when
+ a non-character has been fetched@>;
+ end
+ else begin
+ @<Create a buffer with character |cur_chr| and the following
+ characters (if~any) and then apply the current active OCP filter
+ to this buffer@>;
+ end;
+ end;
+hmode+no_boundary: begin @<Append a |cancel_boundary_node| @>;
+ end;
+hmode+char_ghost: begin t:=cur_chr; get_x_token;
+ if (cur_cmd=letter)or(cur_cmd=other_char)or(cur_cmd=char_given)or
+ (cur_cmd=char_num) then begin
+ p:=new_glyph(cur_font,cur_chr);
+ if t=0 then begin set_is_leftghost(p); end
+ else begin set_is_rightghost(p); end;
+ tail_append(p);
+ end;
+ end;
+hmode+spacer,hmode+ex_space,mmode+ex_space:
+if (abs(mode)+cur_cmd=hmode+spacer) and
+ (not (space_factor = 1000)) then
+ app_space
+else begin
+ @<Append a normal inter-word space to the current list@>;
+ end;
+@t\4@>@<Cases of |main_control| that are not part of the inner loop@>@;
+end; {of the big |case| statement}
+goto big_switch;
+exit:end;
+
+@ When a new token has just been fetched at |big_switch|, we have an
+ideal place to monitor \TeX's activity.
+@^debugging@>
+
+@<Give diagnostic information, if requested@>=
+if interrupt<>0 then if OK_to_interrupt then
+ begin back_input; check_interrupt; goto big_switch;
+ end;
+if tracing_commands>0 then show_cur_cmd_chr
+
+@ The following part of the program was first written in a structured
+manner, according to the philosophy that ``premature optimization is
+the root of all evil.'' Then it was rearranged into pieces of
+spaghetti so that the most common actions could proceed with little or
+no redundancy. And finally, it is replaced by a completely standalone
+loop over the node list: luatex does not have a |main+loop| at all.
+@^inner loop@>
+
+@<Glob...@>=
+@!main_p:pointer; {temporary register for list manipulation}
+@!main_s:integer; {space factor value}
+
+@ We leave the |space_factor| unchanged if |sf_code(cur_chr)=0|; otherwise we
+set it equal to |sf_code(cur_chr)|, except that it should never change
+from a value less than 1000 to a value exceeding 1000. The most common
+case is |sf_code(cur_chr)=1000|, so we want that case to be fast.
+
+@d adjust_space_factor==@t@>@;@/
+ main_s:=get_sf_code(cur_chr);
+ if main_s=1000 then space_factor:=1000
+ else if main_s<1000 then
+ begin if main_s>0 then space_factor:=main_s;
+ end
+ else if space_factor<1000 then space_factor:=1000
+ else space_factor:=main_s
+
+@<Append character |cur_chr|...@>=
+continue: adjust_space_factor;@/
+chr_stack:=cur_chr;
+tail_append(new_char(cur_font,chr_stack));
+get_x_token;
+if (cur_cmd=letter)or(cur_cmd=other_char)or
+ (cur_cmd=char_given)or(cur_cmd=char_num) then begin
+ if cur_cmd=char_num then begin
+ scan_char_num; cur_chr:=cur_val;
+ end;
+ if (chr_stack=ex_hyphen_char)and(cur_chr<>ex_hyphen_char)and(mode>0) then begin
+ tail_append(new_disc); subtype(tail):=automatic_disc;
+ end;
+ goto continue;
+ end
+else begin
+ if (chr_stack=ex_hyphen_char) and (mode>0) then begin
+ tail_append(new_disc); subtype(tail):=automatic_disc;
+ end;
+ chr_stack:=-1;
+ goto reswitch;
+ end
+
+@ The occurrence of blank spaces is almost part of \TeX's inner loop,
+@^inner loop@>
+since we usually encounter about one space for every five non-blank characters.
+Therefore |main_control| gives second-highest priority to ordinary spaces.
+
+When a glue parameter like \.{\\spaceskip} is set to `\.{0pt}', we will
+see to it later that the corresponding glue specification is precisely
+|zero_glue|, not merely a pointer to some specification that happens
+to be full of zeroes. Therefore it is simple to test whether a glue parameter
+is zero or~not.
+
+@<Append a normal inter-word space...@>=
+if space_skip=zero_glue then
+ begin @<Find the glue specification, |main_p|, for
+ text spaces in the current font@>;
+ temp_ptr:=new_glue(main_p);
+ end
+else temp_ptr:=new_param_glue(space_skip_code);
+vlink(tail):=temp_ptr; tail:=temp_ptr
+
+
+@ From Knuth: ``Having |font_glue| allocated for each text font saves
+both time and memory.'' That may be true, but it also punches through
+the API wall for fonts, so I removed that -- Taco. But a bit of caching
+is very welcome, which is why I need to have the next two globals:
+
+@<Glob...@>=
+space_spec_font:internal_font_number;
+space_spec_cache:halfword;
+
+@ @<Set init...@>=
+space_spec_font:=0;
+space_spec_cache:=zero_glue;
+
+@ @<Find the glue specification...@>=
+begin
+if cur_font<>space_spec_font then begin
+ if space_spec_cache<>zero_glue then
+ delete_glue_ref(space_spec_cache);
+ space_spec_cache:=new_spec(zero_glue);
+ width(space_spec_cache):=space(cur_font);
+ stretch(space_spec_cache):=space_stretch(cur_font);
+ shrink(space_spec_cache):=space_shrink(cur_font);
+ space_spec_font:=cur_font;
+ end;
+main_p:=space_spec_cache;
+end
+
+@ @<Declare act...@>=
+procedure app_space; {handle spaces when |space_factor<>1000|}
+var@!q:pointer; {glue node}
+begin if (space_factor>=2000)and(xspace_skip<>zero_glue) then
+ q:=new_param_glue(xspace_skip_code)
+else begin if space_skip<>zero_glue then
+ main_p:=new_spec(space_skip)
+ else begin
+ main_p:=new_spec(zero_glue);
+ width(main_p):=space(cur_font);
+ stretch(main_p):=space_stretch(cur_font);
+ shrink(main_p):=space_shrink(cur_font);
+ end;
+ @<Modify the glue specification in |main_p| according to the space factor@>;
+ q:=new_glue(main_p); glue_ref_count(main_p):=null;
+ end;
+vlink(tail):=q; tail:=q;
+end;
+
+@ @<Modify the glue specification in |main_p| according to the space factor@>=
+if space_factor>=2000 then width(main_p):=width(main_p)+extra_space(cur_font);
+stretch(main_p):=xn_over_d(stretch(main_p),space_factor,1000);
+shrink(main_p):=xn_over_d(shrink(main_p),1000,space_factor)
+
+@ Whew---that covers the main loop. We can now proceed at a leisurely
+pace through the other combinations of possibilities.
+
+@d any_mode(#)==vmode+#,hmode+#,mmode+# {for mode-independent commands}
+
+@<Cases of |main_control| that are not part of the inner loop@>=
+any_mode(relax),vmode+spacer,mmode+spacer,mmode+no_boundary:do_nothing;
+any_mode(ignore_spaces): begin
+ if cur_chr = 0 then begin
+ @<Get the next non-blank non-call...@>;
+ goto reswitch;
+ end
+ else begin
+ t:=scanner_status;
+ scanner_status:=normal;
+ get_filtered_next;
+ scanner_status:=t;
+ cur_cs := prim_lookup(text(cur_cs));
+ if cur_cs<>undefined_primitive then begin
+ cur_cmd := get_prim_eq_type(cur_cs);
+ cur_chr := get_prim_equiv(cur_cs);
+ cur_tok := (cur_cmd*string_offset)+cur_chr;
+ goto reswitch;
+ end;
+ end;
+ end;
+vmode+stop: if its_all_over then return; {this is the only way out}
+@t\4@>@<Forbidden cases detected in |main_control|@>@+@,any_mode(mac_param):
+ report_illegal_case;
+@<Math-only cases in non-math modes, or vice versa@>: insert_dollar_sign;
+@t\4@>@<Cases of |main_control| that build boxes and lists@>@;
+@t\4@>@<Cases of |main_control| that don't depend on |mode|@>@;
+@t\4@>@<Cases of |main_control| that are for extensions to \TeX@>@;
+
+@ Here is a list of cases where the user has probably gotten into or out of math
+mode by mistake. \TeX\ will insert a dollar sign and rescan the current token.
+
+@d non_math(#)==vmode+#,hmode+#
+
+@<Math-only cases in non-math modes...@>=
+non_math(sup_mark), non_math(sub_mark), non_math(math_char_num),
+non_math(math_given), non_math(omath_given),
+non_math(math_comp), non_math(delim_num),
+non_math(left_right), non_math(above), non_math(radical),
+non_math(math_style), non_math(math_choice), non_math(vcenter),
+non_math(non_script), non_math(mkern), non_math(limit_switch),
+non_math(mskip), non_math(math_accent),
+mmode+endv, mmode+par_end, mmode+stop, mmode+vskip, mmode+un_vbox,
+mmode+valign, mmode+hrule
+
+@ @<Declare action...@>=
+procedure insert_dollar_sign;
+begin back_input; cur_tok:=math_shift_token+"$";
+print_err("Missing $ inserted");
+@.Missing \$ inserted@>
+help2("I've inserted a begin-math/end-math symbol since I think")@/
+("you left one out. Proceed, with fingers crossed."); ins_error;
+end;
+
+@ When erroneous situations arise, \TeX\ usually issues an error message
+specific to the particular error. For example, `\.{\\noalign}' should
+not appear in any mode, since it is recognized by the |align_peek| routine
+in all of its legitimate appearances; a special error message is given
+when `\.{\\noalign}' occurs elsewhere. But sometimes the most appropriate
+error message is simply that the user is not allowed to do what he or she
+has attempted. For example, `\.{\\moveleft}' is allowed only in vertical mode,
+and `\.{\\lower}' only in non-vertical modes. Such cases are enumerated
+here and in the other sections referred to under `See also \dots.'
+
+@<Forbidden cases...@>=
+vmode+vmove,hmode+hmove,mmode+hmove,any_mode(last_item),
+
+@ The `|you_cant|' procedure prints a line saying that the current command
+is illegal in the current mode; it identifies these things symbolically.
+
+@<Declare action...@>=
+procedure you_cant;
+begin print_err("You can't use `");
+@.You can't use x in y mode@>
+print_cmd_chr(cur_cmd,cur_chr);
+print("' in "); print_mode(mode);
+end;
+
+@ @<Declare act...@>=
+procedure report_illegal_case;
+begin you_cant;
+help4("Sorry, but I'm not programmed to handle this case;")@/
+("I'll just pretend that you didn't ask for it.")@/
+("If you're in the wrong mode, you might be able to")@/
+("return to the right one by typing `I}' or `I$' or `I\par'.");@/
+error;
+end;
+
+@ Some operations are allowed only in privileged modes, i.e., in cases
+that |mode>0|. The |privileged| function is used to detect violations
+of this rule; it issues an error message and returns |false| if the
+current |mode| is negative.
+
+@<Declare act...@>=
+function privileged:boolean;
+begin if mode>0 then privileged:=true
+else begin report_illegal_case; privileged:=false;
+ end;
+end;
+
+@ Either \.{\\dump} or \.{\\end} will cause |main_control| to enter the
+endgame, since both of them have `|stop|' as their command code.
+
+@<Put each...@>=
+primitive("end",stop,0);@/
+@!@:end_}{\.{\\end} primitive@>
+primitive("dump",stop,1);@/
+@!@:dump_}{\.{\\dump} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+stop:if chr_code=1 then print_esc("dump")@+else print_esc("end");
+
+@ We don't want to leave |main_control| immediately when a |stop| command
+is sensed, because it may be necessary to invoke an \.{\\output} routine
+several times before things really grind to a halt. (The output routine
+might even say `\.{\\gdef\\end\{...\}}', to prolong the life of the job.)
+Therefore |its_all_over| is |true| only when the current page
+and contribution list are empty, and when the last output was not a
+``dead cycle.''
+
+@<Declare act...@>=
+function its_all_over:boolean; {do this when \.{\\end} or \.{\\dump} occurs}
+label exit;
+begin if privileged then
+ begin if (page_head=page_tail)and(head=tail)and(dead_cycles=0) then
+ begin its_all_over:=true; return;
+ end;
+ back_input; {we will try to end again after ejecting residual material}
+ tail_append(new_null_box);
+ width(tail):=hsize;
+ tail_append(new_glue(fill_glue));
+ tail_append(new_penalty(-@'10000000000));@/
+ build_page; {append \.{\\hbox to \\hsize\{\}\\vfill\\penalty-'10000000000}}
+ end;
+its_all_over:=false;
+exit:end;
+
+@* \[47] Building boxes and lists.
+The most important parts of |main_control| are concerned with \TeX's
+chief mission of box-making. We need to control the activities that put
+entries on vlists and hlists, as well as the activities that convert
+those lists into boxes. All of the necessary machinery has already been
+developed; it remains for us to ``push the buttons'' at the right times.
+
+@ As an introduction to these routines, let's consider one of the simplest
+cases: What happens when `\.{\\hrule}' occurs in vertical mode, or
+`\.{\\vrule}' in horizontal mode or math mode? The code in |main_control|
+is short, since the |scan_rule_spec| routine already does most of what is
+required; thus, there is no need for a special action procedure.
+
+Note that baselineskip calculations are disabled after a rule in vertical
+mode, by setting |prev_depth:=ignore_depth|.
+
+@<Cases of |main_control| that build...@>=
+vmode+hrule,hmode+vrule,mmode+vrule: begin tail_append(scan_rule_spec);
+ if abs(mode)=vmode then prev_depth:=ignore_depth
+ else if abs(mode)=hmode then space_factor:=1000;
+ end;
+
+@ The processing of things like \.{\\hskip} and \.{\\vskip} is slightly
+more complicated. But the code in |main_control| is very short, since
+it simply calls on the action routine |append_glue|. Similarly, \.{\\kern}
+activates |append_kern|.
+
+@<Cases of |main_control| that build...@>=
+vmode+vskip,hmode+hskip,mmode+hskip,mmode+mskip: append_glue;
+any_mode(kern),mmode+mkern: append_kern;
+
+@ The |hskip| and |vskip| command codes are used for control sequences
+like \.{\\hss} and \.{\\vfil} as well as for \.{\\hskip} and \.{\\vskip}.
+The difference is in the value of |cur_chr|.
+
+@d fil_code=0 {identifies \.{\\hfil} and \.{\\vfil}}
+@d fill_code=1 {identifies \.{\\hfill} and \.{\\vfill}}
+@d ss_code=2 {identifies \.{\\hss} and \.{\\vss}}
+@d fil_neg_code=3 {identifies \.{\\hfilneg} and \.{\\vfilneg}}
+@d skip_code=4 {identifies \.{\\hskip} and \.{\\vskip}}
+@d mskip_code=5 {identifies \.{\\mskip}}
+
+@<Put each...@>=
+primitive("hskip",hskip,skip_code);@/
+@!@:hskip_}{\.{\\hskip} primitive@>
+primitive("hfil",hskip,fil_code);
+@!@:hfil_}{\.{\\hfil} primitive@>
+primitive("hfill",hskip,fill_code);@/
+@!@:hfill_}{\.{\\hfill} primitive@>
+primitive("hss",hskip,ss_code);
+@!@:hss_}{\.{\\hss} primitive@>
+primitive("hfilneg",hskip,fil_neg_code);@/
+@!@:hfil_neg_}{\.{\\hfilneg} primitive@>
+primitive("vskip",vskip,skip_code);@/
+@!@:vskip_}{\.{\\vskip} primitive@>
+primitive("vfil",vskip,fil_code);
+@!@:vfil_}{\.{\\vfil} primitive@>
+primitive("vfill",vskip,fill_code);@/
+@!@:vfill_}{\.{\\vfill} primitive@>
+primitive("vss",vskip,ss_code);
+@!@:vss_}{\.{\\vss} primitive@>
+primitive("vfilneg",vskip,fil_neg_code);@/
+@!@:vfil_neg_}{\.{\\vfilneg} primitive@>
+primitive("mskip",mskip,mskip_code);@/
+@!@:mskip_}{\.{\\mskip} primitive@>
+primitive("kern",kern,explicit);
+@!@:kern_}{\.{\\kern} primitive@>
+primitive("mkern",mkern,mu_glue);@/
+@!@:mkern_}{\.{\\mkern} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+hskip: case chr_code of
+ skip_code:print_esc("hskip");
+ fil_code:print_esc("hfil");
+ fill_code:print_esc("hfill");
+ ss_code:print_esc("hss");
+ othercases print_esc("hfilneg")
+ endcases;
+vskip: case chr_code of
+ skip_code:print_esc("vskip");
+ fil_code:print_esc("vfil");
+ fill_code:print_esc("vfill");
+ ss_code:print_esc("vss");
+ othercases print_esc("vfilneg")
+ endcases;
+mskip: print_esc("mskip");
+kern: print_esc("kern");
+mkern: print_esc("mkern");
+
+@ All the work relating to glue creation has been relegated to the
+following subroutine. It does not call |build_page|, because it is
+used in at least one place where that would be a mistake.
+
+@<Declare action...@>=
+procedure append_glue;
+var s:small_number; {modifier of skip command}
+begin s:=cur_chr;
+case s of
+fil_code: cur_val:=fil_glue;
+fill_code: cur_val:=fill_glue;
+ss_code: cur_val:=ss_glue;
+fil_neg_code: cur_val:=fil_neg_glue;
+skip_code: scan_glue(glue_val);
+mskip_code: scan_glue(mu_val);
+end; {now |cur_val| points to the glue specification}
+tail_append(new_glue(cur_val));
+if s>=skip_code then
+ begin decr(glue_ref_count(cur_val));
+ if s>skip_code then subtype(tail):=mu_glue;
+ end;
+end;
+
+@ @<Declare act...@>=
+procedure append_kern;
+var s:quarterword; {|subtype| of the kern node}
+begin s:=cur_chr; scan_dimen(s=mu_glue,false,false);
+tail_append(new_kern(cur_val)); subtype(tail):=s;
+end;
+
+@ Many of the actions related to box-making are triggered by the appearance
+of braces in the input. For example, when the user says `\.{\\hbox}
+\.{to} \.{100pt\{$\langle\,\hbox{hlist}\,\rangle$\}}' in vertical mode,
+the information about the box size (100pt, |exactly|) is put onto |save_stack|
+with a level boundary word just above it, and |cur_group:=adjusted_hbox_group|;
+\TeX\ enters restricted horizontal mode to process the hlist. The right
+brace eventually causes |save_stack| to be restored to its former state,
+at which time the information about the box size (100pt, |exactly|) is
+available once again; a box is packaged and we leave restricted horizontal
+mode, appending the new box to the current list of the enclosing mode
+(in this case to the current list of vertical mode), followed by any
+vertical adjustments that were removed from the box by |hpack|.
+
+The next few sections of the program are therefore concerned with the
+treatment of left and right curly braces.
+
+@ If a left brace occurs in the middle of a page or paragraph, it simply
+introduces a new level of grouping, and the matching right brace will not have
+such a drastic effect. Such grouping affects neither the mode nor the
+current list.
+
+@<Cases of |main_control| that build...@>=
+non_math(left_brace): begin
+ new_save_level(simple_group);
+ eq_word_define(int_base+no_local_whatsits_code,0);
+ eq_word_define(int_base+no_local_dirs_code,0);
+ end;
+any_mode(begin_group): begin
+ new_save_level(semi_simple_group);
+ eq_word_define(int_base+no_local_whatsits_code,0);
+ eq_word_define(int_base+no_local_dirs_code,0);
+ end;
+any_mode(end_group):
+ if cur_group=semi_simple_group then begin
+ temp_no_whatsits:=no_local_whatsits;
+ temp_no_dirs:=no_local_dirs;
+ temporary_dir:=text_direction;
+ if dir_level(text_dir_ptr)=cur_level then
+ @<DIR: Remove from |text_dir_ptr|@>;
+ unsave;
+ if abs(mode)=hmode then begin
+ if temp_no_dirs<>0 then begin
+ @<DIR: Add local dir node@>;
+ dir_dir(tail):=temporary_dir-64;
+ end;
+ if temp_no_whatsits<>0 then
+ @<LOCAL: Add local paragraph node@>;
+ end
+ end
+ else off_save;
+
+@ We have to deal with errors in which braces and such things are not
+properly nested. Sometimes the user makes an error of commission by
+inserting an extra symbol, but sometimes the user makes an error of omission.
+\TeX\ can't always tell one from the other, so it makes a guess and tries
+to avoid getting into a loop.
+
+The |off_save| routine is called when the current group code is wrong. It tries
+to insert something into the user's input that will help clean off
+the top level.
+
+@<Declare act...@>=
+procedure off_save;
+var p,q:pointer; {inserted token}
+begin if cur_group=bottom_level then
+ @<Drop current token and complain that it was unmatched@>
+else begin back_input; p:=get_avail; link(temp_token_head):=p;
+ print_err("Missing ");
+ @<Prepare to insert a token that matches |cur_group|,
+ and print what it is@>;
+ print(" inserted"); ins_list(link(temp_token_head));
+ help5("I've inserted something that you may have forgotten.")@/
+ ("(See the <inserted text> above.)")@/
+ ("With luck, this will get me unwedged. But if you")@/
+ ("really didn't forget anything, try typing `2' now; then")@/
+ ("my insertion and my current dilemma will both disappear.");
+ error;
+ end;
+end;
+
+@ At this point, |link(temp_token_head)=p|, a pointer to an empty one-word node.
+
+@<Prepare to insert a token that matches |cur_group|...@>=
+case cur_group of
+semi_simple_group: begin info(p):=cs_token_flag+frozen_end_group;
+ print_esc("endgroup");
+@.Missing \\endgroup inserted@>
+ end;
+math_shift_group: begin info(p):=math_shift_token+"$"; print_char("$");
+@.Missing \$ inserted@>
+ end;
+math_left_group: begin info(p):=cs_token_flag+frozen_right; q:=get_avail; link(p):=q;
+ p:=link(p); info(p):=other_token+"."; print_esc("right.");
+@.Missing \\right\hbox{.} inserted@>
+@^null delimiter@>
+ end;
+othercases begin info(p):=right_brace_token+"}"; print_char("}");
+@.Missing \} inserted@>
+ end
+endcases
+
+@ @<Drop current token and complain that it was unmatched@>=
+begin print_err("Extra "); print_cmd_chr(cur_cmd,cur_chr);
+@.Extra x@>
+help1("Things are pretty mixed up, but I think the worst is over.");@/
+error;
+end
+
+@ The routine for a |right_brace| character branches into many subcases,
+since a variety of things may happen, depending on |cur_group|. Some
+types of groups are not supposed to be ended by a right brace; error
+messages are given in hopes of pinpointing the problem. Most branches
+of this routine will be filled in later, when we are ready to understand
+them; meanwhile, we must prepare ourselves to deal with such errors.
+
+@<Cases of |main_control| that build...@>=
+any_mode(right_brace): handle_right_brace;
+
+@ @<Declare the procedure called |handle_right_brace|@>=
+procedure handle_right_brace;
+var p,@!q:pointer; {for short-term use}
+@!d:scaled; {holds |split_max_depth| in |insert_group|}
+@!f:integer; {holds |floating_penalty| in |insert_group|}
+begin case cur_group of
+simple_group: begin
+ temp_no_whatsits:=no_local_whatsits;
+ temp_no_dirs:=no_local_dirs;
+ temporary_dir:=text_direction;
+ if dir_level(text_dir_ptr)=cur_level then
+ @<DIR: Remove from |text_dir_ptr|@>;
+ unsave;
+ if abs(mode)=hmode then begin
+ if temp_no_dirs<>0 then begin
+ @<DIR: Add local dir node@>;
+ dir_dir(tail):=temporary_dir-64;
+ end;
+ if temp_no_whatsits<>0 then
+ @<LOCAL: Add local paragraph node@>;
+ end
+ end;
+bottom_level: begin print_err("Too many }'s");
+@.Too many \}'s@>
+ help2("You've closed more groups than you opened.")@/
+ ("Such booboos are generally harmless, so keep going."); error;
+ end;
+semi_simple_group,math_shift_group,math_left_group: extra_right_brace;
+@t\4@>@<Cases of |handle_right_brace| where a |right_brace| triggers
+ a delayed action@>@;
+othercases confusion("rightbrace")
+@:this can't happen rightbrace}{\quad rightbrace@>
+endcases;
+end;
+
+@ @<Declare act...@>=
+procedure extra_right_brace;
+begin print_err("Extra }, or forgotten ");
+@.Extra \}, or forgotten x@>
+case cur_group of
+semi_simple_group: print_esc("endgroup");
+math_shift_group: print_char("$");
+math_left_group: print_esc("right");
+end;@/
+help5("I've deleted a group-closing symbol because it seems to be")@/
+("spurious, as in `$x}$'. But perhaps the } is legitimate and")@/
+("you forgot something else, as in `\hbox{$x}'. In such cases")@/
+("the way to recover is to insert both the forgotten and the")@/
+("deleted material, e.g., by typing `I$}'."); error;
+incr(align_state);
+end;
+
+@ Here is where we clear the parameters that are supposed to revert to their
+default values after every paragraph and when internal vertical mode is entered.
+
+@<Declare act...@>=
+procedure normal_paragraph;
+begin if looseness<>0 then eq_word_define(int_base+looseness_code,0);
+if hang_indent<>0 then eq_word_define(dimen_base+hang_indent_code,0);
+if hang_after<>1 then eq_word_define(int_base+hang_after_code,1);
+if par_shape_ptr<>null then eq_define(par_shape_loc,shape_ref,null);
+if inter_line_penalties_ptr<>null then
+ eq_define(inter_line_penalties_loc,shape_ref,null);
+end;
+
+@ Now let's turn to the question of how \.{\\hbox} is treated. We actually
+need to consider also a slightly larger context, since constructions like
+`\.{\\setbox3=}\penalty0\.{\\hbox...}' and
+`\.{\\leaders}\penalty0\.{\\hbox...}' and
+`\.{\\lower3.8pt\\hbox...}'
+are supposed to invoke quite
+different actions after the box has been packaged. Conversely,
+constructions like `\.{\\setbox3=}' can be followed by a variety of
+different kinds of boxes, and we would like to encode such things in an
+efficient way.
+
+In other words, there are two problems: To represent the context of a box,
+and to represent its type.
+
+The first problem is solved by putting a ``context code'' on the |save_stack|,
+just below the two entries that give the dimensions produced by |scan_spec|.
+The context code is either a (signed) shift amount, or it is a large
+integer |>=box_flag|, where |box_flag=@t$2^{30}$@>|. Codes |box_flag| through
+|box_flag+biggest_reg| represent `\.{\\setbox0}' through
+`\.{\\setbox}|biggest_reg|'; codes |box_flag+biggest_reg+1| through
+|box_flag+2*biggest_reg| represent `\.{\\global\\setbox0}'
+through `\.{\\global\\setbox}|biggest_reg|'; code |box_flag+2*number_regs|
+represents `\.{\\shipout}'; and codes |box_flag+2*number_regs+1|
+through |box_flag+2*number_regs+3| represent `\.{\\leaders}', `\.{\\cleaders}',
+and `\.{\\xleaders}'.
+
+The second problem is solved by giving the command code |make_box| to all
+control sequences that produce a box, and by using the following |chr_code|
+values to distinguish between them: |box_code|, |copy_code|, |last_box_code|,
+|vsplit_code|, |vtop_code|, |vtop_code+vmode|, and |vtop_code+hmode|,
+where the latter two are used denote \.{\\vbox} and \.{\\hbox}, respectively.
+
+@d box_flag==@'10000000000 {context code for `\.{\\setbox0}'}
+@d global_box_flag==(box_flag+number_regs) {context code for `\.{\\global\\setbox0}'}
+@d max_global_box_flag==(global_box_flag+number_regs)
+@d ship_out_flag==(max_global_box_flag+1) {context code for `\.{\\shipout}'}
+@d leader_flag==ship_out_flag+1 {context code for `\.{\\leaders}'}
+@d box_code=0 {|chr_code| for `\.{\\box}'}
+@d copy_code=1 {|chr_code| for `\.{\\copy}'}
+@d last_box_code=2 {|chr_code| for `\.{\\lastbox}'}
+@d vsplit_code=3 {|chr_code| for `\.{\\vsplit}'}
+@d vtop_code=4 {|chr_code| for `\.{\\vtop}'}
+
+@<Put each...@>=
+primitive("moveleft",hmove,1);
+@!@:move_left_}{\.{\\moveleft} primitive@>
+primitive("moveright",hmove,0);@/
+@!@:move_right_}{\.{\\moveright} primitive@>
+primitive("raise",vmove,1);
+@!@:raise_}{\.{\\raise} primitive@>
+primitive("lower",vmove,0);
+@!@:lower_}{\.{\\lower} primitive@>
+@#
+primitive("box",make_box,box_code);
+@!@:box_}{\.{\\box} primitive@>
+primitive("copy",make_box,copy_code);
+@!@:copy_}{\.{\\copy} primitive@>
+primitive("lastbox",make_box,last_box_code);
+@!@:last_box_}{\.{\\lastbox} primitive@>
+primitive("vsplit",make_box,vsplit_code);
+@!@:vsplit_}{\.{\\vsplit} primitive@>
+primitive("vtop",make_box,vtop_code);@/
+@!@:vtop_}{\.{\\vtop} primitive@>
+primitive("vbox",make_box,vtop_code+vmode);
+@!@:vbox_}{\.{\\vbox} primitive@>
+primitive("hbox",make_box,vtop_code+hmode);@/
+@!@:hbox_}{\.{\\hbox} primitive@>
+primitive("shipout",leader_ship,a_leaders-1); {|ship_out_flag=leader_flag-1|}
+@!@:ship_out_}{\.{\\shipout} primitive@>
+primitive("leaders",leader_ship,a_leaders);
+@!@:leaders_}{\.{\\leaders} primitive@>
+primitive("cleaders",leader_ship,c_leaders);
+@!@:c_leaders_}{\.{\\cleaders} primitive@>
+primitive("xleaders",leader_ship,x_leaders);
+@!@:x_leaders_}{\.{\\xleaders} primitive@>;
+primitive("boxdir",assign_box_dir,0);
+@!@:box_dir}{\.{\\boxdir} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+hmove: if chr_code=1 then print_esc("moveleft")@+else print_esc("moveright");
+vmove: if chr_code=1 then print_esc("raise")@+else print_esc("lower");
+make_box: case chr_code of
+ box_code: print_esc("box");
+ copy_code: print_esc("copy");
+ last_box_code: print_esc("lastbox");
+ vsplit_code: print_esc("vsplit");
+ vtop_code: print_esc("vtop");
+ vtop_code+vmode: print_esc("vbox");
+ othercases print_esc("hbox")
+ endcases;
+leader_ship: if chr_code=a_leaders then print_esc("leaders")
+ else if chr_code=c_leaders then print_esc("cleaders")
+ else if chr_code=x_leaders then print_esc("xleaders")
+ else print_esc("shipout");
+
+@ Constructions that require a box are started by calling |scan_box| with
+a specified context code. The |scan_box| routine verifies
+that a |make_box| command comes next and then it calls |begin_box|.
+
+@<Cases of |main_control| that build...@>=
+vmode+hmove,hmode+vmove,mmode+vmove: begin t:=cur_chr;
+ scan_normal_dimen;
+ if t=0 then scan_box(cur_val)@+else scan_box(-cur_val);
+ end;
+any_mode(leader_ship): scan_box(leader_flag-a_leaders+cur_chr);
+any_mode(make_box): begin_box(0);
+any_mode(assign_box_dir): begin scan_register_num;
+ cur_box:=box(cur_val);
+ scan_optional_equals; scan_direction;
+ if cur_box<>null then box_dir(cur_box):=cur_val;
+ end;
+
+@ The global variable |cur_box| will point to a newly-made box. If the box
+is void, we will have |cur_box=null|. Otherwise we will have
+|type(cur_box)=hlist_node| or |vlist_node| or |rule_node|; the |rule_node|
+case can occur only with leaders.
+
+@<Glob...@>=
+@!cur_box:pointer; {box to be placed into its context}
+
+@ The |box_end| procedure does the right thing with |cur_box|, if
+|box_context| represents the context as explained above.
+
+@<Declare act...@>=
+procedure box_end(@!box_context:integer);
+var p:pointer; {|ord_noad| for new box in math mode}
+begin if box_context<box_flag then @<Append box |cur_box| to the current list,
+ shifted by |box_context|@>
+else if box_context<ship_out_flag then @<Store \(c)|cur_box| in a box register@>
+else if cur_box<>null then
+ if box_context>ship_out_flag then @<Append a new leader node that
+ uses |cur_box|@>
+ else ship_out(cur_box);
+end;
+
+@ The global variable |adjust_tail| will be non-null if and only if the
+current box might include adjustments that should be appended to the
+current vertical list.
+
+@<Append box |cur_box| to the current...@>=
+begin if cur_box<>null then
+ begin shift_amount(cur_box):=box_context;
+ if abs(mode)=vmode then
+ begin
+ if pre_adjust_tail <> null then begin
+ if pre_adjust_head <> pre_adjust_tail then
+ append_list(pre_adjust_head)(pre_adjust_tail);
+ pre_adjust_tail := null;
+ end;
+ append_to_vlist(cur_box);
+ if adjust_tail <> null then begin
+ if adjust_head <> adjust_tail then
+ append_list(adjust_head)(adjust_tail);
+ adjust_tail := null;
+ end;
+ if mode>0 then begin check_filter('box'); build_page; end;
+ end
+ else begin if abs(mode)=hmode then space_factor:=1000
+ else begin p:=new_noad;
+ math_type(nucleus(p)):=sub_box;
+ vinfo(nucleus(p)):=cur_box; cur_box:=p;
+ end;
+ vlink(tail):=cur_box; tail:=cur_box;
+ end;
+ end;
+end
+
+@ @<Store \(c)|cur_box| in a box register@>=
+if box_context<global_box_flag then
+ eq_define(box_base+box_context-box_flag,box_ref,cur_box)
+else geq_define(box_base+box_context-global_box_flag,box_ref,cur_box)
+
+@ @<Append a new leader node ...@>=
+begin @<Get the next non-blank non-relax...@>;
+if ((cur_cmd=hskip)and(abs(mode)<>vmode))or@|
+ ((cur_cmd=vskip)and(abs(mode)=vmode))or@|
+ ((cur_cmd=mskip)and(abs(mode)=mmode)) then
+ begin append_glue; subtype(tail):=box_context-(leader_flag-a_leaders);
+ leader_ptr(tail):=cur_box;
+ end
+else begin print_err("Leaders not followed by proper glue");
+@.Leaders not followed by...@>
+ help3("You should say `\leaders <box or rule><hskip or vskip>'.")@/
+ ("I found the <box or rule>, but there's no suitable")@/
+ ("<hskip or vskip>, so I'm ignoring these leaders."); back_error;
+ flush_node_list(cur_box);
+ end;
+end
+
+@ Now that we can see what eventually happens to boxes, we can consider
+the first steps in their creation. The |begin_box| routine is called when
+|box_context| is a context specification, |cur_chr| specifies the type of
+box desired, and |cur_cmd=make_box|.
+
+@<Declare act...@>=
+procedure begin_box(@!box_context:integer);
+label exit, done;
+var @!p,@!q:pointer; {run through the current list}
+@!k:halfword; {0 or |vmode| or |hmode|}
+@!n:eight_bits; {a box number}
+begin case cur_chr of
+box_code: begin scan_register_num; cur_box:=box(cur_val);
+ box(cur_val):=null; {the box becomes void, at the same level}
+ end;
+copy_code: begin scan_register_num; cur_box:=copy_node_list(box(cur_val));
+ end;
+last_box_code: @<If the current list ends with a box node, delete it from
+ the list and make |cur_box| point to it; otherwise set |cur_box:=null|@>;
+vsplit_code: @<Split off part of a vertical box, make |cur_box| point to it@>;
+othercases @<Initiate the construction of an hbox or vbox, then |return|@>
+endcases;@/
+box_end(box_context); {in simple cases, we use the box immediately}
+exit:end;
+
+@ Note that the condition |not is_char_node(tail)| implies that |head<>tail|,
+since |head| is a one-word node.
+
+@<If the current list ends with a box node, delete it...@>=
+begin cur_box:=null;
+if abs(mode)=mmode then
+ begin you_cant; help1("Sorry; this \lastbox will be void."); error;
+ end
+else if (mode=vmode)and(head=tail) then
+ begin you_cant;
+ help2("Sorry...I usually can't take things from the current page.")@/
+ ("This \lastbox will therefore be void."); error;
+ end
+else begin if not is_char_node(tail) then
+ if (type(tail)=hlist_node)or(type(tail)=vlist_node) then
+ @<Remove the last box, unless it's part of a discretionary@>;
+ end;
+end
+
+@ @<Remove the last box...@>=
+begin q:=head;
+repeat p:=q;
+if not is_char_node(q) then if type(q)=disc_node then
+ begin
+ if p=tail then goto done;
+ end;
+q:=vlink(p);
+until q=tail;
+cur_box:=tail; shift_amount(cur_box):=0;
+tail:=p; vlink(p):=null;
+done:end
+
+@ Here we deal with things like `\.{\\vsplit 13 to 100pt}'.
+
+@<Split off part of a vertical box, make |cur_box| point to it@>=
+begin scan_register_num; n:=cur_val;
+if not scan_keyword("to") then
+@.to@>
+ begin print_err("Missing `to' inserted");
+@.Missing `to' inserted@>
+ help2("I'm working on `\vsplit<box number> to <dimen>';")@/
+ ("will look for the <dimen> next."); error;
+ end;
+scan_normal_dimen;
+cur_box:=vsplit(n,cur_val);
+end
+
+@ Here is where we enter restricted horizontal mode or internal vertical
+mode, in order to make a box.
+
+@<Initiate the construction of an hbox or vbox, then |return|@>=
+begin k:=cur_chr-vtop_code; saved(0):=box_context;
+case abs(mode) of
+vmode: spec_direction:=body_direction;
+hmode: spec_direction:=text_direction;
+mmode: spec_direction:=math_direction;
+end;
+if k=hmode then
+ if (box_context<box_flag)and(abs(mode)=vmode) then
+ scan_spec(adjusted_hbox_group,true)
+ else scan_spec(hbox_group,true)
+else begin if k=vmode then scan_spec(vbox_group,true)
+ else begin scan_spec(vtop_group,true); k:=vmode;
+ end;
+ normal_paragraph;
+ end;
+push_nest; mode:=-k;
+if k=vmode then
+ begin prev_depth:=ignore_depth;
+ if every_vbox<>null then begin_token_list(every_vbox,every_vbox_text);
+ end
+else begin space_factor:=1000;
+ if every_hbox<>null then begin_token_list(every_hbox,every_hbox_text);
+ end;
+return;
+end
+
+@ @<Declare act...@>=
+procedure scan_box(@!box_context:integer);
+ {the next input should specify a box or perhaps a rule}
+begin @<Get the next non-blank non-relax...@>;
+if cur_cmd=make_box then begin_box(box_context)
+else if (box_context>=leader_flag)and((cur_cmd=hrule)or(cur_cmd=vrule)) then
+ begin cur_box:=scan_rule_spec; box_end(box_context);
+ end
+else begin@t@>@;@/
+ print_err("A <box> was supposed to be here");@/
+@.A <box> was supposed to...@>
+ help3("I was expecting to see \hbox or \vbox or \copy or \box or")@/
+ ("something like that. So you might find something missing in")@/
+ ("your output. But keep trying; you can fix this later."); back_error;
+ end;
+end;
+
+@ When the right brace occurs at the end of an \.{\\hbox} or \.{\\vbox} or
+\.{\\vtop} construction, the |package| routine comes into action. We might
+also have to finish a paragraph that hasn't ended.
+
+@<Cases of |handle...@>=
+hbox_group: package(0);
+adjusted_hbox_group: begin adjust_tail:=adjust_head;
+ pre_adjust_tail:=pre_adjust_head; package(0);
+ end;
+vbox_group: begin line_break_context:=vbox_group; end_graf; package(0);
+ end;
+vtop_group: begin line_break_context:=vtop_group; end_graf; package(vtop_code);
+ end;
+
+@ @<Declare action...@>=
+procedure package(@!c:small_number);
+var h:scaled; {height of box}
+@!p:pointer; {first node in a box}
+@!d:scaled; {max depth}
+@!grp:integer;
+begin grp:=cur_group;
+d:=box_max_depth; unsave; save_ptr:=save_ptr-6;
+pack_direction:=saved(3);
+if mode=-hmode then cur_box:=filtered_hpack(head,tail,saved(2),saved(1),grp)
+else begin cur_box:=filtered_vpackage(vlink(head),saved(2),saved(1),d,grp);
+ if c=vtop_code then @<Readjust the height and depth of |cur_box|,
+ for \.{\\vtop}@>;
+ end;
+if saved(4)<>null then
+ @<DIR: Adjust back |text_dir_ptr| for |scan_spec|@>;
+replace_attribute_list(cur_box, saved(5));
+pop_nest; box_end(saved(0));
+end;
+
+@ The height of a `\.{\\vtop}' box is inherited from the first item on its list,
+if that item is an |hlist_node|, |vlist_node|, or |rule_node|; otherwise
+the \.{\\vtop} height is zero.
+
+
+@<Readjust the height...@>=
+begin h:=0; p:=list_ptr(cur_box);
+if p<>null then if type(p)<=rule_node then h:=height(p);
+depth(cur_box):=depth(cur_box)-h+height(cur_box); height(cur_box):=h;
+end
+
+@ Here is a really small patch to add a new primitive called
+\.{\\quitvmode}. In vertical modes, it is identical to \.{\\indent},
+but in horizontal and math modes it is really a no-op (as opposed to
+\.{\\indent}, which executes the |indent_in_hmode| procedure).
+
+A paragraph begins when horizontal-mode material occurs in vertical mode,
+or when the paragraph is explicitly started by `\.{\\quitvmode}',
+`\.{\\indent}' or `\.{\\noindent}'.
+
+@<Put each...@>=
+primitive("indent",start_par,1);
+@!@:indent_}{\.{\\indent} primitive@>
+primitive("noindent",start_par,0);
+@!@:no_indent_}{\.{\\noindent} primitive@>
+primitive("quitvmode",start_par,2);
+@!@:quit_vmode_}{\.{\\quitvmode} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+start_par: if chr_code=0 then print_esc("noindent")@+ else if chr_code=1 then print_esc("indent")@+ else print_esc("quitvmode");
+
+@ @<Cases of |main_control| that build...@>=
+vmode+start_par: new_graf(cur_chr>0);
+vmode+letter,vmode+other_char,vmode+char_num,vmode+char_given,
+ vmode+char_ghost,
+ vmode+math_shift,vmode+un_hbox,vmode+vrule,
+ vmode+accent,vmode+discretionary,vmode+hskip,vmode+valign,
+ vmode+ex_space,vmode+no_boundary:@t@>@;@/
+ begin back_input; new_graf(true);
+ end;
+
+@ @<Declare act...@>=
+procedure new_graf(@!indented:boolean);
+var p,q,dir_graf_tmp:pointer;
+begin prev_graf:=0;
+if (mode=vmode)or(head<>tail) then begin
+ tail_append(new_param_glue(par_skip_code));
+ if nest_ptr=0 then
+ check_filter('begin_of_par');
+ end;
+push_nest; mode:=hmode; space_factor:=1000;
+@<LOCAL: Add local paragraph node@>;
+if indented then begin
+ p:=new_null_box; box_dir(p):=par_direction;
+ width(p):=par_indent;@+
+ tail_append(p);
+ end;
+q:=tail;
+dir_rover:=text_dir_ptr;
+while dir_rover<>null do
+ begin
+ if (vlink(dir_rover)<>null) or (dir_dir(dir_rover)<>par_direction) then
+ begin
+ dir_graf_tmp:=new_dir(dir_dir(dir_rover));
+ vlink(dir_graf_tmp):=vlink(q); vlink(q):=dir_graf_tmp;
+ end;
+ dir_rover:=vlink(dir_rover);
+ end;
+q:=head;
+while vlink(q)<>null do q:=vlink(q);
+tail:=q;
+if every_par<>null then begin_token_list(every_par,every_par_text);
+if nest_ptr=1 then begin
+ build_page; {put |par_skip| glue on current page}
+ end;
+end;
+
+@ @<Cases of |main_control| that build...@>=
+hmode+start_par,mmode+start_par: if cur_chr<>2 then indent_in_hmode;
+
+@ @<Declare act...@>=
+procedure indent_in_hmode;
+var p,@!q:pointer;
+begin if cur_chr>0 then {\.{\\indent}}
+ begin p:=new_null_box; width(p):=par_indent;
+ if abs(mode)=hmode then space_factor:=1000
+ else begin q:=new_noad; math_type(nucleus(q)):=sub_box;
+ vinfo(nucleus(q)):=p; p:=q;
+ end;
+ tail_append(p);
+ end;
+end;
+
+@ A paragraph ends when a |par_end| command is sensed, or when we are in
+horizontal mode when reaching the right brace of vertical-mode routines
+like \.{\\vbox}, \.{\\insert}, or \.{\\output}.
+
+@<Cases of |main_control| that build...@>=
+vmode+par_end: begin normal_paragraph;
+ if mode>0 then begin check_filter('vmode_par'); build_page; end;
+ end;
+hmode+par_end: begin if align_state<0 then off_save; {this tries to
+ recover from an alignment that didn't end properly}
+ if (mode>0) and (nest[(nest_ptr-1)].mode_field=vmode) then
+ line_break_context:=bottom_level;
+ end_graf; {this takes us to the enclosing mode, if |mode>0|}
+ if mode=vmode then begin check_filter('hmode_par'); build_page; end;
+ end;
+hmode+stop,hmode+vskip,hmode+hrule,hmode+un_vbox,hmode+halign: head_for_vmode;
+
+@ @<Declare act...@>=
+procedure head_for_vmode;
+begin if mode<0 then
+ if cur_cmd<>hrule then off_save
+ else begin print_err("You can't use `");
+ print_esc("hrule"); print("' here except with leaders");
+@.You can't use \\hrule...@>
+ help2("To put a horizontal rule in an hbox or an alignment,")@/
+ ("you should use \leaders or \hrulefill (see The TeXbook).");
+ error;
+ end
+else begin back_input; cur_tok:=par_token; back_input; token_type:=inserted;
+ end;
+end;
+
+@ TODO (BUG?): |dir_save| would have been set by |line_break| by means
+of |post_line_break|, but this is not done right now, as it introduces
+pretty heavy memory leaks. This means the current code is probably
+wrong in some way that relates to in-paragraph displays.
+
+@<Declare act...@>=
+procedure end_graf;
+begin if mode=hmode then
+ begin if (head=tail) or (vlink(head)=tail) then pop_nest
+ {null paragraphs are ignored, all contain a |local_paragraph| node}
+ else line_break(false);
+ if dir_save<>null then
+ begin flush_node_list(dir_save); dir_save:=null;
+ end;
+ normal_paragraph;
+ error_count:=0;
+ end;
+end;
+
+@ Insertion and adjustment and mark nodes are constructed by the following
+pieces of the program.
+
+@<Cases of |main_control| that build...@>=
+any_mode(insert),hmode+vadjust,mmode+vadjust: begin_insert_or_adjust;
+any_mode(mark): handle_mark;
+
+@ @<Forbidden...@>=
+vmode+vadjust,
+
+@ @<Declare act...@>=
+procedure begin_insert_or_adjust;
+begin if cur_cmd=vadjust then cur_val:=255
+else begin scan_register_num;
+ if cur_val=255 then
+ begin print_err("You can't "); print_esc("insert"); print_int(255);
+@.You can't \\insert255@>
+ help1("I'm changing to \insert0; box 255 is special.");
+ error; cur_val:=0;
+ end;
+ end;
+saved(0) := cur_val;
+if (cur_cmd = vadjust) and scan_keyword("pre") then
+ saved(1) := 1
+else
+ saved(1) := 0;
+save_ptr := save_ptr + 2;
+new_save_level(insert_group); scan_left_brace; normal_paragraph;
+push_nest; mode:=-vmode; prev_depth:=ignore_depth;
+end;
+
+@ @<Cases of |handle...@>=
+insert_group: begin
+ line_break_context:=insert_group;
+ end_graf; q:=split_top_skip; add_glue_ref(q);
+ d:=split_max_depth; f:=floating_penalty; unsave; save_ptr := save_ptr - 2;
+ {now |saved(0)| is the insertion number, or 255 for |vadjust|}
+ p:=vpack(vlink(head),natural); pop_nest;
+ if saved(0)<>255 then
+ begin tail_append(new_node(ins_node,saved(0)));
+ height(tail):=height(p)+depth(p); ins_ptr(tail):=list_ptr(p);
+ split_top_ptr(tail):=q; depth(tail):=d; float_cost(tail):=f;
+ end
+ else begin tail_append(new_node(adjust_node,saved(1))); {the |subtype| is used for |adjust_pre|}
+ adjust_ptr(tail):=list_ptr(p); delete_glue_ref(q);
+ end;
+ list_ptr(p):=null; flush_node(p);
+ if nest_ptr=0 then begin check_filter('insert'); build_page; end;
+ end;
+output_group: @<Resume the page builder...@>;
+
+@ I've renamed the |make_mark| procedure to this, because if the
+current chr code is 1, then the actual command was \.{\\clearmarks},
+which does not generate a mark node but instead destroys the current
+mark tokenlists.
+
+@<Declare act...@>=
+procedure handle_mark;
+var p:pointer; {new node}
+@!c:halfword; {the mark class}
+begin if cur_chr=clear_marks_code then begin
+ scan_mark_num; c:=cur_val;
+ delete_top_mark(c); delete_bot_mark(c); delete_first_mark(c);
+ delete_split_first_mark(c); delete_split_bot_mark(c);
+ end
+else begin
+if cur_chr=0 then c:=0
+else begin scan_mark_num; c:=cur_val;
+ if c > biggest_used_mark then biggest_used_mark := c;
+ end;
+p:=scan_toks(false,true);
+p:=new_node(mark_node,0); {the |subtype| is not used}
+mark_class(p):=c;
+mark_ptr(p):=def_ref; vlink(tail):=p; tail:=p;
+end;
+end;
+
+@ Penalty nodes get into a list via the |break_penalty| command.
+@^penalties@>
+
+@<Cases of |main_control| that build...@>=
+any_mode(break_penalty): append_penalty;
+
+@ @<Declare action...@>=
+procedure append_penalty;
+begin scan_int; tail_append(new_penalty(cur_val));
+if mode=vmode then begin check_filter('penalty'); build_page; end;
+end;
+
+@ The |remove_item| command removes a penalty, kern, or glue node if it
+appears at the tail of the current list, using a brute-force linear scan.
+Like \.{\\lastbox}, this command is not allowed in vertical mode (except
+internal vertical mode), since the current list in vertical mode is sent
+to the page builder. But if we happen to be able to implement it in
+vertical mode, we do.
+
+@<Cases of |main_control| that build...@>=
+any_mode(remove_item): delete_last;
+
+@ When |delete_last| is called, |cur_chr| is the |type| of node that
+will be deleted, if present.
+
+@<Declare action...@>=
+procedure delete_last;
+label exit;
+var @!p,@!q:pointer; {run through the current list}
+begin if (mode=vmode)and(tail=head) then
+ @<Apologize for inability to do the operation now,
+ unless \.{\\unskip} follows non-glue@>
+else begin if not is_char_node(tail) then if type(tail)=cur_chr then
+ begin q:=head;
+ repeat p:=q;
+ if not is_char_node(q) then if type(q)=disc_node then
+ begin
+ if p=tail then return;
+ end;
+ q:=vlink(p);
+ until q=tail;
+ vlink(p):=null; flush_node_list(tail); tail:=p;
+ end;
+ end;
+exit:end;
+
+@ @<Apologize for inability to do the operation...@>=
+begin if (cur_chr<>glue_node)or(last_glue<>max_halfword) then
+ begin you_cant;
+ help2("Sorry...I usually can't take things from the current page.")@/
+ ("Try `I\vskip-\lastskip' instead.");
+ if cur_chr=kern_node then help_line[0]:=
+ ("Try `I\kern-\lastkern' instead.")
+ else if cur_chr<>glue_node then help_line[0]:=@|
+ ("Perhaps you can make the output routine do it.");
+ error;
+ end;
+end
+
+@ @<Put each...@>=
+primitive("unpenalty",remove_item,penalty_node);@/
+@!@:un_penalty_}{\.{\\unpenalty} primitive@>
+primitive("unkern",remove_item,kern_node);@/
+@!@:un_kern_}{\.{\\unkern} primitive@>
+primitive("unskip",remove_item,glue_node);@/
+@!@:un_skip_}{\.{\\unskip} primitive@>
+primitive("unhbox",un_hbox,box_code);@/
+@!@:un_hbox_}{\.{\\unhbox} primitive@>
+primitive("unhcopy",un_hbox,copy_code);@/
+@!@:un_hcopy_}{\.{\\unhcopy} primitive@>
+primitive("unvbox",un_vbox,box_code);@/
+@!@:un_vbox_}{\.{\\unvbox} primitive@>
+primitive("unvcopy",un_vbox,copy_code);@/
+@!@:un_vcopy_}{\.{\\unvcopy} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+remove_item: if chr_code=glue_node then print_esc("unskip")
+ else if chr_code=kern_node then print_esc("unkern")
+ else print_esc("unpenalty");
+un_hbox: if chr_code=copy_code then print_esc("unhcopy")
+ else print_esc("unhbox");
+un_vbox: if chr_code=copy_code then print_esc("unvcopy")
+ @<Cases of |un_vbox| for |print_cmd_chr|@>@/
+ else print_esc("unvbox");
+
+@ The |un_hbox| and |un_vbox| commands unwrap one of the |number_regs| current boxes.
+
+@<Cases of |main_control| that build...@>=
+vmode+un_vbox,hmode+un_hbox,mmode+un_hbox: unpackage;
+
+@ @<Declare act...@>=
+procedure unpackage;
+label done, exit;
+var p:pointer; {the box}
+ r: pointer; {to remove marginal kern nodes}
+@!c:box_code..copy_code; {should we copy?}
+@!s:pointer; {for varmem assignment }
+begin if cur_chr>copy_code then @<Handle saved items and |goto done|@>;
+c:=cur_chr; scan_register_num; p:=box(cur_val);
+if p=null then return;
+if (abs(mode)=mmode)or((abs(mode)=vmode)and(type(p)<>vlist_node))or@|
+ ((abs(mode)=hmode)and(type(p)<>hlist_node)) then
+ begin print_err("Incompatible list can't be unboxed");
+@.Incompatible list...@>
+ help3("Sorry, Pandora. (You sneaky devil.)")@/
+ ("I refuse to unbox an \hbox in vertical mode or vice versa.")@/
+ ("And I can't open any boxes in math mode.");@/
+ error; return;
+ end;
+if c=copy_code then begin s:=copy_node_list(list_ptr(p)); vlink(tail):=s; end
+else begin vlink(tail):=list_ptr(p); box(cur_val):=null;
+ list_ptr(p):=null; flush_node(p);
+ end;
+done:
+while vlink(tail) <> null do begin
+ r := vlink(tail);
+ if not is_char_node(r) and (type(r) = margin_kern_node) then begin
+ vlink(tail) := vlink(r);
+ flush_node(r);
+ end;
+ tail:=vlink(tail);
+end;
+exit:end;
+
+@ @<Forbidden...@>=vmode+ital_corr,
+
+@ Italic corrections are converted to kern nodes when the |ital_corr| command
+follows a character. In math mode the same effect is achieved by appending
+a kern of zero here, since italic corrections are supplied later.
+
+@<Cases of |main_control| that build...@>=
+hmode+ital_corr: append_italic_correction;
+mmode+ital_corr: tail_append(new_kern(0));
+
+@ @<Declare act...@>=
+procedure append_italic_correction;
+label exit;
+var p:pointer; {|char_node| at the tail of the current list}
+@!f:internal_font_number; {the font in the |char_node|}
+begin if tail<>head then
+ begin if is_char_node(tail) then p:=tail
+ else return;
+ f:=font(p);
+ tail_append(new_kern(char_italic(f,character(p))));
+ subtype(tail):=explicit;
+ end;
+exit:end;
+
+@ Discretionary nodes are easy in the common case `\.{\\-}', but in the
+general case we must process three braces full of items.
+
+There are four subtypes of discretionaries, but only the first two are
+generated by primitive commands.
+
+@d discretionary_disc=0
+@d explicit_disc=1
+
+@<Put each...@>=
+primitive("-",discretionary,explicit_disc);
+@!@:Single-character primitives -}{\quad\.{\\-}@>
+primitive("discretionary",discretionary,discretionary_disc);
+@!@:discretionary_}{\.{\\discretionary} primitive@>
+primitive("localleftbox",assign_local_box,0);
+@!@:assign_local_box}{\.{\\localleftbox} primitive@>
+primitive("localrightbox",assign_local_box,1);
+@!@:assign_local_box}{\.{\\localrightbox} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+discretionary: if chr_code=explicit_disc then
+ print_esc("-")@+else print_esc("discretionary");
+assign_local_box: if chr_code=0 then print_esc("localleftbox")
+ else print_esc("localrightbox");
+
+@ @<Cases of |main_control| that build...@>=
+hmode+discretionary,mmode+discretionary: append_discretionary;
+any_mode(assign_local_box): append_local_box(cur_chr);
+
+@ The space factor does not change when we append a discretionary node,
+but it starts out as 1000 in the subsidiary lists.
+
+@<Declare act...@>=
+procedure append_local_box(kind:integer);
+begin
+incr(save_ptr); saved(-1):=kind; new_save_level(local_box_group);
+scan_left_brace; push_nest; mode:=-hmode; space_factor:=1000;
+end;
+
+procedure append_discretionary;
+var c:integer;
+begin tail_append(new_disc);
+subtype(tail):=cur_chr;
+if cur_chr=explicit_disc then begin
+ c:=get_pre_hyphen_char(cur_lang);
+ if c<>0 then begin
+ vlink(pre_break(tail)):=new_char(cur_font,c);
+ alink(vlink(pre_break(tail))):=pre_break(tail);
+ tlink(pre_break(tail)):=vlink(pre_break(tail));
+ end;
+ c:=get_post_hyphen_char(cur_lang);
+ if c<>0 then begin
+ vlink(post_break(tail)):=new_char(cur_font,c);
+ alink(vlink(post_break(tail))):=post_break(tail);
+ tlink(post_break(tail)):=vlink(post_break(tail));
+ end;
+ end
+else begin incr(save_ptr); saved(-1):=0; new_save_level(disc_group);
+ scan_left_brace; push_nest; mode:=-hmode; space_factor:=1000;
+ end;
+end;
+
+@ The three discretionary lists are constructed somewhat as if they were
+hboxes. A~subroutine called |build_discretionary| handles the transitions.
+(This is sort of fun.)
+
+@<Cases of |handle...@>=
+disc_group: build_discretionary;
+local_box_group: build_local_box;
+
+@ @<Declare act...@>=
+procedure build_local_box;
+var p:pointer;
+ kind:integer;
+begin
+unsave;
+kind:=saved(-1);
+decr(save_ptr);
+p:=vlink(head); pop_nest;
+p:=hpack(p,natural);
+if kind=0 then
+ eq_define(local_left_box_base,box_ref,p)
+else
+ eq_define(local_right_box_base,box_ref,p);
+if abs(mode)=hmode then
+ @<LOCAL: Add local paragraph node@>;
+eq_word_define(int_base+no_local_whatsits_code,no_local_whatsits+1);
+end;
+
+procedure build_discretionary;
+label done,exit;
+var p,@!q:pointer; {for link manipulation}
+@!n:integer; {length of discretionary list}
+begin unsave;
+@<Prune the current list, if necessary, until it contains only
+ |char_node|, |kern_node|, |hlist_node|, |vlist_node| and
+ |rule_node| items; set |n| to the length of the list,
+ and set |q| to the list's tail@>;
+p:=vlink(head); pop_nest;
+case saved(-1) of
+0: if (n>0) then begin
+ vlink(pre_break(tail)):=p;
+ alink(p):=pre_break(tail);
+ tlink(pre_break(tail)):=q;
+ end;
+1: if (n>0) then begin
+ vlink(post_break(tail)):=p;
+ alink(p):=post_break(tail);
+ tlink(post_break(tail)):=q;
+ end;
+2:@<Attach list |p| to the current list, and record its length;
+ then finish up and |return|@>;
+end; {there are no other cases}
+incr(saved(-1)); new_save_level(disc_group); scan_left_brace;
+push_nest; mode:=-hmode; space_factor:=1000;
+exit:end;
+
+@ @<Attach list |p| to the current...@>=
+begin if (n>0)and(abs(mode)=mmode) then
+ begin print_err("Illegal math "); print_esc("discretionary");
+@.Illegal math \\disc...@>
+ help2("Sorry: The third part of a discretionary break must be")@/
+ ("empty, in math formulas. I had to delete your third part.");
+ flush_node_list(p); error;
+ end
+else begin
+ if (n>0) then begin
+ vlink(no_break(tail)):=p;
+ alink(p):=no_break(tail);
+ tlink(no_break(tail)):=q;
+ end;
+ end;
+decr(save_ptr); return;
+end
+
+@ During this loop, |p=vlink(q)| and there are |n| items preceding |p|.
+
+@<Prune the current list, if necessary...@>=
+q:=head; p:=vlink(q); n:=0;
+while p<>null do
+ begin if not is_char_node(p) then if type(p)<>disc_node then
+ if type(p)>rule_node then if type(p)<>kern_node then
+ begin print_err("Improper discretionary list");
+@.Improper discretionary list@>
+ help1("Discretionary lists must contain only boxes and kerns.");@/
+ error;
+ begin_diagnostic;
+ print_nl("The following discretionary sublist has been deleted:");
+@.The following...deleted@>
+ show_box(p);
+ end_diagnostic(true);
+ flush_node_list(p); vlink(q):=null; goto done;
+ end;
+ q:=p; p:=vlink(q); incr(n);
+ end;
+done:
+
+@ We need only one more thing to complete the horizontal mode routines, namely
+the \.{\\accent} primitive.
+
+@<Cases of |main_control| that build...@>=
+hmode+accent: make_accent;
+
+@ The positioning of accents is straightforward but tedious. Given an accent
+of width |a|, designed for characters of height |x| and slant |s|;
+and given a character of width |w|, height |h|, and slant |t|: We will shift
+the accent down by |x-h|, and we will insert kern nodes that have the effect of
+centering the accent over the character and shifting the accent to the
+right by $\delta={1\over2}(w-a)+h\cdot t-x\cdot s$. If either character is
+absent from the font, we will simply use the other, without shifting.
+
+@<Declare act...@>=
+procedure make_accent;
+var s,@!t: real; {amount of slant}
+@!p,@!q,@!r:pointer; {character, box, and kern nodes}
+@!f:internal_font_number; {relevant font}
+@!a,@!h,@!x,@!w,@!delta:scaled; {heights and widths, as explained above}
+begin scan_char_num; f:=cur_font; p:=new_glyph(f,cur_val);
+if p<>null then
+ begin x:=x_height(f); s:=slant(f)/float_constant(65536);
+@^real division@>
+ a:=glyph_width(p);@/
+ do_assignments;@/
+ @<Create a character node |q| for the next character,
+ but set |q:=null| if problems arise@>;
+ if q<>null then @<Append the accent with appropriate kerns,
+ then set |p:=q|@>;
+ vlink(tail):=p; tail:=p; space_factor:=1000;
+ end;
+end;
+
+@ @<Create a character node |q| for the next...@>=
+q:=null; f:=cur_font;
+if (cur_cmd=letter)or(cur_cmd=other_char)or(cur_cmd=char_given) then
+ q:=new_glyph(f,cur_chr)
+else if cur_cmd=char_num then
+ begin scan_char_num; q:=new_glyph(f,cur_val);
+ end
+else back_input
+
+@ The kern nodes appended here must be distinguished from other kerns, lest
+they be wiped away by the hyphenation algorithm or by a previous line break.
+
+The two kerns are computed with (machine-dependent) |real| arithmetic, but
+their sum is machine-independent; the net effect is machine-independent,
+because the user cannot remove these nodes nor access them via \.{\\lastkern}.
+
+@<Append the accent with appropriate kerns...@>=
+begin t:=slant(f)/float_constant(65536);
+@^real division@>
+w:=glyph_width(q);
+h:=glyph_height(q);
+if h<>x then {the accent must be shifted up or down}
+ begin p:=hpack(p,natural); shift_amount(p):=x-h;
+ end;
+delta:=round((w-a)/float_constant(2)+h*t-x*s);
+@^real multiplication@>
+@^real addition@>
+r:=new_kern(delta); subtype(r):=acc_kern; vlink(tail):=r; vlink(r):=p;
+tail:=new_kern(-a-delta); subtype(tail):=acc_kern; vlink(p):=tail; p:=q;
+end
+
+@ When `\.{\\cr}' or `\.{\\span}' or a tab mark comes through the scanner
+into |main_control|, it might be that the user has foolishly inserted
+one of them into something that has nothing to do with alignment. But it is
+far more likely that a left brace or right brace has been omitted, since
+|get_next| takes actions appropriate to alignment only when `\.{\\cr}'
+or `\.{\\span}' or tab marks occur with |align_state=0|. The following
+program attempts to make an appropriate recovery.
+
+@<Cases of |main_control| that build...@>=
+any_mode(car_ret), any_mode(tab_mark): align_error;
+any_mode(no_align): no_align_error;
+any_mode(omit): omit_error;
+
+@ @<Declare act...@>=
+procedure align_error;
+begin if abs(align_state)>2 then
+ @<Express consternation over the fact that no alignment is in progress@>
+else begin back_input;
+ if align_state<0 then
+ begin print_err("Missing { inserted");
+@.Missing \{ inserted@>
+ incr(align_state); cur_tok:=left_brace_token+"{";
+ end
+ else begin print_err("Missing } inserted");
+@.Missing \} inserted@>
+ decr(align_state); cur_tok:=right_brace_token+"}";
+ end;
+ help3("I've put in what seems to be necessary to fix")@/
+ ("the current column of the current alignment.")@/
+ ("Try to go on, since this might almost work."); ins_error;
+ end;
+end;
+
+@ @<Express consternation...@>=
+begin print_err("Misplaced "); print_cmd_chr(cur_cmd,cur_chr);
+@.Misplaced \&@>
+@.Misplaced \\span@>
+@.Misplaced \\cr@>
+if cur_tok=tab_token+"&" then
+ begin help6("I can't figure out why you would want to use a tab mark")@/
+ ("here. If you just want an ampersand, the remedy is")@/
+ ("simple: Just type `I\&' now. But if some right brace")@/
+ ("up above has ended a previous alignment prematurely,")@/
+ ("you're probably due for more error messages, and you")@/
+ ("might try typing `S' now just to see what is salvageable.");
+ end
+else begin help5("I can't figure out why you would want to use a tab mark")@/
+ ("or \cr or \span just now. If something like a right brace")@/
+ ("up above has ended a previous alignment prematurely,")@/
+ ("you're probably due for more error messages, and you")@/
+ ("might try typing `S' now just to see what is salvageable.");
+ end;
+error;
+end
+
+@ The help messages here contain a little white lie, since \.{\\noalign}
+and \.{\\omit} are allowed also after `\.{\\noalign\{...\}}'.
+
+@<Declare act...@>=
+procedure no_align_error;
+begin print_err("Misplaced "); print_esc("noalign");
+@.Misplaced \\noalign@>
+help2("I expect to see \noalign only after the \cr of")@/
+ ("an alignment. Proceed, and I'll ignore this case."); error;
+end;
+procedure omit_error;
+begin print_err("Misplaced "); print_esc("omit");
+@.Misplaced \\omit@>
+help2("I expect to see \omit only after tab marks or the \cr of")@/
+ ("an alignment. Proceed, and I'll ignore this case."); error;
+end;
+
+@ We've now covered most of the abuses of \.{\\halign} and \.{\\valign}.
+Let's take a look at what happens when they are used correctly.
+
+@<Cases of |main_control| that build...@>=
+vmode+halign,hmode+valign:init_align;
+mmode+halign: if privileged then
+ if cur_group=math_shift_group then init_align
+ else off_save;
+vmode+endv,hmode+endv: do_endv;
+
+@ An |align_group| code is supposed to remain on the |save_stack|
+during an entire alignment, until |fin_align| removes it.
+
+A devious user might force an |endv| command to occur just about anywhere;
+we must defeat such hacks.
+
+@<Declare act...@>=
+procedure do_endv;
+begin base_ptr:=input_ptr; input_stack[base_ptr]:=cur_input;
+while (input_stack[base_ptr].index_field<>v_template) and
+ (input_stack[base_ptr].loc_field=null) and
+ (input_stack[base_ptr].state_field=token_list) do decr(base_ptr);
+if (input_stack[base_ptr].index_field<>v_template) or
+ (input_stack[base_ptr].loc_field<>null) or
+ (input_stack[base_ptr].state_field<>token_list) then
+ fatal_error("(interwoven alignment preambles are not allowed)");
+@.interwoven alignment preambles...@>
+ if cur_group=align_group then
+ begin line_break_context:=align_group; end_graf;
+ if fin_col then fin_row;
+ end
+else off_save;
+end;
+
+@ @<Cases of |handle_right_brace|...@>=
+align_group: begin back_input; cur_tok:=cs_token_flag+frozen_cr;
+ print_err("Missing "); print_esc("cr"); print(" inserted");
+@.Missing \\cr inserted@>
+ help1("I'm guessing that you meant to end an alignment here.");
+ ins_error;
+ end;
+
+@ @<Cases of |handle_right_brace|...@>=
+no_align_group: begin line_break_context:=no_align_group; end_graf; unsave; align_peek;
+ end;
+
+@ Finally, \.{\\endcsname} is not supposed to get through to |main_control|.
+
+@<Cases of |main_control| that build...@>=
+any_mode(end_cs_name): cs_error;
+
+@ @<Declare act...@>=
+procedure cs_error;
+begin print_err("Extra "); print_esc("endcsname");
+@.Extra \\endcsname@>
+help1("I'm ignoring this, since I wasn't doing a \csname.");
+error;
+end;
+
+@* \[48] Building math lists.
+The routines that \TeX\ uses to create mlists are similar to those we have
+just seen for the generation of hlists and vlists. But it is necessary to
+make ``noads'' as well as nodes, so the reader should review the
+discussion of math mode data structures before trying to make sense out of
+the following program.
+
+Here is a little routine that needs to be done whenever a subformula
+is about to be processed. The parameter is a code like |math_group|.
+
+@<Declare act...@>=
+procedure push_math(@!c:group_code);
+begin
+if math_direction<>text_direction then dir_math_save:=true;
+push_nest; mode:=-mmode; incompleat_noad:=null;
+@<DIR: |new_save_level| math@>;
+end;
+
+@ We get into math mode from horizontal mode when a `\.\$' (i.e., a
+|math_shift| character) is scanned. We must check to see whether this
+`\.\$' is immediately followed by another, in case display math mode is
+called for.
+
+@<Cases of |main_control| that build...@>=
+hmode+math_shift:init_math;
+
+@ @<Declare act...@>=
+procedure init_math;
+label found,not_found,done;
+var w:scaled; {new or partial |pre_display_size|}
+@!l:scaled; {new |display_width|}
+@!s:scaled; {new |display_indent|}
+@!p:pointer; {current node when calculating |pre_display_size|}
+@!q:pointer; {glue specification when calculating |pre_display_size|}
+@!f:internal_font_number; {font in current |char_node|}
+@!n:integer; {scope of paragraph shape specification}
+@!v:scaled; {|w| plus possible glue amount}
+@!d:scaled; {increment to |v|}
+begin get_token; {|get_x_token| would fail on \.{\\ifmmode}\thinspace!}
+if (cur_cmd=math_shift)and(mode>0) then @<Go into display math mode@>
+else begin back_input; @<Go into ordinary math mode@>;
+ end;
+end;
+
+@ @<Go into ordinary math mode@>=
+begin push_math(math_shift_group); eq_word_define(int_base+cur_fam_code,-1);
+if every_math<>null then begin_token_list(every_math,every_math_text);
+end
+
+@ We get into ordinary math mode from display math mode when `\.{\\eqno}' or
+`\.{\\leqno}' appears. In such cases |cur_chr| will be 0 or~1, respectively;
+the value of |cur_chr| is placed onto |save_stack| for safe keeping.
+
+@<Cases of |main_control| that build...@>=
+mmode+eq_no: if privileged then
+ if cur_group=math_shift_group then start_eq_no
+ else off_save;
+
+@ @<Put each...@>=
+primitive("eqno",eq_no,0);
+@!@:eq_no_}{\.{\\eqno} primitive@>
+primitive("leqno",eq_no,1);
+@!@:leq_no_}{\.{\\leqno} primitive@>
+
+@ When \TeX\ is in display math mode, |cur_group=math_shift_group|,
+so it is not necessary for the |start_eq_no| procedure to test for
+this condition.
+
+@<Declare act...@>=
+procedure start_eq_no;
+begin saved(0):=cur_chr; incr(save_ptr);
+@<Go into ordinary math mode@>;
+end;
+
+@ @<Cases of |print_cmd_chr|...@>=
+eq_no:if chr_code=1 then print_esc("leqno")@+else print_esc("eqno");
+
+@ @<Forbidden...@>=non_math(eq_no),
+
+@ When we enter display math mode, we need to call |line_break| to
+process the partial paragraph that has just been interrupted by the
+display. Then we can set the proper values of |display_width| and
+|display_indent| and |pre_display_size|.
+
+@<Go into display math mode@>=
+begin if head=tail then {`\.{\\noindent\$\$}' or `\.{\$\${ }\$\$}'}
+ begin pop_nest; w:=-max_dimen;
+ end
+else begin
+ line_break(true);@/
+ @<Calculate the natural width, |w|, by which the characters of the
+ final line extend to the right of the reference point,
+ plus two ems; or set |w:=max_dimen| if the non-blank information
+ on that line is affected by stretching or shrinking@>;
+ end;
+{now we are in vertical mode, working on the list that will contain the display}
+@<Calculate the length, |l|, and the shift amount, |s|, of the display lines@>;
+push_math(math_shift_group); mode:=mmode;
+eq_word_define(int_base+cur_fam_code,-1);@/
+eq_word_define(dimen_base+pre_display_size_code,w);
+eq_word_define(dimen_base+display_width_code,l);
+eq_word_define(dimen_base+display_indent_code,s);
+if every_display<>null then begin_token_list(every_display,every_display_text);
+if nest_ptr=1 then begin check_contrib_filter('before_display'); build_page; end;
+end
+
+@ @<Calculate the natural width, |w|, by which...@>=
+v:=shift_amount(just_box)+2*quad(cur_font); w:=-max_dimen;
+p:=list_ptr(just_box);
+while p<>null do
+ begin @<Let |d| be the natural width of node |p|;
+ if the node is ``visible,'' |goto found|;
+ if the node is glue that stretches or shrinks, set |v:=max_dimen|@>;
+ if v<max_dimen then v:=v+d;
+ goto not_found;
+ found: if v<max_dimen then
+ begin v:=v+d; w:=v;
+ end
+ else begin w:=max_dimen; goto done;
+ end;
+ not_found: p:=vlink(p);
+ end;
+done:
+
+@ @<Let |d| be the natural width of node |p|...@>=
+if is_char_node(p) then
+ begin f:=font(p); d:=glyph_width(p);
+ goto found;
+ end;
+case type(p) of
+hlist_node,vlist_node,rule_node: begin d:=width(p); goto found;
+ end;
+margin_kern_node: d:=width(p);
+kern_node: d:=width(p);
+math_node: d:=surround(p);
+glue_node:@<Let |d| be the natural width of this glue; if stretching
+ or shrinking, set |v:=max_dimen|; |goto found| in the case of leaders@>;
+whatsit_node: @<Let |d| be the width of the whatsit |p|@>;
+othercases d:=0
+endcases
+
+@ We need to be careful that |w|, |v|, and |d| do not depend on any |glue_set|
+values, since such values are subject to system-dependent rounding.
+System-dependent numbers are not allowed to infiltrate parameters like
+|pre_display_size|, since \TeX82 is supposed to make the same decisions on all
+machines.
+
+@<Let |d| be the natural width of this glue...@>=
+begin q:=glue_ptr(p); d:=width(q);
+if glue_sign(just_box)=stretching then
+ begin if (glue_order(just_box)=stretch_order(q))and@|
+ (stretch(q)<>0) then
+ v:=max_dimen;
+ end
+else if glue_sign(just_box)=shrinking then
+ begin if (glue_order(just_box)=shrink_order(q))and@|
+ (shrink(q)<>0) then
+ v:=max_dimen;
+ end;
+if subtype(p)>=a_leaders then goto found;
+end
+
+@ A displayed equation is considered to be three lines long, so we
+calculate the length and offset of line number |prev_graf+2|.
+
+@<Calculate the length, |l|, ...@>=
+if par_shape_ptr=null then
+ if (hang_indent<>0)and@|
+ (((hang_after>=0)and(prev_graf+2>hang_after))or@|
+ (prev_graf+1<-hang_after)) then
+ begin l:=hsize-abs(hang_indent);
+ if hang_indent>0 then s:=hang_indent@+else s:=0;
+ end
+ else begin l:=hsize; s:=0;
+ end
+else begin n:=vinfo(par_shape_ptr);
+ if prev_graf+2>=n then p:=par_shape_ptr+2*n
+ else p:=par_shape_ptr+2*(prev_graf+2);
+ s:=vmem(p-1).sc; l:=vmem(p).sc;
+ end
+
+@ Subformulas of math formulas cause a new level of math mode to be entered,
+on the semantic nest as well as the save stack. These subformulas arise in
+several ways: (1)~A left brace by itself indicates the beginning of a
+subformula that will be put into a box, thereby freezing its glue and
+preventing line breaks. (2)~A subscript or superscript is treated as a
+subformula if it is not a single character; the same applies to
+the nucleus of things like \.{\\underline}. (3)~The \.{\\left} primitive
+initiates a subformula that will be terminated by a matching \.{\\right}.
+The group codes placed on |save_stack| in these three cases are
+|math_group|, |math_group|, and |math_left_group|, respectively.
+
+Here is the code that handles case (1); the other cases are not quite as
+trivial, so we shall consider them later.
+
+@<Cases of |main_control| that build...@>=
+mmode+left_brace: begin tail_append(new_noad);
+ back_input; scan_math(nucleus(tail));
+ end;
+
+@ Recall that the |nucleus|, |subscr|, and |supscr| fields in a noad are
+broken down into subfields called |math_type| and either |info| or
+|(fam,character)|. The job of |scan_math| is to figure out what to place
+in one of these principal fields; it looks at the subformula that
+comes next in the input, and places an encoding of that subformula
+into a given word of |mem|.
+
+@d fam_in_range==((cur_fam>=0)and(cur_fam<256))
+
+@<Declare act...@>=
+@t\4@>@<Declare the function called |fin_mlist|@>@t@>@;@/
+
+procedure scan_math(@!p:pointer);
+label restart,reswitch,exit;
+var c:integer; {math character code}
+begin restart:@<Get the next non-blank non-relax...@>;
+reswitch:case cur_cmd of
+letter,other_char,char_given: begin c:=get_math_code(cur_chr);
+ if c=@"8000000 then
+ begin @<Treat |cur_chr| as an active character@>;
+ goto restart;
+ end;
+ end;
+char_num: begin scan_char_num; cur_chr:=cur_val; cur_cmd:=char_given;
+ goto reswitch;
+ end;
+math_char_num: begin
+ if cur_chr=0 then scan_fifteen_bit_int
+ else scan_big_fifteen_bit_int;
+ c:=cur_val;
+ end;
+math_given: begin
+ c := ((cur_chr div @"1000) * @"1000000) +
+ (((cur_chr mod @"1000) div @"100) * @"10000) +
+ (cur_chr mod @"100);
+ end;
+omath_given: begin c:=cur_chr;
+ end;
+delim_num: begin
+ if cur_chr=0 then scan_twenty_seven_bit_int
+ else scan_fifty_one_bit_int;
+ c:=cur_val;
+ end;
+othercases @<Scan a subformula enclosed in braces and |return|@>
+endcases;@/
+math_type(p):=math_char; mcharacter(p):=qi(c mod @"10000);
+if (c>=var_code)and fam_in_range then fam(p):=cur_fam
+else fam(p):=(c div @"10000) mod @"100;
+exit:end;
+
+@ An active character that is an |outer_call| is allowed here.
+
+@<Treat |cur_chr|...@>=
+begin cur_cs:=(cur_chr mod number_active_chars)+active_base;
+cur_cmd:=eq_type(cur_cs); cur_chr:=equiv(cur_cs);
+x_token; back_input;
+end
+
+@ The pointer |p| is placed on |save_stack| while a complex subformula
+is being scanned.
+
+@<Scan a subformula...@>=
+begin back_input; scan_left_brace;@/
+saved(0):=p; incr(save_ptr); push_math(math_group); return;
+end
+
+@ The simplest math formula is, of course, `\.{\${ }\$}', when no noads are
+generated. The next simplest cases involve a single character, e.g.,
+`\.{\$x\$}'. Even though such cases may not seem to be very interesting,
+the reader can perhaps understand how happy the author was when `\.{\$x\$}'
+was first properly typeset by \TeX. The code in this section was used.
+@^Knuth, Donald Ervin@>
+
+@<Cases of |main_control| that build...@>=
+mmode+letter,mmode+other_char,mmode+char_given:
+ set_math_char(get_math_code(cur_chr));
+mmode+char_num: begin scan_char_num; cur_chr:=cur_val;
+ set_math_char(get_math_code(cur_chr));
+ end;
+mmode+math_char_num: begin
+ if cur_chr=0 then scan_fifteen_bit_int
+ else scan_big_fifteen_bit_int;
+ set_math_char(cur_val);
+ end;
+mmode+math_given: begin
+ set_math_char(((cur_chr div @"1000) * @"1000000) +
+ (((cur_chr mod @"1000) div @"100) * @"10000) +
+ (cur_chr mod @"100));
+ end;
+mmode+omath_given: set_math_char(cur_chr);
+mmode+delim_num: begin
+ if cur_chr=0 then scan_twenty_seven_bit_int
+ else scan_fifty_one_bit_int;
+ set_math_char(cur_val);
+ end;
+
+@ The |set_math_char| procedure creates a new noad appropriate to a given
+math code, and appends it to the current mlist. However, if the math code
+is sufficiently large, the |cur_chr| is treated as an active character and
+nothing is appended.
+
+@<Declare act...@>=
+procedure set_math_char(@!c:integer);
+var p:pointer; {the new noad}
+begin if c>=@"8000000 then
+ @<Treat |cur_chr|...@>
+else begin p:=new_noad; math_type(nucleus(p)):=math_char;
+ mcharacter(nucleus(p)):=qi(c mod @"10000);
+ fam(nucleus(p)):=(c div @"10000) mod @"100;
+ if c>=var_code then
+ begin if fam_in_range then fam(nucleus(p)):=cur_fam;
+ type(p):=ord_noad;
+ end
+ else
+ type(p):=ord_noad+(c div @"1000000);
+ vlink(tail):=p; tail:=p;
+ end;
+end;
+
+@ Primitive math operators like \.{\\mathop} and \.{\\underline} are given
+the command code |math_comp|, supplemented by the noad type that they
+generate.
+
+@<Put each...@>=
+primitive("mathord",math_comp,ord_noad);
+@!@:math_ord_}{\.{\\mathord} primitive@>
+primitive("mathop",math_comp,op_noad);
+@!@:math_op_}{\.{\\mathop} primitive@>
+primitive("mathbin",math_comp,bin_noad);
+@!@:math_bin_}{\.{\\mathbin} primitive@>
+primitive("mathrel",math_comp,rel_noad);
+@!@:math_rel_}{\.{\\mathrel} primitive@>
+primitive("mathopen",math_comp,open_noad);
+@!@:math_open_}{\.{\\mathopen} primitive@>
+primitive("mathclose",math_comp,close_noad);
+@!@:math_close_}{\.{\\mathclose} primitive@>
+primitive("mathpunct",math_comp,punct_noad);
+@!@:math_punct_}{\.{\\mathpunct} primitive@>
+primitive("mathinner",math_comp,inner_noad);
+@!@:math_inner_}{\.{\\mathinner} primitive@>
+primitive("underline",math_comp,under_noad);
+@!@:underline_}{\.{\\underline} primitive@>
+primitive("overline",math_comp,over_noad);@/
+@!@:overline_}{\.{\\overline} primitive@>
+primitive("displaylimits",limit_switch,normal);
+@!@:display_limits_}{\.{\\displaylimits} primitive@>
+primitive("limits",limit_switch,limits);
+@!@:limits_}{\.{\\limits} primitive@>
+primitive("nolimits",limit_switch,no_limits);
+@!@:no_limits_}{\.{\\nolimits} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+math_comp: case chr_code of
+ ord_noad: print_esc("mathord");
+ op_noad: print_esc("mathop");
+ bin_noad: print_esc("mathbin");
+ rel_noad: print_esc("mathrel");
+ open_noad: print_esc("mathopen");
+ close_noad: print_esc("mathclose");
+ punct_noad: print_esc("mathpunct");
+ inner_noad: print_esc("mathinner");
+ under_noad: print_esc("underline");
+ othercases print_esc("overline")
+ endcases;
+limit_switch: if chr_code=limits then print_esc("limits")
+ else if chr_code=no_limits then print_esc("nolimits")
+ else print_esc("displaylimits");
+
+@ @<Cases of |main_control| that build...@>=
+mmode+math_comp: begin tail_append(new_noad);
+ type(tail):=cur_chr; scan_math(nucleus(tail));
+ end;
+mmode+limit_switch: math_limit_switch;
+
+@ @<Declare act...@>=
+procedure math_limit_switch;
+label exit;
+begin if head<>tail then if type(tail)=op_noad then
+ begin subtype(tail):=cur_chr; return;
+ end;
+print_err("Limit controls must follow a math operator");
+@.Limit controls must follow...@>
+help1("I'm ignoring this misplaced \limits or \nolimits command."); error;
+exit:end;
+
+@ Delimiter fields of noads are filled in by the |scan_delimiter| routine.
+The first parameter of this procedure is the |mem| address where the
+delimiter is to be placed; the second tells if this delimiter follows
+\.{\\radical} or not.
+
+@<Declare act...@>=
+procedure scan_delimiter(@!p:pointer;@!r:integer);
+begin if r=1 then scan_twenty_seven_bit_int
+else if r=2 then scan_fifty_one_bit_int
+else begin @<Get the next non-blank non-relax...@>;
+ case cur_cmd of
+ letter,other_char: begin
+ cur_val:=get_del_code_a(cur_chr); cur_val1:=get_del_code_b(cur_chr);
+ end;
+ delim_num: if cur_chr=0 then scan_twenty_seven_bit_int
+ else scan_fifty_one_bit_int;
+ othercases begin cur_val:=-1; cur_val1:=-1; end;
+ endcases;
+ end;
+if cur_val<0 then begin @<Report that an invalid delimiter code is being changed
+ to null; set~|cur_val:=0|@>;
+ cur_val1:=0;
+ end;
+small_fam(p):=(cur_val div @"10000) mod @"100;
+small_char(p):=qi(cur_val mod @"10000);
+large_fam(p):=(cur_val1 div @"10000) mod @"100;
+large_char(p):=qi(cur_val1 mod @"10000);
+end;
+
+@ @<Report that an invalid delimiter...@>=
+begin print_err("Missing delimiter (. inserted)");
+@.Missing delimiter...@>
+help6("I was expecting to see something like `(' or `\{' or")@/
+ ("`\}' here. If you typed, e.g., `{' instead of `\{', you")@/
+ ("should probably delete the `{' by typing `1' now, so that")@/
+ ("braces don't get unbalanced. Otherwise just proceed.")@/
+ ("Acceptable delimiters are characters whose \delcode is")@/
+ ("nonnegative, or you can use `\delimiter <delimiter code>'.");
+back_error; cur_val:=0;
+end
+
+@ @<Cases of |main_control| that build...@>=
+mmode+radical:math_radical;
+
+@ @<Declare act...@>=
+procedure math_radical;
+begin tail_append(new_node(radical_noad,normal));
+vmem(nucleus(tail)).hh:=empty_field;
+vmem(subscr(tail)).hh:=empty_field;
+vmem(supscr(tail)).hh:=empty_field;
+scan_delimiter(left_delimiter(tail),cur_chr+1);
+scan_math(nucleus(tail));
+end;
+
+@ @<Cases of |main_control| that build...@>=
+mmode+accent,mmode+math_accent:math_ac;
+
+@ @<Declare act...@>=
+procedure math_ac;
+begin if cur_cmd=accent then
+ @<Complain that the user should have said \.{\\mathaccent}@>;
+tail_append(new_node(accent_noad,normal));
+vmem(nucleus(tail)).hh:=empty_field;
+vmem(subscr(tail)).hh:=empty_field;
+vmem(supscr(tail)).hh:=empty_field;
+math_type(accent_chr(tail)):=math_char;
+if cur_chr=0 then scan_fifteen_bit_int
+else scan_big_fifteen_bit_int;
+mcharacter(accent_chr(tail)):=qi(cur_val mod @"1000);
+if (cur_val>=var_code)and fam_in_range then fam(accent_chr(tail)):=cur_fam
+else fam(accent_chr(tail)):=(cur_val div @"10000) mod @"100;
+scan_math(nucleus(tail));
+end;
+
+@ @<Complain that the user should have said \.{\\mathaccent}@>=
+begin print_err("Please use "); print_esc("mathaccent");
+print(" for accents in math mode");
+@.Please use \\mathaccent...@>
+help2("I'm changing \accent to \mathaccent here; wish me luck.")@/
+ ("(Accents are not the same in formulas as they are in text.)");
+error;
+end
+
+@ @<Cases of |main_control| that build...@>=
+mmode+vcenter: begin scan_spec(vcenter_group,false); normal_paragraph;
+ push_nest; mode:=-vmode; prev_depth:=ignore_depth;
+ if every_vbox<>null then begin_token_list(every_vbox,every_vbox_text);
+ end;
+
+@ @<Cases of |handle...@>=
+vcenter_group: begin line_break_context:=vcenter_group; end_graf; unsave; save_ptr:=save_ptr-2;
+ p:=vpack(vlink(head),saved(1),saved(0)); pop_nest;
+ tail_append(new_noad); type(tail):=vcenter_noad;
+ math_type(nucleus(tail)):=sub_box; vinfo(nucleus(tail)):=p;
+ end;
+
+@ The routine that inserts a |style_node| holds no surprises.
+
+@<Put each...@>=
+primitive("displaystyle",math_style,display_style);
+@!@:display_style_}{\.{\\displaystyle} primitive@>
+primitive("textstyle",math_style,text_style);
+@!@:text_style_}{\.{\\textstyle} primitive@>
+primitive("scriptstyle",math_style,script_style);
+@!@:script_style_}{\.{\\scriptstyle} primitive@>
+primitive("scriptscriptstyle",math_style,script_script_style);
+@!@:script_script_style_}{\.{\\scriptscriptstyle} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+math_style: print_style(chr_code);
+
+@ @<Cases of |main_control| that build...@>=
+mmode+math_style: tail_append(new_style(cur_chr));
+mmode+non_script: begin tail_append(new_glue(zero_glue));
+ subtype(tail):=cond_math_glue;
+ end;
+mmode+math_choice: append_choices;
+
+@ The routine that scans the four mlists of a \.{\\mathchoice} is very
+much like the routine that builds discretionary nodes.
+
+@<Declare act...@>=
+procedure append_choices;
+begin tail_append(new_choice); incr(save_ptr); saved(-1):=0;
+push_math(math_choice_group); scan_left_brace;
+end;
+
+@ @<Cases of |handle_right_brace|...@>=
+math_choice_group: build_choices;
+
+@ @<Declare act...@>=
+procedure build_choices;
+label exit;
+var p:pointer; {the current mlist}
+begin @<DIR: |unsave| math@>; p:=fin_mlist(null);
+case saved(-1) of
+0:display_mlist(tail):=p;
+1:text_mlist(tail):=p;
+2:script_mlist(tail):=p;
+3:begin script_script_mlist(tail):=p; decr(save_ptr); return;
+ end;
+end; {there are no other cases}
+incr(saved(-1)); push_math(math_choice_group); scan_left_brace;
+exit:end;
+
+@ Subscripts and superscripts are attached to the previous nucleus by the
+@^superscripts@>@^subscripts@>
+action procedure called |sub_sup|. We use the facts that |sub_mark=sup_mark+1|
+and |subscr(p)=supscr(p)+1|.
+
+@<Cases of |main_control| that build...@>=
+mmode+sub_mark,mmode+sup_mark: sub_sup;
+
+@ @<Declare act...@>=
+procedure sub_sup;
+var t:small_number; {type of previous sub/superscript}
+@!p:pointer; {field to be filled by |scan_math|}
+begin t:=empty; p:=null;
+if tail<>head then if scripts_allowed(tail) then
+ begin p:=supscr(tail)+cur_cmd-sup_mark; {|supscr| or |subscr|}
+ t:=math_type(p);
+ end;
+if (p=null)or(t<>empty) then @<Insert a dummy noad to be sub/superscripted@>;
+scan_math(p);
+end;
+
+@ @<Insert a dummy...@>=
+begin tail_append(new_noad);
+p:=supscr(tail)+cur_cmd-sup_mark; {|supscr| or |subscr|}
+if t<>empty then
+ begin if cur_cmd=sup_mark then
+ begin print_err("Double superscript");
+@.Double superscript@>
+ help1("I treat `x^1^2' essentially like `x^1{}^2'.");
+ end
+ else begin print_err("Double subscript");
+@.Double subscript@>
+ help1("I treat `x_1_2' essentially like `x_1{}_2'.");
+ end;
+ error;
+ end;
+end
+
+@ An operation like `\.{\\over}' causes the current mlist to go into a
+state of suspended animation: |incompleat_noad| points to a |fraction_noad|
+that contains the mlist-so-far as its numerator, while the denominator
+is yet to come. Finally when the mlist is finished, the denominator will
+go into the incompleat fraction noad, and that noad will become the
+whole formula, unless it is surrounded by `\.{\\left}' and `\.{\\right}'
+delimiters.
+
+@d above_code=0 { `\.{\\above}' }
+@d over_code=1 { `\.{\\over}' }
+@d atop_code=2 { `\.{\\atop}' }
+@d delimited_code=3 { `\.{\\abovewithdelims}', etc.}
+
+@<Put each...@>=
+primitive("above",above,above_code);@/
+@!@:above_}{\.{\\above} primitive@>
+primitive("over",above,over_code);@/
+@!@:over_}{\.{\\over} primitive@>
+primitive("atop",above,atop_code);@/
+@!@:atop_}{\.{\\atop} primitive@>
+primitive("abovewithdelims",above,delimited_code+above_code);@/
+@!@:above_with_delims_}{\.{\\abovewithdelims} primitive@>
+primitive("overwithdelims",above,delimited_code+over_code);@/
+@!@:over_with_delims_}{\.{\\overwithdelims} primitive@>
+primitive("atopwithdelims",above,delimited_code+atop_code);
+@!@:atop_with_delims_}{\.{\\atopwithdelims} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+above: case chr_code of
+ over_code:print_esc("over");
+ atop_code:print_esc("atop");
+ delimited_code+above_code:print_esc("abovewithdelims");
+ delimited_code+over_code:print_esc("overwithdelims");
+ delimited_code+atop_code:print_esc("atopwithdelims");
+ othercases print_esc("above")
+ endcases;
+
+@ @<Cases of |main_control| that build...@>=
+mmode+above: math_fraction;
+
+@ @<Declare act...@>=
+procedure math_fraction;
+var c:small_number; {the type of generalized fraction we are scanning}
+begin c:=cur_chr;
+if incompleat_noad<>null then
+ @<Ignore the fraction operation and complain about this ambiguous case@>
+else begin incompleat_noad:=new_node(fraction_noad,normal);
+ math_type(numerator(incompleat_noad)):=sub_mlist;
+ vinfo(numerator(incompleat_noad)):=vlink(head);
+ vmem(denominator(incompleat_noad)).hh:=empty_field;
+ vmem(left_delimiter(incompleat_noad)).qqqq:=null_delimiter;
+ vmem(right_delimiter(incompleat_noad)).qqqq:=null_delimiter;@/
+ vlink(head):=null; tail:=head;
+ @<Use code |c| to distinguish between generalized fractions@>;
+ end;
+end;
+
+@ @<Use code |c|...@>=
+if c>=delimited_code then
+ begin scan_delimiter(left_delimiter(incompleat_noad),false);
+ scan_delimiter(right_delimiter(incompleat_noad),false);
+ end;
+case c mod delimited_code of
+above_code: begin scan_normal_dimen;
+ thickness(incompleat_noad):=cur_val;
+ end;
+over_code: thickness(incompleat_noad):=default_code;
+atop_code: thickness(incompleat_noad):=0;
+end {there are no other cases}
+
+@ @<Ignore the fraction...@>=
+begin if c>=delimited_code then
+ begin scan_delimiter(garbage,false); scan_delimiter(garbage,false);
+ end;
+if c mod delimited_code=above_code then scan_normal_dimen;
+print_err("Ambiguous; you need another { and }");
+@.Ambiguous...@>
+help3("I'm ignoring this fraction specification, since I don't")@/
+ ("know whether a construction like `x \over y \over z'")@/
+ ("means `{x \over y} \over z' or `x \over {y \over z}'.");
+error;
+end
+
+@ At the end of a math formula or subformula, the |fin_mlist| routine is
+called upon to return a pointer to the newly completed mlist, and to
+pop the nest back to the enclosing semantic level. The parameter to
+|fin_mlist|, if not null, points to a |right_noad| that ends the
+current mlist; this |right_noad| has not yet been appended.
+
+@<Declare the function called |fin_mlist|@>=
+function fin_mlist(@!p:pointer):pointer;
+var q:pointer; {the mlist to return}
+begin if incompleat_noad<>null then @<Compleat the incompleat noad@>
+else begin vlink(tail):=p; q:=vlink(head);
+ end;
+pop_nest; fin_mlist:=q;
+end;
+
+@ @<Compleat...@>=
+begin math_type(denominator(incompleat_noad)):=sub_mlist;
+vinfo(denominator(incompleat_noad)):=vlink(head);
+if p=null then q:=incompleat_noad
+else begin q:=vinfo(numerator(incompleat_noad));
+ if (type(q)<>left_noad)or(delim_ptr=null) then confusion("right");
+@:this can't happen right}{\quad right@>
+ vinfo(numerator(incompleat_noad)):=vlink(delim_ptr);
+ vlink(delim_ptr):=incompleat_noad; vlink(incompleat_noad):=p;
+ end;
+end
+
+@ Now at last we're ready to see what happens when a right brace occurs
+in a math formula. Two special cases are simplified here: Braces are effectively
+removed when they surround a single Ord without sub/superscripts, or when they
+surround an accent that is the nucleus of an Ord atom.
+
+@<Cases of |handle...@>=
+math_group: begin @<DIR: |unsave| math@>; decr(save_ptr);@/
+ math_type(saved(0)):=sub_mlist; p:=fin_mlist(null); vinfo(saved(0)):=p;
+ if p<>null then if vlink(p)=null then
+ if type(p)=ord_noad then
+ begin if math_type(subscr(p))=empty then
+ if math_type(supscr(p))=empty then
+ begin vmem(saved(0)).hh:=vmem(nucleus(p)).hh;
+ flush_node(p);
+ end;
+ end
+ else if type(p)=accent_noad then if saved(0)=nucleus(tail) then
+ if type(tail)=ord_noad then @<Replace the tail of the list by |p|@>;
+ end;
+
+@ @<Replace the tail...@>=
+begin q:=head; while vlink(q)<>tail do q:=vlink(q);
+vlink(q):=p; flush_node(tail); tail:=p;
+end
+
+@ We have dealt with all constructions of math mode except `\.{\\left}' and
+`\.{\\right}', so the picture is completed by the following sections of
+the program.
+
+@<Put each...@>=
+primitive("left",left_right,left_noad);
+@!@:left_}{\.{\\left} primitive@>
+primitive("right",left_right,right_noad);
+@!@:right_}{\.{\\right} primitive@>
+text(frozen_right):="right"; eqtb[frozen_right]:=eqtb[cur_val];
+
+@ @<Cases of |print_cmd_chr|...@>=
+left_right: if chr_code=left_noad then print_esc("left")
+@/@<Cases of |left_right| for |print_cmd_chr|@>@/
+else print_esc("right");
+
+@ @<Cases of |main_control| that build...@>=
+mmode+left_right: math_left_right;
+
+@ @<Declare act...@>=
+procedure math_left_right;
+var t:small_number; {|left_noad| or |right_noad|}
+@!p:pointer; {new noad}
+@!q:pointer; {resulting mlist}
+begin t:=cur_chr;
+if (t<>left_noad)and(cur_group<>math_left_group) then
+ @<Try to recover from mismatched \.{\\right}@>
+else begin p:=new_noad; type(p):=t;
+ scan_delimiter(delimiter(p),false);
+ if t=middle_noad then
+ begin type(p):=right_noad; subtype(p):=middle_noad;
+ end;
+ if t=left_noad then q:=p
+ else begin q:=fin_mlist(p);
+ @<DIR: |unsave| math@>; {end of |math_left_group|}
+ end;
+ if t<>right_noad then
+ begin push_math(math_left_group); vlink(head):=q; tail:=p;
+ delim_ptr:=p;
+ end
+ else begin
+ tail_append(new_noad); type(tail):=inner_noad;
+ math_type(nucleus(tail)):=sub_mlist;
+ vinfo(nucleus(tail)):=q;
+ end;
+ end;
+end;
+
+@ @<Try to recover from mismatch...@>=
+begin if cur_group=math_shift_group then
+ begin scan_delimiter(garbage,false);
+ print_err("Extra ");
+ if t=middle_noad then
+ begin print_esc("middle");
+@.Extra \\middle.@>
+ help1("I'm ignoring a \middle that had no matching \left.");
+ end
+ else begin print_esc("right");
+@.Extra \\right.@>
+ help1("I'm ignoring a \right that had no matching \left.");
+ end;
+ error;
+ end
+else off_save;
+end
+
+@ Here is the only way out of math mode.
+
+@<Cases of |main_control| that build...@>=
+mmode+math_shift: if cur_group=math_shift_group then after_math
+ else off_save;
+
+@ @<Declare act...@>=
+procedure after_math;
+var l:boolean; {`\.{\\leqno}' instead of `\.{\\eqno}'}
+@!danger:boolean; {not enough symbol fonts are present}
+@!m:integer; {|mmode| or |-mmode|}
+@!p:pointer; {the formula}
+@!a:pointer; {box containing equation number}
+@<Local variables for finishing a displayed formula@>@;
+begin danger:=false;
+@<Check that the necessary fonts for math symbols are present;
+ if not, flush the current math lists and set |danger:=true|@>;
+m:=mode; l:=false; p:=fin_mlist(null); {this pops the nest}
+if mode=-m then {end of equation number}
+ begin @<Check that another \.\$ follows@>;
+ cur_mlist:=p; cur_style:=text_style; mlist_penalties:=false;
+ mlist_to_hlist; a:=hpack(vlink(temp_head),natural);
+ @<DIR: |unsave| math@>;
+ decr(save_ptr); {now |cur_group=math_shift_group|}
+ if saved(0)=1 then l:=true;
+ danger:=false;
+ @<Check that the necessary fonts for math symbols are present;
+ if not, flush the current math lists and set |danger:=true|@>;
+ m:=mode; p:=fin_mlist(null);
+ end
+else a:=null;
+if m<0 then @<Finish math in text@>
+else begin if a=null then @<Check that another \.\$ follows@>;
+ @<Finish displayed math@>;
+ end;
+end;
+
+@ @<Check that the necessary fonts...@>=
+if (font_params(fam_fnt(2+text_size))<total_mathsy_params)or@|
+ (font_params(fam_fnt(2+script_size))<total_mathsy_params)or@|
+ (font_params(fam_fnt(2+script_script_size))<total_mathsy_params) then
+ begin print_err("Math formula deleted: Insufficient symbol fonts");@/
+@.Math formula deleted...@>
+ help3("Sorry, but I can't typeset math unless \textfont 2")@/
+ ("and \scriptfont 2 and \scriptscriptfont 2 have all")@/
+ ("the \fontdimen values needed in math symbol fonts.");
+ error; flush_math; danger:=true;
+ end
+else if (font_params(fam_fnt(3+text_size))<total_mathex_params)or@|
+ (font_params(fam_fnt(3+script_size))<total_mathex_params)or@|
+ (font_params(fam_fnt(3+script_script_size))<total_mathex_params) then
+ begin print_err("Math formula deleted: Insufficient extension fonts");@/
+ help3("Sorry, but I can't typeset math unless \textfont 3")@/
+ ("and \scriptfont 3 and \scriptscriptfont 3 have all")@/
+ ("the \fontdimen values needed in math extension fonts.");
+ error; flush_math; danger:=true;
+ end
+
+@ The |unsave| is done after everything else here; hence an appearance of
+`\.{\\mathsurround}' inside of `\.{\$...\$}' affects the spacing at these
+particular \.\$'s. This is consistent with the conventions of
+`\.{\$\$...\$\$}', since `\.{\\abovedisplayskip}' inside a display affects the
+space above that display.
+
+@<Finish math in text@> =
+begin tail_append(new_math(math_surround,before));
+if dir_math_save then
+ @<Append a begin direction to the tail of the current list@>;
+cur_mlist:=p; cur_style:=text_style; mlist_penalties:=(mode>0); mlist_to_hlist;
+vlink(tail):=vlink(temp_head);
+while vlink(tail)<>null do tail:=vlink(tail);
+if dir_math_save then
+ @<Append an end direction to the tail of the current list@>;
+dir_math_save:=false;
+tail_append(new_math(math_surround,after));
+space_factor:=1000;
+@<DIR: |unsave| math@>;
+end
+
+@ \TeX\ gets to the following part of the program when the first `\.\$' ending
+a display has been scanned.
+
+@<Check that another \.\$ follows@>=
+begin get_x_token;
+if cur_cmd<>math_shift then
+ begin print_err("Display math should end with $$");
+@.Display math...with \$\$@>
+ help2("The `$' that I just saw supposedly matches a previous `$$'.")@/
+ ("So I shall assume that you typed `$$' both times.");
+ back_error;
+ end;
+end
+
+@ We have saved the worst for last: The fussiest part of math mode processing
+occurs when a displayed formula is being centered and placed with an optional
+equation number.
+
+@<Local variables for finishing...@>=
+@!b:pointer; {box containing the equation}
+@!w:scaled; {width of the equation}
+@!z:scaled; {width of the line}
+@!e:scaled; {width of equation number}
+@!q:scaled; {width of equation number plus space to separate from equation}
+@!d:scaled; {displacement of equation in the line}
+@!s:scaled; {move the line right this much}
+@!g1,@!g2:small_number; {glue parameter codes for before and after}
+@!r:pointer; {kern node used to position the display}
+@!t:pointer; {tail of adjustment list}
+@!pre_t:pointer; {tail of pre-adjustment list}
+
+@ At this time |p| points to the mlist for the formula; |a| is either
+|null| or it points to a box containing the equation number; and we are in
+vertical mode (or internal vertical mode).
+
+@<Finish displayed math@>=
+cur_mlist:=p; cur_style:=display_style; mlist_penalties:=false;
+mlist_to_hlist; p:=vlink(temp_head);@/
+adjust_tail:=adjust_head; pre_adjust_tail:=pre_adjust_head;
+b:=hpack(p,natural); p:=list_ptr(b);
+t:=adjust_tail; adjust_tail:=null;@/
+pre_t:=pre_adjust_tail; pre_adjust_tail:=null;@/
+w:=width(b); z:=display_width; s:=display_indent;
+if (a=null)or danger then
+ begin e:=0; q:=0;
+ end
+else begin e:=width(a); q:=e+math_quad(text_size);
+ end;
+if w+q>z then
+ @<Squeeze the equation as much as possible; if there is an equation
+ number that should go on a separate line by itself,
+ set~|e:=0|@>;
+@<Determine the displacement, |d|, of the left edge of the equation, with
+ respect to the line size |z|, assuming that |l=false|@>;
+@<Append the glue or equation number preceding the display@>;
+@<Append the display and perhaps also the equation number@>;
+@<Append the glue or equation number following the display@>;
+resume_after_display
+
+@ @<Declare act...@>=
+procedure resume_after_display;
+begin if cur_group<>math_shift_group then confusion("display");
+@:this can't happen display}{\quad display@>
+@<DIR: |unsave| math@>;
+prev_graf:=prev_graf+3;
+push_nest; mode:=hmode; space_factor:=1000;
+@<LOCAL: Add local paragraph node@>;
+@<Scan an optional space@>;
+if nest_ptr=1 then begin check_filter('after_display'); build_page; end;
+end;
+
+@ The user can force the equation number to go on a separate line
+by causing its width to be zero.
+
+@<Squeeze the equation as much as possible...@>=
+begin if (e<>0)and((w-total_shrink[normal]+q<=z)or@|
+ (total_shrink[sfi]<>0)or(total_shrink[fil]<>0)or
+ (total_shrink[fill]<>0)or(total_shrink[filll]<>0)) then
+ begin flush_node(b);
+ b:=hpack(p,z-q,exactly);
+ end
+else begin e:=0;
+ if w>z then
+ begin
+ list_ptr(b):=null; flush_node(b);
+ b:=hpack(p,z,exactly);
+ end;
+ end;
+w:=width(b);
+end
+
+@ We try first to center the display without regard to the existence of
+the equation number. If that would make it too close (where ``too close''
+means that the space between display and equation number is less than the
+width of the equation number), we either center it in the remaining space
+or move it as far from the equation number as possible. The latter alternative
+is taken only if the display begins with glue, since we assume that the
+user put glue there to control the spacing precisely.
+
+@<Determine the displacement, |d|, of the left edge of the equation...@>=
+d:=half(z-w);
+if (e>0)and(d<2*e) then {too close}
+ begin d:=half(z-w-e);
+ if p<>null then if not is_char_node(p) then if type(p)=glue_node then d:=0;
+ end
+
+@ If the equation number is set on a line by itself, either before or
+after the formula, we append an infinite penalty so that no page break will
+separate the display from its number; and we use the same size and
+displacement for all three potential lines of the display, even though
+`\.{\\parshape}' may specify them differently.
+
+@<Append the glue or equation number preceding the display@>=
+tail_append(new_penalty(pre_display_penalty));@/
+if (d+s<=pre_display_size)or l then {not enough clearance}
+ begin g1:=above_display_skip_code; g2:=below_display_skip_code;
+ end
+else begin g1:=above_display_short_skip_code;
+ g2:=below_display_short_skip_code;
+ end;
+if l and(e=0) then {it follows that |type(a)=hlist_node|}
+ begin shift_amount(a):=s; append_to_vlist(a);
+ tail_append(new_penalty(inf_penalty));
+ end
+else tail_append(new_param_glue(g1))
+
+@ @<Append the display and perhaps also the equation number@>=
+if e<>0 then
+ begin r:=new_kern(z-w-e-d);
+ if l then
+ begin vlink(a):=r; vlink(r):=b; b:=a; d:=0;
+ end
+ else begin vlink(b):=r; vlink(r):=a;
+ end;
+ b:=hpack(b,natural);
+ end;
+shift_amount(b):=s+d; append_to_vlist(b)
+
+@ @<Append the glue or equation number following the display@>=
+if (a<>null)and(e=0)and not l then
+ begin tail_append(new_penalty(inf_penalty));
+ shift_amount(a):=s+z-width(a);
+ append_to_vlist(a);
+ g2:=0;
+ end;
+if t<>adjust_head then {migrating material comes after equation number}
+ begin vlink(tail):=vlink(adjust_head); tail:=t;
+ end;
+if pre_t<>pre_adjust_head then
+ begin vlink(tail):=vlink(pre_adjust_head); tail:=pre_t;
+ end;
+tail_append(new_penalty(post_display_penalty));
+if g2>0 then tail_append(new_param_glue(g2))
+
+@ When \.{\\halign} appears in a display, the alignment routines operate
+essentially as they do in vertical mode. Then the following program is
+activated, with |p| and |q| pointing to the beginning and end of the
+resulting list, and with |aux_save| holding the |prev_depth| value.
+
+@<Finish an alignment in a display@>=
+begin do_assignments;
+if cur_cmd<>math_shift then @<Pontificate about improper alignment in display@>
+else @<Check that another \.\$ follows@>;
+pop_nest;
+tail_append(new_penalty(pre_display_penalty));
+tail_append(new_param_glue(above_display_skip_code));
+vlink(tail):=p;
+if p<>null then tail:=q;
+tail_append(new_penalty(post_display_penalty));
+tail_append(new_param_glue(below_display_skip_code));
+prev_depth:=aux_save.sc; resume_after_display;
+end
+
+@ @<Pontificate...@>=
+begin print_err("Missing $$ inserted");
+@.Missing {\$\$} inserted@>
+help2("Displays can use special alignments (like \eqalignno)")@/
+ ("only if nothing but the alignment itself is between $$'s.");
+back_error;
+end
+
+@* \[49] Mode-independent processing.
+The long |main_control| procedure has now been fully specified, except for
+certain activities that are independent of the current mode. These activities
+do not change the current vlist or hlist or mlist; if they change anything,
+it is the value of a parameter or the meaning of a control sequence.
+
+Assignments to values in |eqtb| can be global or local. Furthermore, a
+control sequence can be defined to be `\.{\\long}', `\.{\\protected}',
+or `\.{\\outer}', and it might or might not be expanded. The prefixes
+`\.{\\global}', `\.{\\long}', `\.{\\protected}',
+and `\.{\\outer}' can occur in any order. Therefore we assign binary numeric
+codes, making it possible to accumulate the union of all specified prefixes
+by adding the corresponding codes. (\PASCAL's |set| operations could also
+have been used.)
+
+@<Put each...@>=
+primitive("long",prefix,1);
+@!@:long_}{\.{\\long} primitive@>
+primitive("outer",prefix,2);
+@!@:outer_}{\.{\\outer} primitive@>
+primitive("global",prefix,4);
+@!@:global_}{\.{\\global} primitive@>
+primitive("def",def,0);
+@!@:def_}{\.{\\def} primitive@>
+primitive("gdef",def,1);
+@!@:gdef_}{\.{\\gdef} primitive@>
+primitive("edef",def,2);
+@!@:edef_}{\.{\\edef} primitive@>
+primitive("xdef",def,3);
+@!@:xdef_}{\.{\\xdef} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+prefix: if chr_code=1 then print_esc("long")
+ else if chr_code=2 then print_esc("outer")
+ @/@<Cases of |prefix| for |print_cmd_chr|@>@/
+ else print_esc("global");
+def: if chr_code=0 then print_esc("def")
+ else if chr_code=1 then print_esc("gdef")
+ else if chr_code=2 then print_esc("edef")
+ else print_esc("xdef");
+
+@ Every prefix, and every command code that might or might not be prefixed,
+calls the action procedure |prefixed_command|. This routine accumulates
+a sequence of prefixes until coming to a non-prefix, then it carries out
+the command.
+
+@<Cases of |main_control| that don't...@>=
+any_mode(toks_register),
+any_mode(assign_toks),
+any_mode(assign_int),
+any_mode(assign_attr),
+any_mode(assign_dir),
+any_mode(assign_dimen),
+any_mode(assign_glue),
+any_mode(assign_mu_glue),
+any_mode(assign_font_dimen),
+any_mode(assign_font_int),
+any_mode(set_aux),
+any_mode(set_prev_graf),
+any_mode(set_page_dimen),
+any_mode(set_page_int),
+any_mode(set_box_dimen),
+any_mode(set_shape),
+any_mode(def_code),
+any_mode(extdef_code),
+any_mode(def_family),
+any_mode(set_font),
+any_mode(def_font),
+any_mode(letterspace_font),
+any_mode(register),
+any_mode(advance),
+any_mode(multiply),
+any_mode(divide),
+any_mode(prefix),
+any_mode(let),
+any_mode(shorthand_def),
+any_mode(read_to_cs),
+any_mode(def),
+any_mode(set_box),
+any_mode(hyph_data),
+any_mode(set_interaction),
+any_mode(set_ocp),
+any_mode(def_ocp),
+any_mode(set_ocp_list),
+any_mode(def_ocp_list),
+any_mode(clear_ocp_lists),
+any_mode(push_ocp_list),
+any_mode(pop_ocp_list),
+any_mode(ocp_list_op),
+any_mode(ocp_trace_level) : prefixed_command;
+
+@ If the user says, e.g., `\.{\\global\\global}', the redundancy is
+silently accepted.
+
+@<Declare act...@>=
+@t\4@>@<Declare subprocedures for |prefixed_command|@>@t@>@;@/
+procedure prefixed_command;
+label done,exit;
+var a:small_number; {accumulated prefix codes so far}
+@!f:internal_font_number; {identifies a font}
+@!j:halfword; {index into a \.{\\parshape} specification}
+@!p,@!q:pointer; {for temporary short-term use}
+@!n:integer; {ditto}
+@!e:boolean; {should a definition be expanded? or was \.{\\let} not done?}
+begin a:=0;
+while cur_cmd=prefix do
+ begin if not odd(a div cur_chr) then a:=a+cur_chr;
+ @<Get the next non-blank non-relax...@>;
+ if cur_cmd<=max_non_prefixed_command then
+ @<Discard erroneous prefixes and |return|@>;
+ if tracing_commands>2 then show_cur_cmd_chr;
+ end;
+@<Discard the prefixes \.{\\long} and \.{\\outer} if they are irrelevant@>;
+@<Adjust \(f)for the setting of \.{\\globaldefs}@>;
+case cur_cmd of
+@t\4@>@<Assignments@>@;
+othercases confusion("prefix")
+@:this can't happen prefix}{\quad prefix@>
+endcases;
+done: @<Insert a token saved by \.{\\afterassignment}, if any@>;
+exit:end;
+
+@ @<Discard erroneous...@>=
+begin print_err("You can't use a prefix with `");
+@.You can't use a prefix with x@>
+print_cmd_chr(cur_cmd,cur_chr); print_char("'");
+help1("I'll pretend you didn't say \long or \outer or \global.");
+back_error; return;
+end
+
+@ @<Discard the prefixes...@>=
+if a>=8 then
+ begin j:=protected_token; a:=a-8;
+ end
+else j:=0;
+if (cur_cmd<>def)and((a mod 4<>0)or(j<>0)) then
+ begin print_err("You can't use `"); print_esc("long"); print("' or `");
+ print_esc("outer"); print("' with `");
+@.You can't use \\long...@>
+ print_cmd_chr(cur_cmd,cur_chr); print_char("'");
+ help1("I'll pretend you didn't say \long or \outer here.");
+ error;
+ end
+
+@ The previous routine does not have to adjust |a| so that |a mod 4=0|,
+since the following routines test for the \.{\\global} prefix as follows.
+
+@d global==(a>=4)
+@d define(#)==if global then geq_define(#)@+else eq_define(#)
+@d word_define(#)==if global then geq_word_define(#)@+else eq_word_define(#)
+@d define_math_code(#)==if global
+ then set_math_code(#,level_one)@+else set_math_code(#,cur_level)
+@d define_del_code(#)==if global
+ then set_del_code(#,level_one)@+else set_del_code(#,cur_level)
+@d define_lc_code(#)==if global
+ then set_lc_code(#,level_one)@+else set_lc_code(#,cur_level)
+@d define_uc_code(#)==if global
+ then set_uc_code(#,level_one)@+else set_uc_code(#,cur_level)
+@d define_sf_code(#)==if global
+ then set_sf_code(#,level_one)@+else set_sf_code(#,cur_level)
+@d define_cat_code(#)==if global
+ then set_cat_code(cat_code_table,#,level_one)@+else set_cat_code(cat_code_table,#,cur_level)
+
+@<Adjust \(f)for the setting of \.{\\globaldefs}@>=
+if global_defs<>0 then
+ if global_defs<0 then
+ begin if global then a:=a-4;
+ end
+ else begin if not global then a:=a+4;
+ end
+
+@ When a control sequence is to be defined, by \.{\\def} or \.{\\let} or
+something similar, the |get_r_token| routine will substitute a special
+control sequence for a token that is not redefinable.
+
+@<Declare subprocedures for |prefixed_command|@>=
+procedure get_r_token;
+label restart;
+begin restart: repeat get_token;
+until cur_tok<>space_token;
+if (cur_cs=0)or(cur_cs>frozen_control_sequence) then
+ begin print_err("Missing control sequence inserted");
+@.Missing control...@>
+ help5("Please don't say `\def cs{...}', say `\def\cs{...}'.")@/
+ ("I've inserted an inaccessible control sequence so that your")@/
+ ("definition will be completed without mixing me up too badly.")@/
+ ("You can recover graciously from this error, if you're")@/
+ ("careful; see exercise 27.2 in The TeXbook.");
+@:TeXbook}{\sl The \TeX book@>
+ if cur_cs=0 then back_input;
+ cur_tok:=cs_token_flag+frozen_protection; ins_error; goto restart;
+ end;
+end;
+
+@ @<Initialize table entries...@>=
+text(frozen_protection):="inaccessible";
+
+@ Assignments from Lua need helpers.
+
+@p function is_int_assign(cmd:halfword):boolean;
+begin
+ is_int_assign := (cmd=assign_int);
+end;
+function is_dim_assign(cmd:halfword):boolean;
+begin
+ is_dim_assign := (cmd=assign_dimen);
+end;
+procedure assign_internal_int(cmd:halfword;value:integer);
+var a:small_number;
+begin
+ a:=0;
+ word_define(cmd,value);
+end;
+procedure assign_internal_dim(cmd:halfword;value:integer);
+var a:small_number;
+begin
+ a:=0;
+ word_define(cmd,value);
+end;
+
+
+@ Here's an example of the way many of the following routines operate.
+(Unfortunately, they aren't all as simple as this.)
+
+@<Assignments@>=
+set_font: define(cur_font_loc,data,cur_chr);
+
+@ When a |def| command has been scanned,
+|cur_chr| is odd if the definition is supposed to be global, and
+|cur_chr>=2| if the definition is supposed to be expanded.
+
+@<Assignments@>=
+def: begin if odd(cur_chr)and not global and(global_defs>=0) then a:=a+4;
+ e:=(cur_chr>=2); get_r_token; p:=cur_cs;
+ q:=scan_toks(true,e);
+ if j<>0 then
+ begin q:=get_avail; info(q):=j; link(q):=link(def_ref);
+ link(def_ref):=q;
+ end;
+ define(p,call+(a mod 4),def_ref);
+ end;
+
+@ Both \.{\\let} and \.{\\futurelet} share the command code |let|.
+
+@<Put each...@>=
+primitive("let",let,normal);@/
+@!@:let_}{\.{\\let} primitive@>
+primitive("futurelet",let,normal+1);@/
+@!@:future_let_}{\.{\\futurelet} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+let: if chr_code<>normal then print_esc("futurelet")@+else print_esc("let");
+
+@ @<Assignments@>=
+let: begin n:=cur_chr;
+ get_r_token; p:=cur_cs;
+ if n=normal then
+ begin repeat get_token;
+ until cur_cmd<>spacer;
+ if cur_tok=other_token+"=" then
+ begin get_token;
+ if cur_cmd=spacer then get_token;
+ end;
+ end
+ else begin get_token; q:=cur_tok; get_token; back_input;
+ cur_tok:=q; back_input; {look ahead, then back up}
+ end; {note that |back_input| doesn't affect |cur_cmd|, |cur_chr|}
+ if cur_cmd>=call then add_token_ref(cur_chr);
+ define(p,cur_cmd,cur_chr);
+ end;
+
+@ A \.{\\chardef} creates a control sequence whose |cmd| is |char_given|;
+a \.{\\mathchardef} creates a control sequence whose |cmd| is |math_given|;
+and the corresponding |chr| is the character code or math code. A \.{\\countdef}
+or \.{\\dimendef} or \.{\\skipdef} or \.{\\muskipdef} creates a control
+sequence whose |cmd| is |assign_int| or \dots\ or |assign_mu_glue|, and the
+corresponding |chr| is the |eqtb| location of the internal register in question.
+
+@d char_def_code=0 {|shorthand_def| for \.{\\chardef}}
+@d math_char_def_code=1 {|shorthand_def| for \.{\\mathchardef}}
+@d omath_char_def_code=2 {|shorthand_def| for \.{\\omathchardef}}
+@d count_def_code=3 {|shorthand_def| for \.{\\countdef}}
+@d attribute_def_code=4 {|shorthand_def| for \.{\\attributedef}}
+@d dimen_def_code=5 {|shorthand_def| for \.{\\dimendef}}
+@d skip_def_code=6 {|shorthand_def| for \.{\\skipdef}}
+@d mu_skip_def_code=7 {|shorthand_def| for \.{\\muskipdef}}
+@d toks_def_code=8 {|shorthand_def| for \.{\\toksdef}}
+
+@<Put each...@>=
+primitive("chardef",shorthand_def,char_def_code);@/
+@!@:char_def_}{\.{\\chardef} primitive@>
+primitive("mathchardef",shorthand_def,math_char_def_code);@/
+@!@:math_char_def_}{\.{\\mathchardef} primitive@>
+primitive("omathchardef",shorthand_def,omath_char_def_code);@/
+@!@:math_char_def_}{\.{\\omathchardef} primitive@>
+primitive("countdef",shorthand_def,count_def_code);@/
+@!@:count_def_}{\.{\\countdef} primitive@>
+primitive("attributedef",shorthand_def,attribute_def_code);@/
+@!@:attribute_def_}{\.{\\attributedef} primitive@>
+primitive("dimendef",shorthand_def,dimen_def_code);@/
+@!@:dimen_def_}{\.{\\dimendef} primitive@>
+primitive("skipdef",shorthand_def,skip_def_code);@/
+@!@:skip_def_}{\.{\\skipdef} primitive@>
+primitive("muskipdef",shorthand_def,mu_skip_def_code);@/
+@!@:mu_skip_def_}{\.{\\muskipdef} primitive@>
+primitive("toksdef",shorthand_def,toks_def_code);@/
+@!@:toks_def_}{\.{\\toksdef} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+shorthand_def: case chr_code of
+ char_def_code: print_esc("chardef");
+ math_char_def_code: print_esc("mathchardef");
+ omath_char_def_code: print_esc("omathchardef");
+ count_def_code: print_esc("countdef");
+ attribute_def_code: print_esc("attributedef");
+ dimen_def_code: print_esc("dimendef");
+ skip_def_code: print_esc("skipdef");
+ mu_skip_def_code: print_esc("muskipdef");
+ othercases print_esc("toksdef")
+ endcases;
+char_given: begin print_esc("char"); print_hex(chr_code);
+ end;
+math_given: begin print_esc("mathchar"); print_hex(chr_code);
+ end;
+omath_given: begin print_esc("omathchar"); print_hex(chr_code);
+ end;
+
+@ We temporarily define |p| to be |relax|, so that an occurrence of |p|
+while scanning the definition will simply stop the scanning instead of
+producing an ``undefined control sequence'' error or expanding the
+previous meaning. This allows, for instance, `\.{\\chardef\\foo=123\\foo}'.
+
+@<Assignments@>=
+shorthand_def: begin n:=cur_chr; get_r_token; p:=cur_cs;
+ define(p,relax,too_big_char); scan_optional_equals;
+ case n of
+ char_def_code: begin scan_char_num; define(p,char_given,cur_val);
+ end;
+ math_char_def_code: begin scan_real_fifteen_bit_int;
+ define(p,math_given,cur_val);
+ end;
+ omath_char_def_code: begin scan_big_fifteen_bit_int;
+ define(p,omath_given,cur_val);
+ end;
+ othercases begin scan_register_num;
+ case n of
+ count_def_code: define(p,assign_int,count_base+cur_val);
+ attribute_def_code: define(p,assign_attr,attribute_base+cur_val);
+ dimen_def_code: define(p,assign_dimen,scaled_base+cur_val);
+ skip_def_code: define(p,assign_glue,skip_base+cur_val);
+ mu_skip_def_code: define(p,assign_mu_glue,mu_skip_base+cur_val);
+ toks_def_code: define(p,assign_toks,toks_base+cur_val);
+ end; {there are no other cases}
+ end
+ endcases;
+ end;
+
+@ @<Assignments@>=
+read_to_cs: begin j:=cur_chr; scan_int; n:=cur_val;
+ if not scan_keyword("to") then
+ begin print_err("Missing `to' inserted");
+@.Missing `to'...@>
+ help2("You should have said `\read<number> to \cs'.")@/
+ ("I'm going to look for the \cs now."); error;
+ end;
+ get_r_token;
+ p:=cur_cs; read_toks(n,p,j); define(p,call,cur_val);
+ end;
+
+@ The token-list parameters, \.{\\output} and \.{\\everypar}, etc., receive
+their values in the following way. (For safety's sake, we place an
+enclosing pair of braces around an \.{\\output} list.)
+
+@<Assignments@>=
+toks_register,assign_toks: begin q:=cur_cs;
+ if cur_cmd=toks_register then
+ begin scan_register_num; p:=toks_base+cur_val;
+ end
+ else p:=cur_chr; {|p=every_par_loc| or |output_routine_loc| or \dots}
+ scan_optional_equals;
+ @<Get the next non-blank non-relax non-call token@>;
+ if cur_cmd<>left_brace then @<If the right-hand side is a token parameter
+ or token register, finish the assignment and |goto done|@>;
+ back_input; cur_cs:=q; q:=scan_toks(false,false);
+ if link(def_ref)=null then {empty list: revert to the default}
+ begin define(p,undefined_cs,null); free_avail(def_ref);
+ end
+ else begin if p=output_routine_loc then {enclose in curlies}
+ begin p:=get_avail; link(q):=p; p:=output_routine_loc;
+ q:=link(q);info(q):=right_brace_token+"}";
+ q:=get_avail;
+ info(q):=left_brace_token+"{";
+ link(q):=link(def_ref); link(def_ref):=q;
+ end;
+ define(p,call,def_ref);
+ end;
+ end;
+
+@ @<If the right-hand side is a token parameter...@>=
+begin if cur_cmd=toks_register then
+ begin scan_register_num; cur_cmd:=assign_toks; cur_chr:=toks_base+cur_val;
+ end;
+if cur_cmd=assign_toks then
+ begin q:=equiv(cur_chr);
+ if q=null then define(p,undefined_cs,null)
+ else begin add_token_ref(q); define(p,call,q);
+ end;
+ goto done;
+ end;
+end
+
+@ Similar routines are used to assign values to the numeric parameters.
+
+@<Assignments@>=
+assign_int: begin p:=cur_chr; scan_optional_equals; scan_int;
+ if p=(int_base+cat_code_table_code) then begin
+ if valid_catcode_table(cur_val) then begin
+ if cur_val<>cat_code_table then
+ word_define(p,cur_val);
+ end
+ else begin
+ print_err("Invalid \catcode table");
+ help2("You can only switch to a \catcode table that is initialized")
+ ("using \savecatcodetable or \initcatcodetable, or to table 0");
+ error;
+ end;
+ end
+ else if (p=new_line_char)and(cur_val>127) then begin
+ print_err("Invalid \newlinechar");
+ help1("The value for \newlinechar has to be between 0 and 127.");
+ error;
+ end
+ else if p=end_line_char then begin
+ if (cur_val<0)or(cur_val>biggest_char) then
+ word_define(p,-1)
+ else
+ word_define(p,13);
+ end
+ else
+ word_define(p,cur_val);
+{If we are defining subparagraph penalty levels while we are
+in hmode, then we put out a whatsit immediately, otherwise
+we leave it alone. This mechanism might not be sufficiently
+powerful, and some other algorithm, searching down the stack,
+might be necessary. Good first step.}
+ if (abs(mode)=hmode) and
+ ((p=(int_base+local_inter_line_penalty_code)) or
+ (p=(int_base+local_broken_penalty_code))) then begin
+ @<LOCAL: Add local paragraph node@>;
+ eq_word_define(int_base+no_local_whatsits_code,no_local_whatsits+1);
+ local_par_bool:=true;
+ end;
+ if p=int_base+language_code then word_define(int_base+cur_lang_code,cur_val);
+ end;
+assign_attr: begin p:=cur_chr; scan_optional_equals; scan_int;
+ if (p-attribute_base)>max_used_attr then max_used_attr:=(p-attribute_base);
+ attr_list_cache:=cache_disabled;
+ word_define(p,cur_val); end;
+assign_dir: begin
+ @<DIR: Assign direction codes@>
+ end;
+assign_dimen: begin p:=cur_chr; scan_optional_equals;
+ scan_normal_dimen; word_define(p,cur_val);
+ end;
+assign_glue,assign_mu_glue: begin p:=cur_chr; n:=cur_cmd; scan_optional_equals;
+ if n=assign_mu_glue then scan_glue(mu_val)@+else scan_glue(glue_val);
+ trap_zero_glue;
+ define(p,glue_ref,cur_val);
+ end;
+
+@ When a glue register or parameter becomes zero, it will always point to
+|zero_glue| because of the following procedure. (Exception: The tabskip
+glue isn't trapped while preambles are being scanned.)
+
+@<Declare subprocedures for |prefixed_command|@>=
+procedure trap_zero_glue;
+begin if (width(cur_val)=0)and(stretch(cur_val)=0)and(shrink(cur_val)=0) then
+ begin add_glue_ref(zero_glue);
+ delete_glue_ref(cur_val); cur_val:=zero_glue;
+ end;
+end;
+
+@ The various character code tables are changed by the |def_code| commands,
+and the font families are declared by |def_family|.
+
+@<Put each...@>=
+primitive("catcode",def_code,cat_code_base);
+@!@:cat_code_}{\.{\\catcode} primitive@>
+primitive("mathcode",def_code,math_code_base);
+@!@:math_code_}{\.{\\mathcode} primitive@>
+primitive("lccode",def_code,lc_code_base);
+@!@:lc_code_}{\.{\\lccode} primitive@>
+primitive("uccode",def_code,uc_code_base);
+@!@:uc_code_}{\.{\\uccode} primitive@>
+primitive("sfcode",def_code,sf_code_base);
+@!@:sf_code_}{\.{\\sfcode} primitive@>
+primitive("delcode",def_code,del_code_base);
+@!@:del_code_}{\.{\\delcode} primitive@>
+primitive("textfont",def_family,math_font_base);
+@!@:text_font_}{\.{\\textfont} primitive@>
+primitive("scriptfont",def_family,math_font_base+script_size);
+@!@:script_font_}{\.{\\scriptfont} primitive@>
+primitive("scriptscriptfont",def_family,math_font_base+script_script_size);
+@!@:script_script_font_}{\.{\\scriptscriptfont} primitive@>
+primitive("omathcode",extdef_code,math_code_base);
+@!@:math_code_}{\.{\\omathcode} primitive@>
+primitive("odelcode",extdef_code,del_code_base);
+@!@:del_code_}{\.{\\odelcode} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+def_code: if chr_code=cat_code_base then print_esc("catcode")
+ else if chr_code=math_code_base then print_esc("mathcode")
+ else if chr_code=lc_code_base then print_esc("lccode")
+ else if chr_code=uc_code_base then print_esc("uccode")
+ else if chr_code=sf_code_base then print_esc("sfcode")
+ else print_esc("delcode");
+extdef_code: if chr_code=math_code_base then print_esc("omathcode")
+ else print_esc("odelcode");
+def_family: print_size(chr_code-math_font_base);
+
+@ The different types of code values have different legal ranges; the
+following program is careful to check each case properly.
+
+@d check_def_code(#)== if ((cur_val<0)and(p<#))or(cur_val>n) then
+ begin print_err("Invalid code ("); print_int(cur_val);
+ if p<# then print("), should be in the range 0..")
+ else print("), should be at most ");
+ print_int(n);
+ help1("I'm going to use 0 instead of that illegal code value.");@/
+ error; cur_val:=0;
+ end
+@.Invalid code@>
+
+
+@<Assignments@>=
+def_code: begin @<Let |n| be the largest legal code value, based on |cur_chr|@>;
+ p:=cur_chr;
+ if cur_chr=math_code_base then begin
+ scan_char_num; p:= cur_val;
+ scan_optional_equals;
+ scan_int;
+ check_def_code(math_code_base);
+ if cur_val=@"8000 then cur_val:=@"8000000
+ else cur_val:=((cur_val div @"1000) * @"1000000) +
+ (((cur_val mod @"1000) div @"100) * @"10000) +
+ (cur_val mod @"100);
+ define_math_code(p,cur_val);
+ end
+ else if cur_chr=lc_code_base then begin
+ scan_char_num; p:= cur_val;
+ scan_optional_equals;
+ scan_int;
+ check_def_code(lc_code_base);
+ define_lc_code(p,cur_val);
+ end
+ else if cur_chr=uc_code_base then begin
+ scan_char_num; p:= cur_val;
+ scan_optional_equals;
+ scan_int;
+ check_def_code(uc_code_base);
+ define_uc_code(p,cur_val);
+ end
+ else if cur_chr=sf_code_base then begin
+ scan_char_num; p:= cur_val;
+ scan_optional_equals;
+ scan_int;
+ check_def_code(sf_code_base);
+ define_sf_code(p,cur_val);
+ end
+ else if cur_chr=cat_code_base then begin
+ scan_char_num; p:= cur_val;
+ scan_optional_equals;
+ scan_int;
+ check_def_code(cat_code_base);
+ define_cat_code(p,cur_val);
+ end
+ else if cur_chr=del_code_base then begin
+ scan_char_num; p:= cur_val;
+ scan_optional_equals;
+ scan_int;
+ check_def_code(del_code_base);
+ cur_val1:=cur_val div @"1000;
+ cur_val1:=(cur_val1 div @"100)*@"10000 + (cur_val1 mod @"100);
+ cur_val:=cur_val mod @"1000;
+ cur_val:=(cur_val div @"100)*@"10000 + (cur_val mod @"100);
+ define_del_code(p,cur_val1,cur_val);
+ end;
+ end;
+extdef_code: begin
+ if cur_chr=del_code_base then begin
+ p:=cur_chr; scan_char_num; p:=p+cur_val; scan_optional_equals;
+ scan_int; cur_val1:=cur_val; scan_int; {backwards}
+ if (cur_val1>@"FFFFFF) or (cur_val>@"FFFFFF) then
+ begin print_err("Invalid code ("); print_int(cur_val1); print(" ");
+ print_int(cur_val);
+ print("), should be at most ""FFFFFF ""FFFFFF");
+ help1("I'm going to use 0 instead of that illegal code value.");@/
+ error; cur_val1:=0; cur_val:=0;
+ end;
+ define_del_code(p,cur_val1,cur_val);
+ end
+ else begin
+ p:=cur_chr; scan_char_num; p:=cur_val; scan_optional_equals;
+ scan_int;
+ if (cur_val>@"8000000) then
+ begin print_err("Invalid code ("); print_int(cur_val);
+@.Invalid code@>
+ print("), should be at most "); print_int(@"8000000);
+ help1("I'm going to use 0 instead of that illegal code value.");@/
+ error; cur_val:=0;
+ end;
+ define_math_code(p,cur_val);
+ end;
+ end;
+
+@ @<Let |n| be the largest...@>=
+if cur_chr=cat_code_base then n:=max_char_code
+else if cur_chr=lc_code_base then n:=biggest_char
+else if cur_chr=uc_code_base then n:=biggest_char
+else if cur_chr=math_code_base then n:=@'100000
+else if cur_chr=sf_code_base then n:=@'77777
+else if cur_chr=del_code_base then n:=@'77777777
+else n:=biggest_char
+
+@ @<Assignments@>=
+def_family: begin p:=cur_chr; scan_math_family_int; p:=p+cur_val;
+ scan_optional_equals; scan_font_ident; define(p,data,cur_val);
+ end;
+
+@ Next we consider changes to \TeX's numeric registers.
+
+@<Assignments@>=
+register,advance,multiply,divide: do_register_command(a);
+
+@ We use the fact that |register<advance<multiply<divide|.
+
+@<Declare subprocedures for |prefixed_command|@>=
+procedure do_register_command(@!a:small_number);
+label found,exit;
+var l,@!q,@!r,@!s:pointer; {for list manipulation}
+@!p:int_val..mu_val; {type of register involved}
+begin q:=cur_cmd;
+@<Compute the register location |l| and its type |p|; but |return| if invalid@>;
+if q=register then scan_optional_equals
+else if scan_keyword("by") then do_nothing; {optional `\.{by}'}
+arith_error:=false;
+if q<multiply then @<Compute result of |register| or
+ |advance|, put it in |cur_val|@>
+else @<Compute result of |multiply| or |divide|, put it in |cur_val|@>;
+if arith_error then
+ begin print_err("Arithmetic overflow");
+@.Arithmetic overflow@>
+ help2("I can't carry out that multiplication or division,")@/
+ ("since the result is out of range.");
+ error; return;
+ end;
+if p<glue_val then begin
+ if p=attr_val then begin
+ if (l-attribute_base)>max_used_attr then max_used_attr:=(l-attribute_base);
+ attr_list_cache:=cache_disabled;
+ end;
+ word_define(l,cur_val);
+ end
+else begin trap_zero_glue; define(l,glue_ref,cur_val);
+ end;
+exit: end;
+
+@ Here we use the fact that the consecutive codes |int_val...mu_val| and
+|assign_int..assign_mu_glue| correspond to each other nicely.
+
+@<Compute the register location |l| and its type |p|...@>=
+begin l:=0;
+if q<>register then
+ begin get_x_token;
+ if (cur_cmd>=assign_int)and(cur_cmd<=assign_mu_glue) then
+ begin l:=cur_chr; p:=cur_cmd-assign_int; goto found;
+ end;
+ if cur_cmd<>register then
+ begin print_err("You can't use `"); print_cmd_chr(cur_cmd,cur_chr);
+@.You can't use x after ...@>
+ print("' after "); print_cmd_chr(q,0);
+ help1("I'm forgetting what you said and not changing anything.");
+ error; return;
+ end;
+ end;
+p:=cur_chr; scan_register_num;
+case p of
+int_val: l:=cur_val+count_base;
+attr_val: l:=cur_val+attribute_base;
+dimen_val: l:=cur_val+scaled_base;
+glue_val: l:=cur_val+skip_base;
+mu_val: l:=cur_val+mu_skip_base;
+end; {there are no other cases}
+end;
+found:
+
+@ @<Compute result of |register| or |advance|...@>=
+if p<glue_val then
+ begin if (p=int_val) or (p=attr_val) then scan_int@+else scan_normal_dimen;
+ if q=advance then cur_val:=cur_val+eqtb[l].int;
+ end
+else begin scan_glue(p);
+ if q=advance then @<Compute the sum of two glue specs@>;
+ end
+
+@ @<Compute the sum of two glue specs@>=
+begin q:=new_spec(cur_val); r:=equiv(l);
+delete_glue_ref(cur_val);
+width(q):=width(q)+width(r);
+if stretch(q)=0 then stretch_order(q):=normal;
+if stretch_order(q)=stretch_order(r) then stretch(q):=stretch(q)+stretch(r)
+else if (stretch_order(q)<stretch_order(r))and(stretch(r)<>0) then
+ begin stretch(q):=stretch(r); stretch_order(q):=stretch_order(r);
+ end;
+if shrink(q)=0 then shrink_order(q):=normal;
+if shrink_order(q)=shrink_order(r) then shrink(q):=shrink(q)+shrink(r)
+else if (shrink_order(q)<shrink_order(r))and(shrink(r)<>0) then
+ begin shrink(q):=shrink(r); shrink_order(q):=shrink_order(r);
+ end;
+cur_val:=q;
+end
+
+@ @<Compute result of |multiply| or |divide|...@>=
+begin scan_int;
+if p<glue_val then
+ if q=multiply then
+ if (p=int_val)or(p=attr_val) then cur_val:=mult_integers(eqtb[l].int,cur_val)
+ else cur_val:=nx_plus_y(eqtb[l].int,cur_val,0)
+ else cur_val:=x_over_n(eqtb[l].int,cur_val)
+else begin s:=equiv(l); r:=new_spec(s);
+ if q=multiply then
+ begin width(r):=nx_plus_y(width(s),cur_val,0);
+ stretch(r):=nx_plus_y(stretch(s),cur_val,0);
+ shrink(r):=nx_plus_y(shrink(s),cur_val,0);
+ end
+ else begin width(r):=x_over_n(width(s),cur_val);
+ stretch(r):=x_over_n(stretch(s),cur_val);
+ shrink(r):=x_over_n(shrink(s),cur_val);
+ end;
+ cur_val:=r;
+ end;
+end
+
+@ The processing of boxes is somewhat different, because we may need
+to scan and create an entire box before we actually change the value of the old
+one.
+
+@<Assignments@>=
+set_box: begin scan_register_num;
+ if global then n:=global_box_flag+cur_val@+else n:=box_flag+cur_val;
+ scan_optional_equals;
+ if set_box_allowed then scan_box(n)
+ else begin print_err("Improper "); print_esc("setbox");
+@.Improper \\setbox@>
+ help2("Sorry, \setbox is not allowed after \halign in a display,")@/
+ ("or between \accent and an accented character."); error;
+ end;
+ end;
+
+@ The |space_factor| or |prev_depth| settings are changed when a |set_aux|
+command is sensed. Similarly, |prev_graf| is changed in the presence of
+|set_prev_graf|, and |dead_cycles| or |insert_penalties| in the presence of
+|set_page_int|. These definitions are always global.
+
+When some dimension of a box register is changed, the change isn't exactly
+global; but \TeX\ does not look at the \.{\\global} switch.
+
+@<Assignments@>=
+set_aux:alter_aux;
+set_prev_graf:alter_prev_graf;
+set_page_dimen:alter_page_so_far;
+set_page_int:alter_integer;
+set_box_dimen:alter_box_dimen;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure alter_aux;
+var c:halfword; {|hmode| or |vmode|}
+begin if cur_chr<>abs(mode) then report_illegal_case
+else begin c:=cur_chr; scan_optional_equals;
+ if c=vmode then
+ begin scan_normal_dimen; prev_depth:=cur_val;
+ end
+ else begin scan_int;
+ if (cur_val<=0)or(cur_val>32767) then
+ begin print_err("Bad space factor");
+@.Bad space factor@>
+ help1("I allow only values in the range 1..32767 here.");
+ int_error(cur_val);
+ end
+ else space_factor:=cur_val;
+ end;
+ end;
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure alter_prev_graf;
+var p:0..nest_size; {index into |nest|}
+begin nest[nest_ptr]:=cur_list; p:=nest_ptr;
+while abs(nest[p].mode_field)<>vmode do decr(p);
+scan_optional_equals; scan_int;
+if cur_val<0 then
+ begin print_err("Bad "); print_esc("prevgraf");
+@.Bad \\prevgraf@>
+ help1("I allow only nonnegative values here.");
+ int_error(cur_val);
+ end
+else begin nest[p].pg_field:=cur_val; cur_list:=nest[nest_ptr];
+ end;
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure alter_page_so_far;
+var c:0..7; {index into |page_so_far|}
+begin c:=cur_chr; scan_optional_equals; scan_normal_dimen;
+page_so_far[c]:=cur_val;
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure alter_integer;
+var c:small_number;
+ {0 for \.{\\deadcycles}, 1 for \.{\\insertpenalties}, etc.}
+begin c:=cur_chr; scan_optional_equals; scan_int;
+if c=0 then dead_cycles:=cur_val
+@/@<Cases for |alter_integer|@>@/
+else insert_penalties:=cur_val;
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure alter_box_dimen;
+var c:small_number; {|width_offset| or |height_offset| or |depth_offset|}
+@!b:eight_bits; {box number}
+begin c:=cur_chr; scan_register_num; b:=cur_val; scan_optional_equals;
+scan_normal_dimen;
+if box(b)<>null then vmem(box(b)+c).sc:=cur_val;
+end;
+
+@ Paragraph shapes are set up in an obvious way. It needs one word more than in
+\TeX, though.
+
+@d shape_node=54 { storage for shape pointers }
+
+@<Assignments@>=
+set_shape: begin q:=cur_chr; scan_optional_equals; scan_int; n:=cur_val;
+ if n<=0 then p:=null
+ else if q>par_shape_loc then
+ begin n:=(cur_val div 2)+1; p:=new_node(shape_node,2*n+1+1); vinfo(p+1):=n;
+ n:=cur_val; vmem(p+2).int:=n; {number of penalties}
+ for j:=p+3 to p+n+2 do
+ begin scan_int; vmem(j).int:=cur_val; {penalty values}
+ end;
+ if not odd(n) then vmem(p+n+3).int:=0; {unused}
+ end
+ else begin p:=new_node(shape_node,2*(n+1)+1); vinfo(p+1):=n;
+ for j:=1 to n do
+ begin scan_normal_dimen;
+ vmem(p+2*j).sc:=cur_val; {indentation}
+ scan_normal_dimen;
+ vmem(p+2*j+1).sc:=cur_val; {width}
+ end;
+ end;
+ define(q,shape_ref,p);
+ end;
+
+@ New language information data is loaded by the |hyph_data| command.
+
+@<Put each...@>=
+primitive("hyphenation",hyph_data,0);
+@!@:hyphenation_}{\.{\\hyphenation} primitive@>
+primitive("patterns",hyph_data,1);
+@!@:patterns_}{\.{\\patterns} primitive@>
+primitive("prehyphenchar",hyph_data,2);
+@!@:prehyphenchar_}{\.{\\prehyphenchar} primitive@>
+primitive("posthyphenchar",hyph_data,3);
+@!@:posthyphenchar_}{\.{\\posthyphenchar} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+hyph_data: case cur_chr of
+ 0: print_esc("hyphenation");
+ 1: print_esc("patterns");
+ 2: print_esc("prehyphenchar");
+ 3: print_esc("posthyphenchar");
+ endcases;
+
+@ @<Assignments@>=
+hyph_data: begin
+ case cur_chr of
+ 0: new_hyph_exceptions;
+ 1: new_patterns;
+ 2: new_pre_hyphen_char;
+ 3: new_post_hyphen_char;
+ endcases;
+ goto done;
+ end;
+
+@ All of \TeX's parameters are kept in |eqtb| except the font information,
+the interaction mode, and the hyphenation tables; these are strictly global.
+
+@<Assignments@>=
+assign_font_dimen: set_font_dimen;
+assign_font_int: begin
+ n:=cur_chr; scan_font_ident; f:=cur_val;
+ if n = no_lig_code then set_no_ligatures(f)
+ else if n < lp_code_base then begin
+ scan_optional_equals; scan_int;
+ if n=0 then set_hyphen_char(f,cur_val)@+else set_skew_char(f,cur_val);
+ end
+ else begin
+ scan_char_num; p := cur_val;
+ scan_optional_equals; scan_int;
+ case n of
+ lp_code_base: set_lp_code(f, p, cur_val);
+ rp_code_base: set_rp_code(f, p, cur_val);
+ ef_code_base: set_ef_code(f, p, cur_val);
+ tag_code: set_tag_code(f, p, cur_val);
+ end;
+ end;
+end;
+
+@ @<Put each...@>=
+primitive("hyphenchar",assign_font_int,0);
+@!@:hyphen_char_}{\.{\\hyphenchar} primitive@>
+primitive("skewchar",assign_font_int,1);
+@!@:skew_char_}{\.{\\skewchar} primitive@>
+primitive("lpcode",assign_font_int,lp_code_base);
+@!@:lp_code_}{\.{\\lpcode} primitive@>
+primitive("rpcode",assign_font_int,rp_code_base);
+@!@:rp_code_}{\.{\\rpcode} primitive@>
+primitive("efcode",assign_font_int,ef_code_base);
+@!@:ef_code_}{\.{\\efcode} primitive@>
+primitive("tagcode",assign_font_int,tag_code);
+@!@:tag_code_}{\.{\\tagcode} primitive@>
+primitive("pdfnoligatures",assign_font_int,no_lig_code);
+@!@:no_lig_code_}{\.{\\pdfnoligatures} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+assign_font_int: case chr_code of
+0: print_esc("hyphenchar");
+1: print_esc("skewchar");
+lp_code_base: print_esc("lpcode");
+rp_code_base: print_esc("rpcode");
+ef_code_base: print_esc("efcode");
+tag_code: print_esc("tagcode");
+no_lig_code: print_esc("pdfnoligatures");
+endcases;
+
+@ Here is where the information for a new font gets loaded.
+
+@<Assignments@>=
+def_font: def_new_font(a);
+letterspace_font: new_letterspaced_font(a);
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure def_new_font(@!a:small_number);
+var u:pointer; {user's font identifier}
+@!s:scaled; {stated ``at'' size, or negative of scaled magnification}
+@!f:internal_font_number; {runs through existing fonts}
+@!t:str_number; {name for the frozen font identifier}
+@!old_setting:0..max_selector; {holds |selector| setting}
+@!offset:integer;
+@!natural_dir:integer;{the natural direction of the font}
+@!flushable_string:str_number; {string not yet referenced}
+@!junk:pointer;
+begin if job_name=0 then open_log_file;
+ {avoid confusing \.{texput} with the font name}
+@.texput@>
+get_r_token; u:=cur_cs;
+if u>=hash_base then t:=text(u)
+else if u=null_cs then t:="FONT"
+else begin old_setting:=selector; selector:=new_string;
+ print("FONT"); print(u-active_base); selector:=old_setting;
+@.FONTx@>
+ str_room(1); t:=make_string;
+ end;
+define(u,set_font,null_font); scan_optional_equals;
+@<Get the next non-blank non-call token@>;
+if cur_cmd<>left_brace then begin
+ back_input;
+ scan_file_name;
+ end
+else begin
+ back_input;
+ junk:=scan_toks(false,true);
+ old_setting:=selector; selector:=new_string;
+ token_show(def_ref); selector:=old_setting;
+ flush_list(def_ref);
+ str_room(1);
+ cur_name:=make_string;
+ cur_ext:="";
+ cur_area:="";
+ end;
+@<Scan the font size specification@>;
+name_in_progress:=true;
+if scan_keyword("offset") then begin
+ scan_int;
+ offset:=cur_val;
+ if (cur_val<0) then begin
+ print_err("Illegal offset has been changed to 0");
+ help1("The offset must be bigger than 0."); int_error(cur_val);
+ offset:=0;
+ end
+ end
+else offset:=0;
+if scan_keyword("naturaldir") then begin
+ scan_direction;
+ natural_dir:=cur_val;
+ end
+else natural_dir:=-1;
+name_in_progress:=false;
+if cur_area = "" then
+ f:=read_font_info(u,cur_name,"",s,natural_dir)
+else
+ f:=read_font_info(u,cur_name,cur_area,s,natural_dir);
+equiv(u):=f; eqtb[font_id_base+f]:=eqtb[u]; font_id_text(f):=t;
+end;
+
+@ @<Scan the font size specification@>=
+name_in_progress:=true; {this keeps |cur_name| from being changed}
+if scan_keyword("at") then @<Put the \(p)(positive) `at' size into |s|@>
+@.at@>
+else if scan_keyword("scaled") then
+@.scaled@>
+ begin scan_int; s:=-cur_val;
+ if (cur_val<=0)or(cur_val>32768) then
+ begin print_err("Illegal magnification has been changed to 1000");@/
+@.Illegal magnification...@>
+ help1("The magnification ratio must be between 1 and 32768.");
+ int_error(cur_val); s:=-1000;
+ end;
+ end
+else s:=-1000;
+name_in_progress:=false
+
+@ @<Put the \(p)(positive) `at' size into |s|@>=
+begin scan_normal_dimen; s:=cur_val;
+if (s<=0)or(s>=@'1000000000) then
+ begin print_err("Improper `at' size (");
+ print_scaled(s); print("pt), replaced by 10pt");
+@.Improper `at' size...@>
+ help2("I can only handle fonts at positive sizes that are")@/
+ ("less than 2048pt, so I've changed what you said to 10pt.");
+ error; s:=10*unity;
+ end;
+end
+
+
+@ @<Cases of |print_cmd_chr|...@>=
+set_font:begin print("select font "); print_font_name(chr_code);
+ if font_size(chr_code)<>font_dsize(chr_code) then
+ begin print(" at "); print_scaled(font_size(chr_code));
+ print("pt");
+ end;
+ end;
+
+@ @<Put each...@>=
+primitive("batchmode",set_interaction,batch_mode);
+@!@:batch_mode_}{\.{\\batchmode} primitive@>
+primitive("nonstopmode",set_interaction,nonstop_mode);
+@!@:nonstop_mode_}{\.{\\nonstopmode} primitive@>
+primitive("scrollmode",set_interaction,scroll_mode);
+@!@:scroll_mode_}{\.{\\scrollmode} primitive@>
+primitive("errorstopmode",set_interaction,error_stop_mode);
+@!@:error_stop_mode_}{\.{\\errorstopmode} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+set_interaction: case chr_code of
+ batch_mode: print_esc("batchmode");
+ nonstop_mode: print_esc("nonstopmode");
+ scroll_mode: print_esc("scrollmode");
+ othercases print_esc("errorstopmode")
+ endcases;
+
+@ @<Assignments@>=
+set_interaction: new_interaction;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure new_interaction;
+begin print_ln;
+interaction:=cur_chr;
+@<Initialize the print |selector| based on |interaction|@>;
+if log_opened then selector:=selector+2;
+end;
+
+@ The \.{\\afterassignment} command puts a token into the global
+variable |after_token|. This global variable is examined just after
+every assignment has been performed.
+
+@<Glob...@>=
+@!after_token:halfword; {zero, or a saved token}
+
+@ @<Set init...@>=
+after_token:=0;
+
+@ @<Cases of |main_control| that don't...@>=
+any_mode(after_assignment):begin get_token; after_token:=cur_tok;
+ end;
+
+@ @<Insert a token saved by \.{\\afterassignment}, if any@>=
+if after_token<>0 then
+ begin cur_tok:=after_token; back_input; after_token:=0;
+ end
+
+@ Here is a procedure that might be called `Get the next non-blank non-relax
+non-call non-assignment token'.
+
+@<Declare act...@>=
+procedure do_assignments;
+label exit;
+begin loop begin @<Get the next non-blank non-relax...@>;
+ if cur_cmd<=max_non_prefixed_command then return;
+ set_box_allowed:=false; prefixed_command; set_box_allowed:=true;
+ end;
+exit:end;
+
+@ @<Cases of |main_control| that don't...@>=
+any_mode(after_group):begin get_token; save_for_after(cur_tok);
+ end;
+
+@ Files for \.{\\read} are opened and closed by the |in_stream| command.
+
+@<Put each...@>=
+primitive("openin",in_stream,1);
+@!@:open_in_}{\.{\\openin} primitive@>
+primitive("closein",in_stream,0);
+@!@:close_in_}{\.{\\closein} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+in_stream: if chr_code=0 then print_esc("closein")
+ else print_esc("openin");
+
+@ @<Cases of |main_control| that don't...@>=
+any_mode(in_stream): open_or_close_in;
+
+@ @<Declare act...@>=
+procedure open_or_close_in;
+var c:0..1; {1 for \.{\\openin}, 0 for \.{\\closein}}
+@!n:0..15; {stream number}
+begin c:=cur_chr; scan_four_bit_int; n:=cur_val;
+if read_open[n]<>closed then
+ begin lua_a_close_in(read_file[n],(n+1)); read_open[n]:=closed;
+ end;
+if c<>0 then
+ begin scan_optional_equals; scan_file_name;
+ if cur_ext="" then cur_ext:=".tex";
+ pack_cur_name;
+ if lua_a_open_in(read_file[n],(n+1)) then begin
+ read_file[n]:= name_file_pointer;
+ read_open[n]:=just_open;
+ end;
+ end;
+end;
+
+@ The user can issue messages to the terminal, regardless of the
+current mode.
+
+@<Cases of |main_control| that don't...@>=
+any_mode(message):issue_message;
+
+@ @<Put each...@>=
+primitive("message",message,0);
+@!@:message_}{\.{\\message} primitive@>
+primitive("errmessage",message,1);
+@!@:err_message_}{\.{\\errmessage} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+message: if chr_code=0 then print_esc("message")
+ else print_esc("errmessage");
+
+@ @<Declare act...@>=
+procedure issue_message;
+var old_setting:0..max_selector; {holds |selector| setting}
+junk:pointer;
+@!c:0..1; {identifies \.{\\message} and \.{\\errmessage}}
+@!s:str_number; {the message}
+begin c:=cur_chr; junk:=scan_toks(false,true);
+old_setting:=selector; selector:=new_string;
+token_show(def_ref); selector:=old_setting;
+flush_list(def_ref);
+str_room(1); s:=make_string;
+if c=0 then @<Print string |s| on the terminal@>
+else @<Print string |s| as an error message@>;
+flush_string;
+end;
+
+@ @<Print string |s| on the terminal@>=
+begin if term_offset+length(s)>max_print_line-2 then print_ln
+else if (term_offset>0)or(file_offset>0) then print_char(" ");
+slow_print(s); update_terminal;
+end
+
+@ If \.{\\errmessage} occurs often in |scroll_mode|, without user-defined
+\.{\\errhelp}, we don't want to give a long help message each time. So we
+give a verbose explanation only once.
+
+@<Glob...@>=
+@!long_help_seen:boolean; {has the long \.{\\errmessage} help been used?}
+
+@ @<Set init...@>=long_help_seen:=false;
+
+@ @<Print string |s| as an error message@>=
+begin print_err(""); slow_print(s);
+if err_help<>null then use_err_help:=true
+else if long_help_seen then help1("(That was another \errmessage.)")
+else begin if interaction<error_stop_mode then long_help_seen:=true;
+ help4("This error message was generated by an \errmessage")@/
+ ("command, so I can't give any explicit help.")@/
+ ("Pretend that you're Hercule Poirot: Examine all clues,")@/
+@^Poirot, Hercule@>
+ ("and deduce the truth by order and method.");
+ end;
+error; use_err_help:=false;
+end
+
+@ The |error| routine calls on |give_err_help| if help is requested from
+the |err_help| parameter.
+
+@p procedure give_err_help;
+begin token_show(err_help);
+end;
+
+@ The \.{\\uppercase} and \.{\\lowercase} commands are implemented by
+building a token list and then changing the cases of the letters in it.
+
+@<Cases of |main_control| that don't...@>=
+any_mode(case_shift):shift_case;
+
+@ @<Put each...@>=
+primitive("lowercase",case_shift,lc_code_base);
+@!@:lowercase_}{\.{\\lowercase} primitive@>
+primitive("uppercase",case_shift,uc_code_base);
+@!@:uppercase_}{\.{\\uppercase} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+case_shift:if chr_code=lc_code_base then print_esc("lowercase")
+ else print_esc("uppercase");
+
+@ @<Declare act...@>=
+procedure shift_case;
+var b:pointer; {|lc_code_base| or |uc_code_base|}
+@!p:pointer; {runs through the token list}
+@!t:halfword; {token}
+@!c:halfword; {character code}
+@!i:halfword; {inbetween}
+begin b:=cur_chr; p:=scan_toks(false,false); p:=link(def_ref);
+while p<>null do
+ begin @<Change the case of the token in |p|, if a change is appropriate@>;
+ p:=link(p);
+ end;
+back_list(link(def_ref)); free_avail(def_ref); {omit reference count}
+end;
+
+@ When the case of a |chr_code| changes, we don't change the |cmd|.
+We also change active characters, using the fact that
+|cs_token_flag+active_base| is a multiple of~|string_offset|.
+@^data structure assumptions@>
+
+@<Change the case of the token in |p|, if a change is appropriate@>=
+t:=info(p);
+if t<cs_token_flag+null_cs then
+ begin
+ c:=t mod string_offset;
+ if b=uc_code_base then begin
+ i:=get_uc_code(c);
+ if i<>0 then info(p):=t-c+i;
+ end
+ else
+ begin if get_lc_code(c)<>0 then info(p):=t-c+get_lc_code(c); end;
+ end
+
+@ We come finally to the last pieces missing from |main_control|, namely the
+`\.{\\show}' commands that are useful when debugging.
+
+@<Cases of |main_control| that don't...@>=
+any_mode(xray): show_whatever;
+
+@ @d show_code=0 { \.{\\show} }
+@d show_box_code=1 { \.{\\showbox} }
+@d show_the_code=2 { \.{\\showthe} }
+@d show_lists=3 { \.{\\showlists} }
+
+@<Put each...@>=
+primitive("show",xray,show_code);
+@!@:show_}{\.{\\show} primitive@>
+primitive("showbox",xray,show_box_code);
+@!@:show_box_}{\.{\\showbox} primitive@>
+primitive("showthe",xray,show_the_code);
+@!@:show_the_}{\.{\\showthe} primitive@>
+primitive("showlists",xray,show_lists);
+@!@:show_lists_}{\.{\\showlists} primitive@>
+
+@ @<Cases of |print_cmd_chr|...@>=
+xray: case chr_code of
+ show_box_code:print_esc("showbox");
+ show_the_code:print_esc("showthe");
+ show_lists:print_esc("showlists");
+ @<Cases of |xray| for |print_cmd_chr|@>@;@/
+ othercases print_esc("show")
+ endcases;
+
+@ @<Declare act...@>=
+procedure show_whatever;
+label common_ending;
+var p:pointer; {tail of a token list to show}
+@!t:small_number; {type of conditional being shown}
+@!m:normal..or_code; {upper bound on |fi_or_else| codes}
+@!l:integer; {line where that conditional began}
+@!n:integer; {level of \.{\\if...\\fi} nesting}
+begin case cur_chr of
+show_lists: begin begin_diagnostic; show_activities;
+ end;
+show_box_code: @<Show the current contents of a box@>;
+show_code: @<Show the current meaning of a token, then |goto common_ending|@>;
+@<Cases for |show_whatever|@>@;@/
+othercases @<Show the current value of some parameter or register,
+ then |goto common_ending|@>
+endcases;@/
+@<Complete a potentially long \.{\\show} command@>;
+common_ending: if interaction<error_stop_mode then
+ begin help0; decr(error_count);
+ end
+else if tracing_online>0 then
+ begin@t@>@;@/
+ help3("This isn't an error message; I'm just \showing something.")@/
+ ("Type `I\show...' to show more (e.g., \show\cs,")@/
+ ("\showthe\count10, \showbox255, \showlists).");
+ end
+else begin@t@>@;@/
+ help5("This isn't an error message; I'm just \showing something.")@/
+ ("Type `I\show...' to show more (e.g., \show\cs,")@/
+ ("\showthe\count10, \showbox255, \showlists).")@/
+ ("And type `I\tracingonline=1\show...' to show boxes and")@/
+ ("lists on your terminal as well as in the transcript file.");
+ end;
+error;
+end;
+
+@ @<Show the current meaning of a token...@>=
+begin get_token;
+if interaction=error_stop_mode then wake_up_terminal;
+print_nl("> ");
+if cur_cs<>0 then
+ begin sprint_cs(cur_cs); print_char("=");
+ end;
+print_meaning; goto common_ending;
+end
+
+@ @<Cases of |print_cmd_chr|...@>=
+undefined_cs: print("undefined");
+call,long_call,outer_call,long_outer_call: begin n:=cmd-call;
+ if info(link(chr_code))=protected_token then n:=n+4;
+ if odd(n div 4) then print_esc("protected");
+ if odd(n) then print_esc("long");
+ if odd(n div 2) then print_esc("outer");
+ if n>0 then print_char(" ");
+ print("macro");
+ end;
+end_template: print_esc("outer endtemplate");
+
+@ @<Show the current contents of a box@>=
+begin scan_register_num; begin_diagnostic;
+print_nl("> \box"); print_int(cur_val); print_char("=");
+if box(cur_val)=null then print("void")
+else show_box(box(cur_val));
+end
+
+@ @<Show the current value of some parameter...@>=
+begin p:=the_toks;
+if interaction=error_stop_mode then wake_up_terminal;
+print_nl("> "); token_show(temp_token_head);
+flush_list(link(temp_token_head)); goto common_ending;
+end
+
+@ @<Complete a potentially long \.{\\show} command@>=
+end_diagnostic(true); print_err("OK");
+@.OK@>
+if selector=term_and_log then if tracing_online<=0 then
+ begin selector:=term_only; print(" (see the transcript file)");
+ selector:=term_and_log;
+ end
+
+@* \[50] Dumping and undumping the tables.
+After \.{INITEX} has seen a collection of fonts and macros, it
+can write all the necessary information on an auxiliary file so
+that production versions of \TeX\ are able to initialize their
+memory at high speed. The present section of the program takes
+care of such output and input. We shall consider simultaneously
+the processes of storing and restoring,
+so that the inverse relation between them is clear.
+@.INITEX@>
+
+The global variable |format_ident| is a string that is printed right
+after the |banner| line when \TeX\ is ready to start. For \.{INITEX} this
+string says simply `\.{(INITEX)}'; for other versions of \TeX\ it says,
+for example, `\.{(preloaded format=plain 82.11.19)}', showing the year,
+month, and day that the format file was created. We have |format_ident=0|
+before \TeX's tables are loaded.
+
+@<Glob...@>=
+@!format_ident:str_number;
+@!format_name:str_number; {principal file name}
+
+@ @<Set init...@>=
+format_ident:=0;
+format_name:="";
+
+@ @<Initialize table entries...@>=
+format_ident:=" (INITEX)";
+
+@ @<Declare act...@>=
+@!init procedure store_fmt_file;
+label found1,found2,done1,done2;
+var j,@!k,@!l:integer; {all-purpose indices}
+@!p: pointer; {all-purpose pointer}
+@!x: integer; {something to dump}
+@!w: four_quarters; {four ASCII codes}
+begin @<If dumping is not allowed, abort@>;
+@<Create the |format_ident|, open the format file,
+ and inform the user that dumping has begun@>;
+@<Dump constants for consistency check@>;
+@<Dump the string pool@>;
+@<Dump the dynamic memory@>;
+@<Dump the table of equivalents@>;
+@<Dump the font information@>;
+@<Dump the active ocp information@>;
+@<Dump the ocp information@>;
+@<Dump the ocp list information@>;
+@<Dump the hyphenation tables@>;
+@<Dump a couple more things and the closing check word@>;
+@<Dump the lua bytecodes@>;
+@<Close the format file@>;
+end;
+tini
+
+@ Corresponding to the procedure that dumps a format file, we have a function
+that reads one in. The function returns |false| if the dumped format is
+incompatible with the present \TeX\ table sizes, etc.
+
+@d bad_fmt=6666 {go here if the format file is unacceptable}
+@d too_small(#)==begin wake_up_terminal;
+ wterm_ln('---! Must increase the ',#);
+@.Must increase the x@>
+ goto bad_fmt;
+ end
+
+@p @t\4@>@<Declare the function called |open_fmt_file|@>@;
+function load_fmt_file:boolean;
+label bad_fmt,exit;
+var j,@!k:integer; {all-purpose indices}
+@!p: pointer; {all-purpose pointer}
+@!x: integer; {something undumped}
+@!w: four_quarters; {four ASCII codes}
+begin @<Undump constants for consistency check@>;
+@<Undump the string pool@>;
+@<Undump the dynamic memory@>;
+@<Undump the table of equivalents@>;
+@<Undump the font information@>;
+@<Undump the active ocp information@>;
+@<Undump the ocp information@>;
+@<Undump the ocp list information@>;
+@<Undump the hyphenation tables@>;
+@<Undump a couple more things and the closing check word@>;
+@<Undump the lua bytecodes@>;
+load_fmt_file:=true; return; {it worked!}
+bad_fmt: wake_up_terminal;
+ wterm_ln('(Fatal format file error; I''m stymied)');
+@.Fatal format file error@>
+load_fmt_file:=false;
+exit:end;
+
+@ The user is not allowed to dump a format file unless |save_ptr=0|.
+This condition implies that |cur_level=level_one|, hence
+the |xeq_level| array is constant and it need not be dumped.
+
+@<If dumping is not allowed, abort@>=
+if save_ptr<>0 then
+ begin print_err("You can't dump inside a group");
+@.You can't dump...@>
+ help1("`{...\dump}' is a no-no."); succumb;
+ end
+
+@ Format files consist of |memory_word| items, and we use the following
+macros to dump words of different types:
+
+@d dump_wd(#)==begin fmt_file^:=#; put(fmt_file);@+end
+@d dump_int(#)==begin fmt_file^.int:=#; put(fmt_file);@+end
+@d dump_hh(#)==begin fmt_file^.hh:=#; put(fmt_file);@+end
+@d dump_qqqq(#)==begin fmt_file^.qqqq:=#; put(fmt_file);@+end
+
+@<Glob...@>=
+@!fmt_file:word_file; {for input or output of format information}
+
+@ The inverse macros are slightly more complicated, since we need to check
+the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
+read an integer value |x| that is supposed to be in the range |a<=x<=b|.
+
+@d undump_wd(#)==begin get(fmt_file); #:=fmt_file^;@+end
+@d undump_int(#)==begin get(fmt_file); #:=fmt_file^.int;@+end
+@d undump_hh(#)==begin get(fmt_file); #:=fmt_file^.hh;@+end
+@d undump_qqqq(#)==begin get(fmt_file); #:=fmt_file^.qqqq;@+end
+@d undump_end_end(#)==#:=x;@+end
+@d undump_end(#)==(x>#) then goto bad_fmt@+else undump_end_end
+@d undump(#)==begin undump_int(x); if (x<#) or undump_end
+@d undump_size_end_end(#)==too_small(#)@+else undump_end_end
+@d undump_size_end(#)==if x># then undump_size_end_end
+@d undump_size(#)==begin undump_int(x);
+ if x<# then goto bad_fmt; undump_size_end
+
+@ The next few sections of the program should make it clear how we use the
+dump/undump macros.
+
+@<Dump constants for consistency check@>=
+dump_int(@$);@/
+dump_int(eqtb_size);@/
+dump_int(hash_prime)
+
+@ Sections of a \.{WEB} program that are ``commented out'' still contribute
+strings to the string pool; therefore \.{INITEX} and \TeX\ will have
+the same strings. (And it is, of course, a good thing that they do.)
+@.WEB@>
+@^string pool@>
+
+@<Undump constants for consistency check@>=
+x:=fmt_file^.int;
+if x<>@$ then goto bad_fmt; {check that strings are the same}
+undump_int(x);@/
+if x<>eqtb_size then goto bad_fmt;
+undump_int(x);
+if x<>hash_prime then goto bad_fmt
+
+@ @d dump_four_ASCII==
+ w.b0:=qi(so(str_pool[k])); w.b1:=qi(so(str_pool[k+1]));
+ w.b2:=qi(so(str_pool[k+2])); w.b3:=qi(so(str_pool[k+3]));
+ dump_qqqq(w)
+
+@<Dump the string pool@>=
+dump_int(pool_ptr);
+dump_int(str_ptr);
+for k:=string_offset to str_ptr do dump_int(str_start_macro(k));
+k:=0;
+while k+4<pool_ptr do
+ begin dump_four_ASCII; k:=k+4;
+ end;
+k:=pool_ptr-4; dump_four_ASCII;
+print_ln; print_int(str_ptr-string_offset); print(" strings of total length ");
+print_int(pool_ptr)
+
+@ @d undump_four_ASCII==
+ undump_qqqq(w);
+ str_pool[k]:=si(qo(w.b0)); str_pool[k+1]:=si(qo(w.b1));
+ str_pool[k+2]:=si(qo(w.b2)); str_pool[k+3]:=si(qo(w.b3))
+
+@<Undump the string pool@>=
+undump_size(0)(pool_size)('string pool size')(pool_ptr);
+undump_size(0)(max_strings)('max strings')(str_ptr);
+for k:=string_offset to str_ptr do undump(0)(pool_ptr)(str_start_macro(k));
+k:=0;
+while k+4<pool_ptr do
+ begin undump_four_ASCII; k:=k+4;
+ end;
+k:=pool_ptr-4; undump_four_ASCII;
+init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr
+
+@ By sorting the list of available spaces in the variable-size portion of
+|mem|, we are usually able to get by without having to dump very much
+of the dynamic memory.
+
+We recompute |var_used| and |dyn_used|, so that \.{INITEX} dumps valid
+information even when it has not been gathering statistics.
+
+@<Dump the dynamic memory@>=
+dump_node_mem;
+@#
+dump_int(temp_token_head); dump_int(hold_token_head);
+dump_int(omit_template); dump_int(null_list);
+dump_int(backup_head); dump_int(garbage);
+dump_int(fix_mem_min); dump_int(fix_mem_max);
+dump_int(fix_mem_end);
+dump_int(avail);
+dyn_used:=fix_mem_end+1;
+for k:=fix_mem_min to fix_mem_end do dump_wd(mem(k));
+x:=x+(fix_mem_end+1-fix_mem_min);
+p:=avail;
+while p<>null do
+ begin decr(dyn_used); p:=link(p);
+ end;
+dump_int(dyn_used);
+print_ln; print_int(x);
+print(" memory locations dumped; current usage is ");
+print_int(var_used); print_char("&"); print_int(dyn_used)
+
+@ @<Undump the dynamic memory@>=
+undump_node_mem;
+@#
+undump_int(temp_token_head); undump_int(hold_token_head);
+undump_int(omit_template); undump_int(null_list);
+undump_int(backup_head); undump_int(garbage);
+undump_int(fix_mem_min);undump_int(fix_mem_max);
+fixmem:= xmallocarray (smemory_word, fix_mem_max+1);
+memset (voidcast(fixmem),0,(fix_mem_max+1)*sizeof(smemory_word));
+undump_int(fix_mem_end);
+undump_int(avail);
+for k:=fix_mem_min to fix_mem_end do undump_wd(mem(k));
+undump_int(dyn_used)
+
+@ @<Dump the table of equivalents@>=
+@<Dump regions 1 to 4 of |eqtb|@>;
+@<Dump regions 5 and 6 of |eqtb|@>;
+dump_int(par_loc); dump_int(write_loc);@/
+dump_math_codes;
+dump_text_codes;
+@<Dump the hash table@>
+
+@ @<Undump the table of equivalents@>=
+@<Undump regions 1 to 6 of |eqtb|@>;
+undump(hash_base)(frozen_control_sequence)(par_loc);
+par_token:=cs_token_flag+par_loc;@/
+undump(hash_base)(frozen_control_sequence)(write_loc);@/
+undump_math_codes;
+undump_text_codes;
+@<Undump the hash table@>
+
+@ The table of equivalents usually contains repeated information, so we dump it
+in compressed form: The sequence of $n+2$ values $(n,x_1,\ldots,x_n,m)$ in the
+format file represents $n+m$ consecutive entries of |eqtb|, with |m| extra
+copies of $x_n$, namely $(x_1,\ldots,x_n,x_n,\ldots,x_n)$.
+
+@<Dump regions 1 to 4 of |eqtb|@>=
+k:=active_base;
+repeat j:=k;
+while j<int_base-1 do
+ begin if (equiv(j)=equiv(j+1))and(eq_type(j)=eq_type(j+1))and@|
+ (eq_level(j)=eq_level(j+1)) then goto found1;
+ incr(j);
+ end;
+l:=int_base; goto done1; {|j=int_base-1|}
+found1: incr(j); l:=j;
+while j<int_base-1 do
+ begin if (equiv(j)<>equiv(j+1))or(eq_type(j)<>eq_type(j+1))or@|
+ (eq_level(j)<>eq_level(j+1)) then goto done1;
+ incr(j);
+ end;
+done1:
+dump_int(l-k);
+while k<l do
+ begin dump_wd(eqtb[k]); incr(k);
+ end;
+k:=j+1; dump_int(k-l);
+until k=int_base
+
+@ @<Dump regions 5 and 6 of |eqtb|@>=
+repeat j:=k;
+while j<eqtb_size do
+ begin if eqtb[j].int=eqtb[j+1].int then goto found2;
+ incr(j);
+ end;
+l:=eqtb_size+1; goto done2; {|j=eqtb_size|}
+found2: incr(j); l:=j;
+while j<eqtb_size do
+ begin if eqtb[j].int<>eqtb[j+1].int then goto done2;
+ incr(j);
+ end;
+done2:dump_int(l-k);
+while k<l do
+ begin dump_wd(eqtb[k]); incr(k);
+ end;
+k:=j+1; dump_int(k-l);
+until k>eqtb_size
+
+@ @<Undump regions 1 to 6 of |eqtb|@>=
+k:=active_base;
+repeat undump_int(x);
+if (x<1)or(k+x>eqtb_size+1) then goto bad_fmt;
+for j:=k to k+x-1 do undump_wd(eqtb[j]);
+k:=k+x;
+undump_int(x);
+if (x<0)or(k+x>eqtb_size+1) then goto bad_fmt;
+for j:=k to k+x-1 do eqtb[j]:=eqtb[k-1];
+k:=k+x;
+until k>eqtb_size
+
+@ A different scheme is used to compress the hash table, since its lower
+region is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output
+two words, |p| and |hash[p]|. The hash table is, of course, densely packed
+for |p>=hash_used|, so the remaining entries are output in a~block.
+
+@<Dump the hash table@>=
+for p:=0 to prim_size do dump_hh(prim[p]);
+for p:=0 to prim_size do dump_wd(prim_eqtb[p]);
+dump_int(hash_used); cs_count:=frozen_control_sequence-1-hash_used;
+for p:=hash_base to hash_used do if text(p)<>0 then
+ begin dump_int(p); dump_hh(hash[p]); incr(cs_count);
+ end;
+for p:=hash_used+1 to undefined_control_sequence-1 do dump_hh(hash[p]);
+dump_int(cs_count);@/
+print_ln; print_int(cs_count); print(" multiletter control sequences")
+
+@ @<Undump the hash table@>=
+for p:=0 to prim_size do undump_hh(prim[p]);
+for p:=0 to prim_size do undump_wd(prim_eqtb[p]);
+undump(hash_base)(frozen_control_sequence)(hash_used); p:=hash_base-1;
+repeat undump(p+1)(hash_used)(p); undump_hh(hash[p]);
+until p=hash_used;
+for p:=hash_used+1 to undefined_control_sequence-1 do undump_hh(hash[p]);
+undump_int(cs_count)
+
+@ @<Dump the font information@>=
+dump_int(max_font_id);
+for k:=0 to max_font_id do
+ @<Dump the array info for internal font number |k|@>;
+print_ln; print_int(max_font_id); print(" preloaded font");
+if max_font_id<>1 then print_char("s")
+
+@ @<Undump the font information@>=
+undump_int(x);
+set_max_font_id(x);
+for k:=0 to max_font_id do
+ @<Undump the array info for internal font number |k|@>
+
+@ @<Dump the array info for internal font number |k|@>=
+begin dump_font(k);
+print_nl("\font"); print_esc(font_id_text(k)); print_char("=");
+print_file_name(tex_font_name(k),tex_font_area(k),"");
+flush_string; flush_string;
+if font_size(k)<>font_dsize(k) then
+ begin print(" at "); print_scaled(font_size(k)); print("pt");
+ end;
+end
+
+@ @<Undump the array info for internal font number |k|@>=
+begin undump_font(k);@/
+end
+
+@ @<Dump the active ocp information@>=
+dump_int(active_min_ptr);
+dump_int(active_max_ptr);
+for k:=0 to active_max_ptr-1 do dump_wd(active_info[k]);
+if active_max_ptr>0 then begin
+ print_ln; print_int(active_max_ptr); print(" words of active ocps");
+ end;
+
+@ @<Undump the active ocp information@>=
+undump_size(0)(active_mem_size)('active start point')(active_min_ptr);
+undump_size(0)(active_mem_size)('active mem size')(active_max_ptr);
+for k:=0 to active_max_ptr-1 do undump_wd(active_info[k]);
+
+@ @<Dump the ocp information@>=
+dump_int(ocp_ptr);
+for k:=null_ocp to ocp_ptr do
+ @<Dump the array info for internal ocp number |k|@>;
+if ocp_ptr-ocp_base>0 then begin
+ print_ln; print_int(ocp_ptr-ocp_base); print(" preloaded ocp");
+ if ocp_ptr<>ocp_base+1 then print_char("s");
+ end
+
+@ @<Undump the ocp information@>=
+undump_size(ocp_base)(ocp_biggest)('ocp max')(ocp_ptr);
+for k:=null_ocp to ocp_ptr do
+ @<Undump the array info for internal ocp number |k|@>
+
+@ @<Dump the array info for internal ocp number |k|@>=
+begin dump_ocp_table(k);
+if ocp_ptr-ocp_base>0 then begin
+ print_nl("\ocp"); print_esc(ocp_id_text(k)); print_char("=");
+ print_file_name(ocp_name(k),ocp_area(k),"");
+ end;
+end
+
+@ @<Undump the array info for internal ocp number |k|@>=
+begin undump_ocp_table(k);
+end
+
+@ @<Dump the ocp list information@>=
+dump_int(ocp_listmem_ptr);
+for k:=0 to ocp_listmem_ptr-1 do dump_wd(ocp_list_info[k]);
+dump_int(ocp_list_ptr);
+for k:=null_ocp_list to ocp_list_ptr do begin
+ dump_int(ocp_list_list[k]);
+ if null_ocp_list<>ocp_list_ptr then begin
+ print_nl("\ocplist");
+ print_esc(ocp_list_id_text(k));
+ print_char("=");
+ print_ocp_list(ocp_list_list[k]);
+ end;
+ end;
+dump_int(ocp_lstackmem_ptr);
+for k:=0 to ocp_lstackmem_ptr-1 do dump_wd(ocp_lstack_info[k])
+
+@ @<Undump the ocp list information@>=
+undump_size(1)(1000000)('ocp list mem size')(ocp_listmem_ptr);
+for k:=0 to ocp_listmem_ptr-1 do undump_wd(ocp_list_info[k]);
+undump_size(ocp_list_base)(ocp_list_biggest)('ocp list max')(ocp_list_ptr);
+for k:=null_ocp_list to ocp_list_ptr do
+ undump_int(ocp_list_list[k]);
+undump_size(1)(1000000)('ocp lstack mem size')(ocp_lstackmem_ptr);
+for k:=0 to ocp_lstackmem_ptr-1 do undump_wd(ocp_lstack_info[k])
+
+@ This is done in C
+
+@<Dump the hyphenation tables@>=
+dump_language_data
+
+@ @<Undump the hyphenation tables@>=
+undump_language_data
+
+@ This is also done in C
+
+@<Dump the lua bytecodes@>=
+dump_luac_registers;
+
+@ @<Undump the lua bytecodes@>=
+undump_luac_registers;
+
+@ We have already printed a lot of statistics, so we set |tracing_stats:=0|
+to prevent them from appearing again.
+
+@<Dump a couple more things and the closing check word@>=
+dump_int(interaction); dump_int(format_ident); dump_int(format_name); dump_int(69069);
+tracing_stats:=0
+
+@ @<Undump a couple more things and the closing check word@>=
+undump(batch_mode)(error_stop_mode)(interaction);
+undump(0)(str_ptr)(format_ident);
+undump(0)(str_ptr)(format_name);
+undump_int(x);
+if (x<>69069)or eof(fmt_file) then goto bad_fmt
+
+@ @<Create the |format_ident|...@>=
+selector:=new_string;
+print(" (preloaded format="); print(job_name); print_char(" ");
+print_int(year); print_char(".");
+print_int(month); print_char("."); print_int(day); print_char(")");
+str_room(2);
+format_ident:=make_string;
+print(job_name);
+format_name:=make_string;
+if interaction=batch_mode then selector:=log_only
+else selector:=term_and_log;
+pack_job_name(format_extension);
+while not w_open_out(fmt_file) do
+ prompt_file_name("format file name",format_extension);
+print_nl("Beginning to dump on file ");
+@.Beginning to dump...@>
+slow_print(w_make_name_string(fmt_file)); flush_string;
+print_nl(""); slow_print(format_ident)
+
+@ @<Close the format file@>=
+w_close(fmt_file)
+
+@* \[51] The main program.
+This is it: the part of \TeX\ that executes all those procedures we have
+written.
+
+Well---almost. Let's leave space for a few more routines that we may
+have forgotten.
+
+@p @<Last-minute procedures@>
+
+@ We have noted that there are two versions of \TeX82. One, called \.{INITEX},
+@.INITEX@>
+has to be run first; it initializes everything from scratch, without
+reading a format file, and it has the capability of dumping a format file.
+The other one is called `\.{VIRTEX}'; it is a ``virgin'' program that needs
+@.VIRTEX@>
+to input a format file in order to get started. \.{VIRTEX} typically has
+more memory capacity than \.{INITEX}, because it does not need the space
+consumed by the auxiliary hyphenation tables and the numerous calls on
+|primitive|, etc.
+
+The \.{VIRTEX} program cannot read a format file instantaneously, of course;
+the best implementations therefore allow for production versions of \TeX\ that
+not only avoid the loading routine for \PASCAL\ object code, they also have
+a format file pre-loaded. This is impossible to do if we stick to standard
+\PASCAL; but there is a simple way to fool many systems into avoiding the
+initialization, as follows:\quad(1)~We declare a global integer variable
+called |ready_already|. The probability is negligible that this
+variable holds any particular value like 314159 when \.{VIRTEX} is first
+loaded.\quad(2)~After we have read in a format file and initialized
+everything, we set |ready_already:=314159|.\quad(3)~Soon \.{VIRTEX}
+will print `\.*', waiting for more input; and at this point we
+interrupt the program and save its core image in some form that the
+operating system can reload speedily.\quad(4)~When that core image is
+activated, the program starts again at the beginning; but now
+|ready_already=314159| and all the other global variables have
+their initial values too. The former chastity has vanished!
+
+In other words, if we allow ourselves to test the condition
+|ready_already=314159|, before |ready_already| has been
+assigned a value, we can avoid the lengthy initialization. Dirty tricks
+rarely pay off so handsomely.
+@^dirty \PASCAL@>
+@^system dependencies@>
+
+On systems that allow such preloading, the standard program called \.{TeX}
+should be the one that has \.{plain} format preloaded, since that agrees
+with {\sl The \TeX book}. Other versions, e.g., \.{AmSTeX}, should also
+@:TeXbook}{\sl The \TeX book@>
+@.AmSTeX@>
+@.plain@>
+be provided for commonly used formats.
+
+@<Glob...@>=
+@!ready_already:integer; {a sacrifice of purity for economy}
+
+@ Now this is really it: \TeX\ starts and ends here.
+
+The initial test involving |ready_already| should be deleted if the
+\PASCAL\ runtime system is smart enough to detect such a ``mistake.''
+@^system dependencies@>
+
+@p begin @!{|start_here|}
+history:=fatal_error_stop; {in case we quit during initialization}
+t_open_out; {open the terminal for output}
+if ready_already=314159 then goto start_of_TEX;
+@<Check the ``constant'' values...@>@;
+if bad>0 then
+ begin wterm_ln('Ouch---my internal constants have been clobbered!',
+ '---case ',bad:1);
+@.Ouch...clobbered@>
+ goto final_end;
+ end;
+initialize; {set global variables to their starting values}
+@!init if not get_strings_started then goto final_end;
+init_prim; {call |primitive| for each primitive}
+init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr; fix_date_and_time;
+tini@/
+ready_already:=314159;
+start_of_TEX: @<Initialize the output routines@>;
+@<Get the first line of input and prepare to start@>;
+history:=spotless; {ready to go!}
+main_control; {come to life}
+final_cleanup; {prepare for death}
+end_of_TEX: close_files_and_terminate;
+final_end: ready_already:=0;
+end.
+
+@ Put this in a function because two extra variables are needed
+for callback testing, and putting those inside the main body is
+ugly
+
+@<Basic print...@>=
+procedure print_banner;
+var res:boolean;
+ callback_id:integer;
+begin
+callback_id:=callback_defined(start_run_callback);
+if callback_id=0 then begin
+ wterm(banner);
+ if format_ident=0 then wterm_ln(' (no format preloaded)')
+ else begin slow_print(format_ident); print_ln;
+ end;
+ end
+else
+ res:= run_callback(callback_id,'->');
+update_terminal;
+end;
+@#
+procedure print_version_banner;
+begin
+wterm(banner);
+end;
+
+
+@ Here we do whatever is needed to complete \TeX's job gracefully on the
+local operating system. The code here might come into play after a fatal
+error; it must therefore consist entirely of ``safe'' operations that
+cannot produce error messages. For example, it would be a mistake to call
+|str_room| or |make_string| at this time, because a call on |overflow|
+might lead to an infinite loop.
+@^system dependencies@>
+
+Actually there's one way to get error messages, via |prepare_mag|;
+but that can't cause infinite recursion.
+@^recursion@>
+
+This program doesn't bother to close the input files that may still be open.
+
+@<Last-minute...@>=
+procedure close_files_and_terminate;
+label done, done1;
+var a, b, c, i, j, k, l: integer; {all-purpose index}
+ is_root: boolean; {|pdf_last_pages| is root of Pages tree?}
+ is_names: boolean; {flag for name tree output: is it Names or Kids?}
+ root, outlines, threads, names_tree, dests: integer;
+ xref_offset_width, names_head, names_tail: integer;
+ callback_id:integer;
+ res:boolean;
+begin
+callback_id:=callback_defined(stop_run_callback);
+@<Finish the extensions@>;
+@!stat if tracing_stats>0 then
+ if callback_id=0 then @<Output statistics about this job@>;@;@+tats@/
+wake_up_terminal;
+if not fixed_pdfoutput_set then
+ fix_pdfoutput;
+if fixed_pdfoutput > 0 then begin
+ if history = fatal_error_stop then begin
+ remove_pdffile;
+ print_err(" ==> Fatal error occurred, no output PDF file produced!")
+ end
+ else begin
+ @<Finish the PDF file@>;
+ if callback_id=0 then begin
+ if log_opened then
+ begin wlog_cr;
+ wlog_ln('PDF statistics:');
+ wlog_ln(' ',obj_ptr:1,' PDF objects out of ',obj_tab_size:1,
+ ' (max. ',sup_obj_tab_size:1,')');
+ if pdf_os_cntr > 0 then begin
+ wlog(' ',((pdf_os_cntr - 1) * pdf_os_max_objs + pdf_os_objidx + 1):1,
+ ' compressed objects within ',pdf_os_cntr:1,' object stream');
+ if pdf_os_cntr > 1 then
+ wlog('s');
+ wlog_cr;
+ end;
+ wlog_ln(' ',pdf_dest_names_ptr:1,' named destinations out of ',dest_names_size:1,
+ ' (max. ',sup_dest_names_size:1,')');
+ wlog_ln(' ',pdf_mem_ptr:1,' words of extra memory for PDF output out of ',pdf_mem_size:1,
+ ' (max. ',sup_pdf_mem_size:1,')');
+ end;
+ end;
+ end;
+end
+else begin
+ @<Finish the \.{DVI} file@>;
+end;
+if log_opened then
+ begin wlog_cr; selector:=selector-2;
+ if (selector=term_only)and(callback_id=0) then begin
+ print_nl("Transcript written on ");
+@.Transcript written...@>
+ slow_print(log_name); print_char(".");
+ end;
+ lua_a_close_out(log_file);
+ end;
+end;
+
+@ The present section goes directly to the log file instead of using
+|print| commands, because there's no need for these strings to take
+up |str_pool| memory when a non-{\bf stat} version of \TeX\ is being used.
+
+@<Output statistics...@>=
+if log_opened then
+ begin wlog_ln(' ');
+ wlog_ln('Here is how much of TeX''s memory',' you used:');
+@.Here is how much...@>
+ wlog(' ',str_ptr-init_str_ptr:1,' string');
+ if str_ptr<>init_str_ptr+1 then wlog('s');
+ wlog_ln(' out of ', max_strings-init_str_ptr+string_offset:1);@/
+ wlog_ln(' ',pool_ptr-init_pool_ptr:1,' string characters out of ',
+ pool_size-init_pool_ptr:1);@/
+ wlog_ln(' ',var_mem_max:1,',',fix_mem_max:1,@|
+ ' words of node,token memory allocated');@/
+ print_node_mem_stats(tracing_stats, tracing_online);
+ wlog_ln(' ',cs_count:1,' multiletter control sequences out of ',
+ hash_size:1);@/
+ wlog(' ',max_font_id,' font');
+ if max_font_id<>1 then wlog('s');
+ wlog_ln(' using ', font_bytes:1, ' bytes');
+ wlog_ln(' ',max_in_stack:1,'i,',max_nest_stack:1,'n,',@|
+ max_param_stack:1,'p,',@|
+ max_buf_stack+1:1,'b,',@|
+ max_save_stack+6:1,'s stack positions out of ',@|
+ stack_size:1,'i,',
+ nest_size:1,'n,',
+ param_size:1,'p,',
+ buf_size:1,'b,',
+ save_size:1,'s');
+ end
+
+@ We get to the |final_cleanup| routine when \.{\\end} or \.{\\dump} has
+been scanned and |its_all_over|\kern-2pt.
+
+@<Last-minute...@>=
+procedure final_cleanup;
+label exit;
+var c:small_number; {0 for \.{\\end}, 1 for \.{\\dump}}
+i:halfword; { for looping marks }
+begin c:=cur_chr;
+if job_name=0 then open_log_file;
+while input_ptr>0 do
+ if state=token_list then end_token_list@+else end_file_reading;
+while open_parens>0 do
+ begin
+ if tracefilenames then print(" )");
+ decr(open_parens);
+ end;
+if cur_level>level_one then
+ begin print_nl("("); print_esc("end occurred ");
+ print("inside a group at level ");
+@:end_}{\.{(\\end occurred...)}@>
+ print_int(cur_level-level_one); print_char(")");
+ show_save_groups;
+ end;
+while cond_ptr<>null do
+ begin print_nl("("); print_esc("end occurred ");
+ print("when "); print_cmd_chr(if_test,cur_if);
+ if if_line<>0 then
+ begin print(" on line "); print_int(if_line);
+ end;
+ print(" was incomplete)");
+ if_line:=if_line_field(cond_ptr);
+ cur_if:=subtype(cond_ptr); temp_ptr:=cond_ptr;
+ cond_ptr:=vlink(cond_ptr); flush_node(temp_ptr);
+ end;
+if not callback_defined(stop_run_callback) then
+ if history<>spotless then
+ if ((history=warning_issued)or(interaction<error_stop_mode)) then
+ if selector=term_and_log then
+ begin selector:=term_only;
+ print_nl("(see the transcript file for additional information)");
+@.see the transcript file...@>
+ selector:=term_and_log;
+ end;
+if c=1 then
+ begin @!init for i:=0 to biggest_used_mark do begin
+ delete_top_mark(i); delete_first_mark(i); delete_bot_mark(i);
+ delete_split_first_mark(i); delete_split_bot_mark(i);
+ end;
+ for c:=last_box_code to vsplit_code do flush_node_list(disc_ptr[c]);
+ @<Close the pseudo files@>;
+ store_fmt_file; return;@+tini@/
+ print_nl("(\dump is performed only by INITEX)"); return;
+@:dump_}{\.{\\dump...only by INITEX}@>
+ end;
+exit:end;
+
+@ @<Last-minute...@>=
+@!init procedure init_prim; {initialize all the primitives}
+begin no_new_control_sequence:=false;
+first:=0;
+@<Put each...@>;
+no_new_control_sequence:=true;
+end;
+tini
+
+@ When we begin the following code, \TeX's tables may still contain garbage;
+the strings might not even be present. Thus we must proceed cautiously to get
+bootstrapped in.
+
+But when we finish this part of the program, \TeX\ is ready to call on the
+|main_control| routine to do its work.
+
+@<Get the first line...@>=
+begin @<Initialize the input routines@>;
+@<Enable \eTeX, if requested@>@;@/
+if (format_ident=0)or(buffer[loc]="&") then
+ begin if format_ident<>0 then initialize; {erase preloaded format}
+ if not open_fmt_file then goto final_end;
+ if not load_fmt_file then
+ begin w_close(fmt_file); goto final_end;
+ end;
+ w_close(fmt_file);
+ while (loc<limit)and(buffer[loc]=" ") do incr(loc);
+ end;
+if (pdf_output_option <> 0) then pdf_output := pdf_output_value;
+if (pdf_draftmode_option <> 0) then pdf_draftmode := pdf_draftmode_value;
+pdf_init_map_file('pdftex.map');
+if false then wterm_ln('entering extended mode');
+if end_line_char_inactive then decr(limit)
+else buffer[limit]:=end_line_char;
+fix_date_and_time;@/
+random_seed :=(microseconds*1000)+(epochseconds mod 1000000);@/
+init_randoms(random_seed);@/
+@<Compute the magic offset@>;
+@<Initialize the print |selector|...@>;
+if (loc<limit)and(get_cat_code(cat_code_table,buffer[loc])<>escape) then start_input;
+ {\.{\\input} assumed}
+@<DIR: Initialize |text_dir_ptr|@>;
+end
+
+@* \[52] Debugging.
+Once \TeX\ is working, you should be able to diagnose most errors with
+the \.{\\show} commands and other diagnostic features. But for the initial
+stages of debugging, and for the revelation of really deep mysteries, you
+can compile \TeX\ with a few more aids, including the \PASCAL\ runtime
+checks and its debugger. An additional routine called |debug_help|
+will also come into play when you type `\.D' after an error message;
+|debug_help| also occurs just before a fatal error causes \TeX\ to succumb.
+@^debugging@>
+@^system dependencies@>
+
+The interface to |debug_help| is primitive, but it is good enough when used
+with a \PASCAL\ debugger that allows you to set breakpoints and to read
+variables and change their values. After getting the prompt `\.{debug \#}', you
+type either a negative number (this exits |debug_help|), or zero (this
+goes to a location where you can set a breakpoint, thereby entering into
+dialog with the \PASCAL\ debugger), or a positive number |m| followed by
+an argument |n|. The meaning of |m| and |n| will be clear from the
+program below. (If |m=13|, there is an additional argument, |l|.)
+@.debug \#@>
+
+@d breakpoint=888 {place where a breakpoint is desirable}
+
+@<Last-minute...@>=
+@!debug procedure debug_help; {routine to display various things}
+label breakpoint,exit;
+var k,@!l,@!m,@!n:integer;
+begin loop begin wake_up_terminal;
+ print_nl("debug # (-1 to exit):"); update_terminal;
+@.debug \#@>
+ read(term_in,m);
+ if m<0 then return
+ else if m=0 then
+ begin goto breakpoint;@\ {go to every label at least once}
+ breakpoint: m:=0; @{'BREAKPOINT'@}@\
+ end
+ else begin read(term_in,n);
+ case m of
+ @t\4@>@<Numbered cases for |debug_help|@>@;
+ othercases print("?")
+ endcases;
+ end;
+ end;
+exit:end;
+gubed
+
+@ @<Numbered cases...@>=
+1: print_word(mem(n)); {display |mem[n]| in all forms}
+2: print_int(info(n));
+3: print_int(link(n));
+4: print_word(eqtb[n]);
+5: ;
+6: print_word(save_stack[n]);
+7: show_box(n);
+ {show a box, abbreviated by |show_box_depth| and |show_box_breadth|}
+8: begin breadth_max:=10000; depth_threshold:=pool_size-pool_ptr-10;
+ show_node_list(n); {show a box in its entirety}
+ end;
+9: show_token_list(n,null,1000);
+10: slow_print(n);
+13: begin read(term_in,l); print_cmd_chr(n,l);
+ end;
+14: for k:=0 to n do print(buffer[k]);
+15: begin font_in_short_display:=null_font; short_display(n);
+ end;
+
+@* \[53] Extensions.
+The program above includes a bunch of ``hooks'' that allow further
+capabilities to be added without upsetting \TeX's basic structure.
+Most of these hooks are concerned with ``whatsit'' nodes, which are
+intended to be used for special purposes; whenever a new extension to
+\TeX\ involves a new kind of whatsit node, a corresponding change needs
+to be made to the routines below that deal with such nodes,
+but it will usually be unnecessary to make many changes to the
+other parts of this program.
+
+In order to demonstrate how extensions can be made, we shall treat
+`\.{\\write}', `\.{\\openout}', `\.{\\closeout}', `\.{\\immediate}',
+and `\.{\\special}' as if they were extensions.
+These commands are actually primitives of \TeX, and they should
+appear in all implementations of the system; but let's try to imagine
+that they aren't. Then the program below illustrates how a person
+could add them.
+
+Sometimes, of course, an extension will require changes to \TeX\ itself;
+no system of hooks could be complete enough for all conceivable extensions.
+The features associated with `\.{\\write}' are almost all confined to the
+following paragraphs, but there are small parts of the |print_ln| and
+|print_char| procedures that were introduced specifically to \.{\\write}
+characters. Furthermore one of the token lists recognized by the scanner
+is a |write_text|; and there are a few other miscellaneous places where we
+have already provided for some aspect of \.{\\write}. The goal of a \TeX\
+extender should be to minimize alterations to the standard parts of the
+program, and to avoid them completely if possible. He or she should also
+be quite sure that there's no easy way to accomplish the desired goals
+with the standard features that \TeX\ already has. ``Think thrice before
+extending,'' because that may save a lot of work, and it will also keep
+incompatible extensions of \TeX\ from proliferating.
+@^system dependencies@>
+@^extensions to \TeX@>
+
+@ First let's consider the format of whatsit nodes that are used to represent
+the data associated with \.{\\write} and its relatives. Recall that a whatsit
+has |type=whatsit_node|, and the |subtype| is supposed to distinguish
+different kinds of whatsits. Each node occupies two or more words; the
+exact number is immaterial, as long as it is readily determined from the
+|subtype| or other data.
+
+We shall introduce five |subtype| values here, corresponding to the
+control sequences \.{\\openout}, \.{\\write}, \.{\\closeout}, and \.{\\special}.
+The second word of I/O whatsits has a |write_stream| field
+that identifies the write-stream number (0 to 15, or 16 for out-of-range and
+positive, or 17 for out-of-range and negative).
+In the case of \.{\\write} and \.{\\special}, there is also a field that
+points to the reference count of a token list that should be sent. In the
+case of \.{\\openout}, we need three words and three auxiliary subfields
+to hold the string numbers for name, area, and extension.
+
+@d open_node=0 {|subtype| in whatsits that represent files to \.{\\openout}}
+@d open_node_size==4 {number of words in an open/whatsit node}
+@d write_node=1 {|subtype| in whatsits that represent things to \.{\\write}}
+@d write_node_size==3 {number of words in a write/whatsit node}
+@d close_node=2 {|subtype| in whatsits that represent streams to \.{\\closeout}}
+@d close_node_size==3 {number of words in a write/whatsit node}
+@d special_node=3 {|subtype| in whatsits that represent \.{\\special} things}
+@d special_node_size==3 {number of words in a write/whatsit node}
+@d dir_node_size=4 {number of words in change direction node}
+@d dir_dir(#)==vinfo(#+2) {keep the direction to be taken}
+@d dir_level(#)==vlink(#+2) {the save level at which the direction was defined}
+@d dir_dvi_ptr(#)==vinfo(#+3) {for reflecting dvi output}
+@d dir_dvi_h(#)==vlink(#+3) {for reflecting dvi output}
+@d what_lang(#)==vlink(#+2) {language number, in the range |0..255|}
+@d what_lhm(#)==type(#+2) {minimum left fragment, in the range |1..63|}
+@d what_rhm(#)==subtype(#+2) {minimum right fragment, in the range |1..63|}
+@d write_tokens(#) == vlink(#+2) {reference count of token list to write}
+@d write_stream(#) == vinfo(#+2) {stream number (0 to 17)}
+@d open_name(#) == vlink(#+2) {string number of file name to open}
+@d open_area(#) == vinfo(#+3) {string number of file area for |open_name|}
+@d open_ext(#) == vlink(#+3) {string number of file extension for |open_name|}
+
+@ The sixteen possible \.{\\write} streams are represented by the |write_file|
+array. The |j|th file is open if and only if |write_open[j]=true|. The last
+two streams are special; |write_open[16]| represents a stream number
+greater than 15, while |write_open[17]| represents a negative stream number,
+and both of these variables are always |false|.
+
+@<Glob...@>=
+@!write_file:array[0..15] of alpha_file;
+@!write_file_mode:array[0..15] of halfword;
+@!write_file_translation:array[0..15] of halfword;
+@!write_open:array[0..17] of boolean;
+@!neg_wd:scaled;
+@!pos_wd:scaled;
+@!neg_ht:scaled;
+@!dvi_direction:integer;
+@!dir_primary:array[0..31] of 0..31;
+@!dir_secondary:array[0..31] of 0..31;
+@!dir_tertiary:array[0..31] of 0..31;
+@!dir_rearrange:array[0..3] of 0..31;
+@!dir_names:array[0..3] of str_number;
+@!text_dir_ptr:pointer;
+@!text_dir_tmp:pointer;
+
+@
+@<Set init...@>=
+for k:=0 to 17 do write_open[k]:=false;
+pack_direction:=-1;
+for k:= 0 to 7 do begin
+ dir_primary [k ]:=dir_T;
+ dir_primary [k+ 8]:=dir_L;
+ dir_primary [k+16]:=dir_B;
+ dir_primary [k+24]:=dir_R;
+ end;
+for k:= 0 to 3 do begin
+ dir_secondary[k ]:=dir_L;
+ dir_secondary[k+ 4]:=dir_R;
+ dir_secondary[k+ 8]:=dir_T;
+ dir_secondary[k+12]:=dir_B;
+
+ dir_secondary[k+16]:=dir_L;
+ dir_secondary[k+20]:=dir_R;
+ dir_secondary[k+24]:=dir_T;
+ dir_secondary[k+28]:=dir_B;
+ end;
+for k:=0 to 7 do begin
+ dir_tertiary[k*4 ]:=dir_T;
+ dir_tertiary[k*4+1]:=dir_L;
+ dir_tertiary[k*4+2]:=dir_B;
+ dir_tertiary[k*4+3]:=dir_R;
+ end;
+dir_rearrange[0]:=0;
+dir_rearrange[1]:=0;
+dir_rearrange[2]:=1;
+dir_rearrange[3]:=1;
+dir_names[0]:="T";
+dir_names[1]:="L";
+dir_names[2]:="B";
+dir_names[3]:="R";
+
+@ Extensions might introduce new command codes; but it's best to use
+|extension| with a modifier, whenever possible, so that |main_control|
+stays the same.
+
+@d immediate_code=4 {command modifier for \.{\\immediate}}
+@d local_par_node==6 {|subtype| in whatsits for local paragraph node}
+{|local_par_node| has to be a macro, not numeric }
+@d dir_node=7 {|subtype| in whatsits for change direction node}
+@d pdftex_first_extension_code = 8
+@d pdf_literal_node == pdftex_first_extension_code + 0
+@d pdf_obj_code == pdftex_first_extension_code + 1
+@d pdf_refobj_node == pdftex_first_extension_code + 2
+@d pdf_xform_code == pdftex_first_extension_code + 3
+@d pdf_refxform_node == pdftex_first_extension_code + 4
+@d pdf_ximage_code == pdftex_first_extension_code + 5
+@d pdf_refximage_node == pdftex_first_extension_code + 6
+@d pdf_annot_node == pdftex_first_extension_code + 7
+@d pdf_start_link_node == pdftex_first_extension_code + 8
+@d pdf_end_link_node == pdftex_first_extension_code + 9
+@d pdf_end_link_node_size==3
+@d pdf_outline_code == pdftex_first_extension_code + 10
+@d pdf_dest_node == pdftex_first_extension_code + 11
+@d pdf_thread_node == pdftex_first_extension_code + 12
+@d pdf_start_thread_node == pdftex_first_extension_code + 13
+@d pdf_end_thread_node == pdftex_first_extension_code + 14
+@d pdf_end_thread_node_size==3
+@d pdf_save_pos_node == pdftex_first_extension_code + 15
+@d pdf_save_pos_node_size==3
+@d pdf_info_code == pdftex_first_extension_code + 16
+@d pdf_thread_data_node == pdftex_first_extension_code + 16
+@d pdf_catalog_code == pdftex_first_extension_code + 17
+@d pdf_link_data_node == pdftex_first_extension_code + 17
+@d pdf_names_code == pdftex_first_extension_code + 18
+@d pdf_font_attr_code == pdftex_first_extension_code + 19
+@d pdf_include_chars_code == pdftex_first_extension_code + 20
+@d pdf_map_file_code == pdftex_first_extension_code + 21
+@d pdf_map_line_code == pdftex_first_extension_code + 22
+@d pdf_trailer_code == pdftex_first_extension_code + 23
+@d pdf_font_expand_code == pdftex_first_extension_code + 24
+@d set_random_seed_code == pdftex_first_extension_code + 25
+@d pdf_glyph_to_unicode_code == pdftex_first_extension_code + 26
+@d late_lua_node == pdftex_first_extension_code + 27
+@d close_lua_node == pdftex_first_extension_code + 28
+@d save_cat_code_table_code == pdftex_first_extension_code + 29
+@d init_cat_code_table_code == pdftex_first_extension_code + 30
+@d pdf_colorstack_node == pdftex_first_extension_code + 31
+@d pdf_setmatrix_node == pdftex_first_extension_code + 32
+@d pdf_save_node == pdftex_first_extension_code + 33
+@d pdf_restore_node == pdftex_first_extension_code + 34
+@d pdftex_last_extension_code == pdftex_first_extension_code + 34
+
+@<Put each...@>=
+primitive("openout",extension,open_node);@/
+@!@:open_out_}{\.{\\openout} primitive@>
+primitive("write",extension,write_node); write_loc:=cur_val;@/
+@!@:write_}{\.{\\write} primitive@>
+primitive("closeout",extension,close_node);@/
+@!@:close_out_}{\.{\\closeout} primitive@>
+primitive("special",extension,special_node);@/
+@!@:special_}{\.{\\special} primitive@>
+primitive("immediate",extension,immediate_code);@/
+@!@:immediate_}{\.{\\immediate} primitive@>
+primitive("localinterlinepenalty",assign_int,local_inter_line_penalty_code);@/
+primitive("localbrokenpenalty",assign_int,local_broken_penalty_code);@/
+primitive("pagedir",assign_dir,dir_base+page_direction_code);@/
+primitive("bodydir",assign_dir,dir_base+body_direction_code);@/
+primitive("pardir",assign_dir,dir_base+par_direction_code);@/
+primitive("textdir",assign_dir,dir_base+text_direction_code);@/
+primitive("mathdir",assign_dir,dir_base+math_direction_code);@/
+primitive("pagerightoffset",assign_dimen,dimen_base+page_right_offset_code);
+primitive("pagebottomoffset",assign_dimen,dimen_base+page_bottom_offset_code);
+primitive("pdfliteral",extension,pdf_literal_node);@/
+@!@:pdf_literal_}{\.{\\pdfliteral} primitive@>
+primitive("pdfcolorstack",extension,pdf_colorstack_node);@/
+@!@:pdf_colorstack_}{\.{\\pdfcolorstack} primitive@>
+primitive("pdfsetmatrix",extension,pdf_setmatrix_node);@/
+@!@:pdf_setmatrix_}{\.{\\pdfsetmatrix} primitive@>
+primitive("pdfsave",extension,pdf_save_node);@/
+@!@:pdf_save_}{\.{\\pdfsave} primitive@>
+primitive("pdfrestore",extension,pdf_restore_node);@/
+@!@:pdf_restore_}{\.{\\pdfrestore} primitive@>
+primitive("pdfobj",extension,pdf_obj_code);@/
+@!@:pdf_obj_}{\.{\\pdfobj} primitive@>
+primitive("pdfrefobj",extension,pdf_refobj_node);@/
+@!@:pdf_refobj_}{\.{\\pdfrefobj} primitive@>
+primitive("pdfxform",extension,pdf_xform_code);@/
+@!@:pdf_xform_}{\.{\\pdfxform} primitive@>
+primitive("pdfrefxform",extension,pdf_refxform_node);@/
+@!@:pdf_refxform_}{\.{\\pdfrefxform} primitive@>
+primitive("pdfximage",extension,pdf_ximage_code);@/
+@!@:pdf_ximage_}{\.{\\pdfximage} primitive@>
+primitive("pdfrefximage",extension,pdf_refximage_node);@/
+@!@:pdf_refximage_}{\.{\\pdfrefximage} primitive@>
+primitive("pdfannot",extension,pdf_annot_node);@/
+@!@:pdf_annot_}{\.{\\pdfannot} primitive@>
+primitive("pdfstartlink",extension,pdf_start_link_node);@/
+@!@:pdf_start_link_}{\.{\\pdfstartlink} primitive@>
+primitive("pdfendlink",extension,pdf_end_link_node);@/
+@!@:pdf_end_link_}{\.{\\pdfendlink} primitive@>
+primitive("pdfoutline",extension,pdf_outline_code);@/
+@!@:pdf_outline_}{\.{\\pdfoutline} primitive@>
+primitive("pdfdest",extension,pdf_dest_node);@/
+@!@:pdf_dest_}{\.{\\pdfdest} primitive@>
+primitive("pdfthread",extension,pdf_thread_node);@/
+@!@:pdf_thread_}{\.{\\pdfthread} primitive@>
+primitive("pdfstartthread",extension,pdf_start_thread_node);@/
+@!@:pdf_start_thread_}{\.{\\pdfstartthread} primitive@>
+primitive("pdfendthread",extension,pdf_end_thread_node);@/
+@!@:pdf_end_thread_}{\.{\\pdfendthread} primitive@>
+primitive("pdfsavepos",extension,pdf_save_pos_node);@/
+@!@:pdf_save_pos_}{\.{\\pdfsavepos} primitive@>
+primitive("pdfinfo",extension,pdf_info_code);@/
+@!@:pdf_info_}{\.{\\pdfinfo} primitive@>
+primitive("pdfcatalog",extension,pdf_catalog_code);@/
+@!@:pdf_catalog_}{\.{\\pdfcatalog} primitive@>
+primitive("pdfnames",extension,pdf_names_code);@/
+@!@:pdf_names_}{\.{\\pdfnames} primitive@>
+primitive("pdfincludechars",extension,pdf_include_chars_code);@/
+@!@:pdf_include_chars_}{\.{\\pdfincludechars} primitive@>
+primitive("pdffontattr",extension,pdf_font_attr_code);@/
+@!@:pdf_font_attr_}{\.{\\pdffontattr} primitive@>
+primitive("pdfmapfile",extension,pdf_map_file_code);@/
+@!@:pdf_map_file_}{\.{\\pdfmapfile} primitive@>
+primitive("pdfmapline",extension,pdf_map_line_code);@/
+@!@:pdf_map_line_}{\.{\\pdfmapline} primitive@>
+primitive("pdftrailer",extension,pdf_trailer_code);@/
+@!@:pdf_trailer_}{\.{\\pdftrailer} primitive@>
+primitive("savecatcodetable",extension,save_cat_code_table_code);@/
+@!@:save_cat_code_table_}{\.{\\savecatcodetable} primitive@>
+primitive("initcatcodetable",extension,init_cat_code_table_code);@/
+@!@:init_cat_code_table_}{\.{\\initcatcodetable} primitive@>
+primitive("pdfsetrandomseed",extension,set_random_seed_code);@/
+@!@:set_random_seed_code}{\.{\\pdfsetrandomseed} primitive@>
+primitive("latelua",extension,late_lua_node);@/
+@!@:late_lua_node_}{\.{\\latelua} primitive@>
+primitive("closelua",extension,close_lua_node);@/
+@!@:close_lua_node_}{\.{\\closelua} primitive@>
+primitive("pdffontexpand",extension,pdf_font_expand_code);@/
+@!@:pdf_font_expand_}{\.{\\pdffontexpand} primitive@>
+primitive("pdfglyphtounicode",extension,pdf_glyph_to_unicode_code);@/
+@!@:pdf_glyph_to_unicode_}{\.{\\pdfglyphtounicode} primitive@>
+
+@ The variable |write_loc| just introduced is used to provide an
+appropriate error message in case of ``runaway'' write texts.
+
+@<Glob...@>=
+@!write_loc:pointer; {|eqtb| address of \.{\\write}}
+
+@ @<Cases of |print_cmd_chr|...@>=
+extension: case chr_code of
+ open_node:print_esc("openout");
+ write_node:print_esc("write");
+ close_node:print_esc("closeout");
+ special_node:print_esc("special");
+ immediate_code:print_esc("immediate");
+ pdf_annot_node: print_esc("pdfannot");
+ pdf_catalog_code: print_esc("pdfcatalog");
+ pdf_dest_node: print_esc("pdfdest");
+ pdf_end_link_node: print_esc("pdfendlink");
+ pdf_end_thread_node: print_esc("pdfendthread");
+ pdf_font_attr_code: print_esc("pdffontattr");
+ pdf_font_expand_code: print_esc("pdffontexpand");
+ pdf_include_chars_code: print_esc("pdfincludechars");
+ pdf_info_code: print_esc("pdfinfo");
+ pdf_literal_node: print_esc("pdfliteral");
+ pdf_colorstack_node: print_esc("pdfcolorstack");
+ pdf_setmatrix_node: print_esc("pdfsetmatrix");
+ pdf_save_node: print_esc("pdfsave");
+ pdf_restore_node: print_esc("pdfrestore");
+ pdf_map_file_code: print_esc("pdfmapfile");
+ pdf_map_line_code: print_esc("pdfmapline");
+ pdf_names_code: print_esc("pdfnames");
+ pdf_obj_code: print_esc("pdfobj");
+ pdf_outline_code: print_esc("pdfoutline");
+ pdf_refobj_node: print_esc("pdfrefobj");
+ pdf_refxform_node: print_esc("pdfrefxform");
+ pdf_refximage_node: print_esc("pdfrefximage");
+ pdf_save_pos_node: print_esc("pdfsavepos");
+ pdf_start_link_node: print_esc("pdfstartlink");
+ pdf_start_thread_node: print_esc("pdfstartthread");
+ pdf_thread_node: print_esc("pdfthread");
+ pdf_trailer_code: print_esc("pdftrailer");
+ pdf_xform_code: print_esc("pdfxform");
+ pdf_ximage_code: print_esc("pdfximage");
+ save_cat_code_table_code: print_esc("savecatcodetable");
+ init_cat_code_table_code: print_esc("initcatcodetable");
+ set_random_seed_code: print_esc("pdfsetrandomseed");
+ pdf_glyph_to_unicode_code: print_esc("pdfglyphtounicode");
+ late_lua_node: print_esc("latelua");
+ close_lua_node: print_esc("closelua");
+ cancel_boundary_node: print_esc("noboundary");
+ othercases print("[unknown extension!]")
+ endcases;
+
+@ When an |extension| command occurs in |main_control|, in any mode,
+the |do_extension| routine is called.
+
+@<Cases of |main_control| that are for extensions...@>=
+any_mode(extension):do_extension;
+
+@ @<Declare act...@>=
+@t\4@>@<Declare procedures needed in |do_extension|@>@;
+procedure do_extension;
+var i,@!j,@!k:integer; {all-purpose integers}
+@!p,@!q,@!r:pointer; {all-purpose pointers}
+begin case cur_chr of
+ open_node:@<Implement \.{\\openout}@>;
+ write_node:@<Implement \.{\\write}@>;
+ close_node:@<Implement \.{\\closeout}@>;
+ special_node:@<Implement \.{\\special}@>;
+ immediate_code:@<Implement \.{\\immediate}@>;
+ pdf_annot_node: @<Implement \.{\\pdfannot}@>;
+ pdf_catalog_code: @<Implement \.{\\pdfcatalog}@>;
+ pdf_dest_node: @<Implement \.{\\pdfdest}@>;
+ pdf_end_link_node: @<Implement \.{\\pdfendlink}@>;
+ pdf_end_thread_node: @<Implement \.{\\pdfendthread}@>;
+ pdf_font_attr_code: @<Implement \.{\\pdffontattr}@>;
+ pdf_font_expand_code: @<Implement \.{\\pdffontexpand}@>;
+ pdf_include_chars_code: @<Implement \.{\\pdfincludechars}@>;
+ pdf_info_code: @<Implement \.{\\pdfinfo}@>;
+ pdf_literal_node: @<Implement \.{\\pdfliteral}@>;
+ pdf_colorstack_node: @<Implement \.{\\pdfcolorstack}@>;
+ pdf_setmatrix_node: @<Implement \.{\\pdfsetmatrix}@>;
+ pdf_save_node: @<Implement \.{\\pdfsave}@>;
+ pdf_restore_node: @<Implement \.{\\pdfrestore}@>;
+ pdf_map_file_code: @<Implement \.{\\pdfmapfile}@>;
+ pdf_map_line_code: @<Implement \.{\\pdfmapline}@>;
+ pdf_names_code: @<Implement \.{\\pdfnames}@>;
+ pdf_obj_code: @<Implement \.{\\pdfobj}@>;
+ pdf_outline_code: @<Implement \.{\\pdfoutline}@>;
+ pdf_refobj_node: @<Implement \.{\\pdfrefobj}@>;
+ pdf_refxform_node: @<Implement \.{\\pdfrefxform}@>;
+ pdf_refximage_node: @<Implement \.{\\pdfrefximage}@>;
+ pdf_save_pos_node: @<Implement \.{\\pdfsavepos}@>;
+ pdf_start_link_node: @<Implement \.{\\pdfstartlink}@>;
+ pdf_start_thread_node: @<Implement \.{\\pdfstartthread}@>;
+ pdf_thread_node: @<Implement \.{\\pdfthread}@>;
+ pdf_trailer_code: @<Implement \.{\\pdftrailer}@>;
+ pdf_xform_code: @<Implement \.{\\pdfxform}@>;
+ pdf_ximage_code: @<Implement \.{\\pdfximage}@>;
+ save_cat_code_table_code: @<Implement \.{\\savecatcodetable}@>;
+ init_cat_code_table_code: @<Implement \.{\\initcatcodetable}@>;
+ set_random_seed_code: @<Implement \.{\\pdfsetrandomseed}@>;
+ pdf_glyph_to_unicode_code: @<Implement \.{\\pdfglyphtounicode}@>;
+ late_lua_node: @<Implement \.{\\latelua}@>;
+ close_lua_node: @<Implement \.{\\closelua}@>;
+othercases confusion("ext1")
+@:this can't happen ext1}{\quad ext1@>
+endcases;
+end;
+
+@ Here is a subroutine that creates a whatsit node having a given |subtype|
+and a given number of words. It initializes only the first word of the whatsit,
+and appends it to the current list.
+
+@<Declare procedures needed in |do_extension|@>=
+procedure new_whatsit(@!s:small_number);
+var p:pointer; {the new node}
+begin p:=new_node(whatsit_node,s);
+vlink(tail):=p; tail:=p;
+end;
+
+@ The next subroutine uses |cur_chr| to decide what sort of whatsit is
+involved, and also inserts a |write_stream| number.
+
+@<Declare procedures needed in |do_ext...@>=
+procedure new_write_whatsit(@!w:small_number);
+begin new_whatsit(cur_chr);
+if w<>write_node_size then scan_four_bit_int
+else begin scan_int;
+ if cur_val<0 then cur_val:=17
+ else if cur_val>15 then cur_val:=16;
+ end;
+write_stream(tail):=cur_val;
+end;
+
+@ @<Implement \.{\\openout}@>=
+begin new_write_whatsit(open_node_size);
+scan_optional_equals; scan_file_name;@/
+open_name(tail):=cur_name; open_area(tail):=cur_area; open_ext(tail):=cur_ext;
+end
+
+@ When `\.{\\write 12\{...\}}' appears, we scan the token list `\.{\{...\}}'
+without expanding its macros; the macros will be expanded later when this
+token list is rescanned.
+
+@<Implement \.{\\write}@>=
+begin k:=cur_cs; new_write_whatsit(write_node_size);@/
+cur_cs:=k; p:=scan_toks(false,false); write_tokens(tail):=def_ref;
+end
+
+@ @<Implement \.{\\closeout}@>=
+begin new_write_whatsit(write_node_size); write_tokens(tail):=null;
+end
+
+@ When `\.{\\special\{...\}}' appears, we expand the macros in the token
+list as in \.{\\xdef} and \.{\\mark}.
+
+@<Implement \.{\\special}@>=
+begin new_whatsit(special_node); write_stream(tail):=null;
+p:=scan_toks(false,true); write_tokens(tail):=def_ref;
+end
+
+@ @<Implement \.{\\pdffontexpand}@>=
+ read_expand_font
+
+@ The following macros are needed for further manipulation with whatsit nodes
+for \pdfTeX{} extensions (copying, destroying etc.)
+
+@d add_action_ref(#) == incr(pdf_action_refcount(#)) {increase count of
+references to this action}
+
+@d delete_action_ref(#) == {decrease count of references to this
+action; free it if there is no reference to this action}
+begin
+ if pdf_action_refcount(#) = null then begin
+ if pdf_action_type(#) = pdf_action_user then
+ delete_token_ref(pdf_action_tokens(#))
+ else begin
+ if pdf_action_file(#) <> null then
+ delete_token_ref(pdf_action_file(#));
+ if pdf_action_type(#) = pdf_action_page then
+ delete_token_ref(pdf_action_tokens(#))
+ else if pdf_action_named_id(#) > 0 then
+ delete_token_ref(pdf_action_id(#));
+ end;
+ flush_node(#);
+ end
+ else
+ decr(pdf_action_refcount(#));
+end
+
+@ We have to check whether \.{\\pdfoutput} is set for using \pdfTeX{}
+ extensions.
+@<Declare procedures needed in |do_ext...@>=
+procedure check_pdfoutput(s: str_number; is_error : boolean);
+begin
+ if pdf_output <= 0 then
+ begin
+ if is_error then
+ pdf_error(s, "not allowed in DVI mode (\pdfoutput <= 0)")
+ else
+ pdf_warning(s, "not allowed in DVI mode (\pdfoutput <= 0); ignoring it", true,true);
+ end
+end;
+
+procedure scan_pdf_ext_toks;
+begin
+ call_func(scan_toks(false, true)); {like \.{\\special}}
+end;
+
+@ @<Implement \.{\\pdfliteral}@>=
+begin
+ check_pdfoutput("\pdfliteral", true);
+ new_whatsit(pdf_literal_node);
+ if scan_keyword("direct") then
+ pdf_literal_mode(tail) := direct_always
+ else if scan_keyword("page") then
+ pdf_literal_mode(tail) := direct_page
+ else
+ pdf_literal_mode(tail) := set_origin;
+ scan_pdf_ext_toks;
+ pdf_literal_data(tail) := def_ref;
+end
+
+@ @<Implement \.{\\pdfcolorstack}@>=
+begin
+ check_pdfoutput("\pdfcolorstack", true);
+ {Scan and check the stack number and store in |cur_val|}
+ scan_int;
+ if cur_val >= colorstackused then begin
+ print_err("Unknown color stack number ");
+ print_int(cur_val);
+@.Unknown color stack@>
+ help3("Allocate and initialize a color stack with \\pdfcolorstackinit.")@/
+ ("I'll use default color stack 0 here.")@/
+ ("Proceed, with fingers crossed.");
+ error;
+ cur_val := 0;
+ end;
+ if cur_val < 0 then begin
+ print_err("Invalid negative color stack number");
+@.Invalid negative color stack number@>
+ help2("I'll use default color stack 0 here.")@/
+ ("Proceed, with fingers corssed.");
+ error;
+ cur_val := 0;
+ end;
+ if scan_keyword("set") then begin
+ i := colorstack_set;
+ end
+ else if scan_keyword("push") then begin
+ i := colorstack_push;
+ end
+ else if scan_keyword("pop") then begin
+ i := colorstack_pop;
+ end
+ else if scan_keyword("current") then begin
+ i := colorstack_current;
+ end
+ else begin
+ i := -1; {error}
+ end;
+ if i >= 0 then begin
+ new_whatsit(pdf_colorstack_node);
+ pdf_colorstack_stack(tail) := cur_val;
+ pdf_colorstack_cmd(tail) := i;
+ pdf_colorstack_data(tail) := null;
+ if i <= colorstack_data then begin
+ scan_pdf_ext_toks;
+ pdf_colorstack_data(tail) := def_ref;
+ end;
+ end
+ else begin
+ print_err("Color stack action is missing");
+@.Color stack action is missing@>
+ help3("The expected actions for \pdfcolorstack:")@/
+ (" set, push, pop, current")@/
+ ("I'll ignore the color stack command.");
+ error;
+ end
+end
+
+@ @<Implement \.{\\pdfsetmatrix}@>=
+begin
+ check_pdfoutput("\pdfsetmatrix", true);
+ new_whatsit(pdf_setmatrix_node);
+ scan_pdf_ext_toks;
+ pdf_setmatrix_data(tail) := def_ref;
+end
+
+@ @<Implement \.{\\pdfsave}@>=
+begin
+ check_pdfoutput("\pdfsave", true);
+ new_whatsit(pdf_save_node);
+end
+
+@ @<Implement \.{\\pdfrestore}@>=
+begin
+ check_pdfoutput("\pdfrestore", true);
+ new_whatsit(pdf_restore_node);
+end
+
+
+@ @<Implement \.{\\latelua}@>=
+begin
+ check_pdfoutput("\latelua", true);
+ new_whatsit(late_lua_node);
+ scan_register_num;
+ late_lua_reg(tail) := cur_val;
+ scan_pdf_ext_toks;
+ late_lua_data(tail) := def_ref;
+end
+
+@ @<Implement \.{\\closelua}@>=
+begin
+ check_pdfoutput("\closelua", true);
+ new_whatsit(close_lua_node);
+ scan_register_num;
+ late_lua_reg(tail) := cur_val;
+end
+
+@ The \.{\\pdfobj} primitive is used to create a ``raw'' object in the PDF
+ output file. The object contents will be hold in memory and will be written
+ out only when the object is referenced by \.{\\pdfrefobj}. When \.{\\pdfobj}
+ is used with \.{\\immediate}, the object contents will be written out
+ immediately. Objects referenced in the current page are appended into
+ |pdf_obj_list|.
+
+@<Glob...@>=
+@!pdf_last_obj: integer;
+
+@ @<Implement \.{\\pdfobj}@>=
+begin
+ check_pdfoutput("\pdfobj", true);
+ if scan_keyword("reserveobjnum") then begin
+ @<Scan an optional space@>;
+ incr(pdf_obj_count);
+ pdf_create_obj(obj_type_obj, pdf_obj_count);
+ pdf_last_obj := obj_ptr;
+ end
+ else begin
+ k := -1;
+ if scan_keyword("useobjnum") then begin
+ scan_int;
+ k := cur_val;
+ if (k <= 0) or (k > obj_ptr) or (obj_data_ptr(k) <> 0) then begin
+ pdf_warning("\pdfobj", "invalid object number being ignored", true, true);
+ pdf_retval := -1; {signal the problem}
+ k := -1; {will be generated again}
+ end;
+ end;
+ if k < 0 then begin
+ incr(pdf_obj_count);
+ pdf_create_obj(obj_type_obj, pdf_obj_count);
+ k := obj_ptr;
+ end;
+ obj_data_ptr(k) := pdf_get_mem(pdfmem_obj_size);
+ if scan_keyword("stream") then begin
+ obj_obj_is_stream(k) := 1;
+ if scan_keyword("attr") then begin
+ scan_pdf_ext_toks;
+ obj_obj_stream_attr(k) := def_ref;
+ end
+ else
+ obj_obj_stream_attr(k) := null;
+ end
+ else
+ obj_obj_is_stream(k) := 0;
+ if scan_keyword("file") then
+ obj_obj_is_file(k) := 1
+ else
+ obj_obj_is_file(k) := 0;
+ scan_pdf_ext_toks;
+ obj_obj_data(k) := def_ref;
+ pdf_last_obj := k;
+ end;
+end
+
+@ We need to check whether the referenced object exists.
+
+@<Declare procedures that need to be declared forward for \pdfTeX@>=
+function prev_rightmost(s, e: pointer): pointer;
+{finds the node preceding the rightmost node |e|; |s| is some node
+before |e|}
+var p: pointer;
+begin
+ prev_rightmost := null;
+ p := s;
+ if p = null then
+ return;
+ while vlink(p) <> e do begin
+ p := vlink(p);
+ if p = null then
+ return;
+ end;
+ prev_rightmost := p;
+end;
+
+procedure pdf_check_obj(t, n: integer);
+var k: integer;
+begin
+ k := head_tab[t];
+ while (k <> 0) and (k <> n) do
+ k := obj_link(k);
+ if k = 0 then
+ pdf_error("ext1", "cannot find referenced object");
+end;
+
+@ @<Implement \.{\\pdfrefobj}@>=
+begin
+ check_pdfoutput("\pdfrefobj", true);
+ scan_int;
+ pdf_check_obj(obj_type_obj, cur_val);
+ new_whatsit(pdf_refobj_node);
+ pdf_obj_objnum(tail) := cur_val;
+end
+
+@ \.{\\pdfxform} and \.{\\pdfrefxform} are similiar to \.{\\pdfobj} and
+ \.{\\pdfrefobj}
+
+@<Glob...@>=
+@!pdf_last_xform: integer;
+
+@ @<Implement \.{\\pdfxform}@>=
+begin
+ check_pdfoutput("\pdfxform", true);
+ incr(pdf_xform_count);
+ pdf_create_obj(obj_type_xform, pdf_xform_count);
+ k := obj_ptr;
+ obj_data_ptr(k) := pdf_get_mem(pdfmem_xform_size);
+ if scan_keyword("attr") then begin
+ scan_pdf_ext_toks;
+ obj_xform_attr(k) := def_ref;
+ end
+ else
+ obj_xform_attr(k) := null;
+ if scan_keyword("resources") then begin
+ scan_pdf_ext_toks;
+ obj_xform_resources(k) := def_ref;
+ end
+ else
+ obj_xform_resources(k) := null;
+ scan_int;
+ p:=box(cur_val);
+ if p = null then
+ pdf_error("ext1", "\pdfxform cannot be used with a void box");
+ obj_xform_width(k) := width(p);
+ obj_xform_height(k) := height(p);
+ obj_xform_depth(k) := depth(p);
+ obj_xform_box(k) := p; {save pointer to the box}
+ box(cur_val):=null;
+ pdf_last_xform := k;
+end
+
+@ @<Implement \.{\\pdfrefxform}@>=
+begin
+ check_pdfoutput("\pdfrefxform", true);
+ scan_int;
+ pdf_check_obj(obj_type_xform, cur_val);
+ new_whatsit(pdf_refxform_node);
+ pdf_xform_objnum(tail) := cur_val;
+ pdf_width(tail) := obj_xform_width(cur_val);
+ pdf_height(tail) := obj_xform_height(cur_val);
+ pdf_depth(tail) := obj_xform_depth(cur_val);
+end
+
+@ \.{\\pdfximage} and \.{\\pdfrefximage} are similiar to \.{\\pdfxform} and
+ \.{\\pdfrefxform}. As we have to scan |<rule spec>| quite often, it is better
+ have a |rule_node| that holds the most recently scanned |<rule spec>|.
+
+@<Glob...@>=
+@!pdf_last_ximage: integer;
+@!pdf_last_ximage_pages: integer;
+@!pdf_last_ximage_colordepth: integer;
+@!alt_rule: pointer;
+@!warn_pdfpagebox: boolean;
+
+@ @<Set init...@>=
+alt_rule := null;
+warn_pdfpagebox := true;
+
+@ @<Declare procedures needed in |do_ext...@>=
+
+function scan_pdf_box_spec: integer; {scans PDF pagebox specification}
+begin
+ scan_pdf_box_spec := 0;
+ if scan_keyword("mediabox") then
+ scan_pdf_box_spec := pdf_box_spec_media
+ else if scan_keyword("cropbox") then
+ scan_pdf_box_spec := pdf_box_spec_crop
+ else if scan_keyword("bleedbox") then
+ scan_pdf_box_spec := pdf_box_spec_bleed
+ else if scan_keyword("trimbox") then
+ scan_pdf_box_spec := pdf_box_spec_trim
+ else if scan_keyword("artbox") then
+ scan_pdf_box_spec := pdf_box_spec_art
+end;
+
+procedure scan_alt_rule; {scans rule spec to |alt_rule|}
+label reswitch;
+begin
+ if alt_rule = null then
+ alt_rule := new_rule;
+ width(alt_rule) := null_flag;
+ height(alt_rule) := null_flag;
+ depth(alt_rule) := null_flag;
+reswitch:
+ if scan_keyword("width") then begin
+ scan_normal_dimen;
+ width(alt_rule) := cur_val;
+ goto reswitch;
+ end;
+ if scan_keyword("height") then begin
+ scan_normal_dimen;
+ height(alt_rule) := cur_val;
+ goto reswitch;
+ end;
+ if scan_keyword("depth") then begin
+ scan_normal_dimen;
+ depth(alt_rule) := cur_val;
+ goto reswitch;
+ end;
+end;
+
+procedure scan_image;
+label reswitch;
+var i, k, img_wd, img_ht, img_dp, ref: integer;
+ named, attr: str_number;
+ s: str_number;
+ page, pagebox, colorspace: integer;
+begin
+ incr(pdf_ximage_count);
+ pdf_create_obj(obj_type_ximage, pdf_ximage_count);
+ k := obj_ptr;
+ scan_alt_rule; {scans |<rule spec>| to |alt_rule|}
+ img_wd := width(alt_rule);
+ img_ht := height(alt_rule);
+ img_dp := depth(alt_rule);
+ attr := 0;
+ named := 0;
+ page := 1;
+ colorspace := 0;
+ if scan_keyword("attr") then begin
+ scan_pdf_ext_toks;
+ attr := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ end;
+ if scan_keyword("named") then begin
+ scan_pdf_ext_toks;
+ named := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ page := 0;
+ end
+ else if scan_keyword("page") then begin
+ scan_int;
+ page := cur_val;
+ end;
+ if scan_keyword("colorspace") then begin
+ scan_int;
+ colorspace := cur_val;
+ end;
+ pagebox := scan_pdf_box_spec;
+ if pagebox = 0 then
+ pagebox := pdf_pagebox;
+ scan_pdf_ext_toks;
+ s := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ if pdf_option_always_use_pdfpagebox <> 0 then begin
+ pdf_warning("PDF inclusion", "Primitive \pdfoptionalwaysusepdfpagebox is obsolete; use \pdfpagebox instead.", true, true);
+ pdf_force_pagebox := pdf_option_always_use_pdfpagebox;
+ pdf_option_always_use_pdfpagebox := 0; {warn once}
+ warn_pdfpagebox := false;
+ end;
+ if pdf_option_pdf_inclusion_errorlevel <> 0 then begin
+ pdf_warning("PDF inclusion", "Primitive \pdfoptionpdfinclusionerrorlevel is obsolete; use \pdfinclusionerrorlevel instead.", true, true);
+ pdf_inclusion_errorlevel := pdf_option_pdf_inclusion_errorlevel;
+ pdf_option_pdf_inclusion_errorlevel := 0; {warn once}
+ end;
+ if pdf_force_pagebox > 0 then begin
+ if warn_pdfpagebox then begin
+ pdf_warning("PDF inclusion", "Primitive \pdfforcepagebox is obsolete; use \pdfpagebox instead.", true, true);
+ warn_pdfpagebox := false;
+ end;
+ pagebox := pdf_force_pagebox;
+ end;
+ if pagebox = 0 then {no pagebox specification given}
+ pagebox := pdf_box_spec_crop;
+ ref := read_image(k, pdf_ximage_count, s, page, named, attr, colorspace, pagebox,
+ pdf_minor_version, pdf_inclusion_errorlevel);
+ flush_str(s);
+ obj_data_ptr(k) := ref;
+ if named <> 0 then flush_str(named);
+ set_image_dimensions(ref, img_wd, img_ht, img_dp);
+ if attr <> 0 then flush_str(attr);
+ scale_image(ref);
+ pdf_last_ximage := k;
+ pdf_last_ximage_pages := image_pages(ref);
+ pdf_last_ximage_colordepth := image_colordepth(ref);
+end;
+
+@ @<Implement \.{\\pdfximage}@>=
+begin
+ check_pdfoutput("\pdfximage", true);
+ check_pdfminorversion;
+ scan_image;
+end
+
+@ @<Implement \.{\\pdfrefximage}@>=
+begin
+ check_pdfoutput("\pdfrefximage", true);
+ scan_int;
+ pdf_check_obj(obj_type_ximage, cur_val);
+ new_whatsit(pdf_refximage_node);
+ j := obj_data_ptr(cur_val);
+ pdf_ximage_ref(tail) := j;
+ pdf_width(tail) := image_width(j);
+ pdf_height(tail) := image_height(j);
+ pdf_depth(tail) := image_depth(j);
+end
+
+@ The following function finds object with identifier |i| and type |t|.
+ |i < 0| indicates that |-i| should be treated as a string number. If no
+ such object exists then it will be created. This function is used mainly to
+ find destination for link annotations and outlines; however it is also used
+ in |pdf_ship_out| (to check whether a Page object already exists) so we need
+ to declare it together with subroutines needed in |pdf_hlist_out| and
+ |pdf_vlist_out|.
+
+@<Declare procedures that need to be declared forward for \pdfTeX@>=
+function find_obj(t, i: integer; byname: boolean): integer;
+begin
+ find_obj := avl_find_obj(t, i, byname);
+end;
+
+procedure flush_str(s: str_number); {flush a string if possible}
+begin
+ if flushable(s) then
+ flush_string;
+end;
+
+function get_obj(t, i: integer; byname: boolean): integer;
+var r: integer;
+ s: str_number;
+begin
+ if byname > 0 then begin
+ s := tokens_to_string(i);
+ r := find_obj(t, s, true);
+ end
+ else begin
+ s := 0;
+ r := find_obj(t, i, false);
+ end;
+ if r = 0 then begin
+ if byname > 0 then begin
+ pdf_create_obj(t, -s);
+ s := 0;
+ end
+ else
+ pdf_create_obj(t, i);
+ r := obj_ptr;
+ if t = obj_type_dest then
+ obj_dest_ptr(r) := null;
+ end;
+ if s <> 0 then
+ flush_str(s);
+ get_obj := r;
+end;
+
+function get_microinterval:integer;
+var s,@!m:integer; {seconds and microseconds}
+begin
+ seconds_and_micros(s,m);
+ if (s-epochseconds)>32767 then
+ get_microinterval := max_integer
+ else if (microseconds>m) then
+ get_microinterval := ((s-1-epochseconds)*65536)+ (((m+1000000-microseconds)/100)*65536)/10000
+ else
+ get_microinterval := ((s-epochseconds)*65536) + (((m-microseconds)/100)*65536)/10000;
+end;
+
+
+@ @<Declare procedures needed in |do_ext...@>=
+function scan_action: pointer; {read an action specification}
+var p: integer;
+begin
+ p := new_node(action_node,0);
+ scan_action := p;
+ if scan_keyword("user") then
+ pdf_action_type(p) := pdf_action_user
+ else if scan_keyword("goto") then
+ pdf_action_type(p) := pdf_action_goto
+ else if scan_keyword("thread") then
+ pdf_action_type(p) := pdf_action_thread
+ else
+ pdf_error("ext1", "action type missing");
+ if pdf_action_type(p) = pdf_action_user then begin
+ scan_pdf_ext_toks;
+ pdf_action_tokens(p) := def_ref;
+ return;
+ end;
+ if scan_keyword("file") then begin
+ scan_pdf_ext_toks;
+ pdf_action_file(p) := def_ref;
+ end;
+ if scan_keyword("page") then begin
+ if pdf_action_type(p) <> pdf_action_goto then
+ pdf_error("ext1", "only GoTo action can be used with `page'");
+ pdf_action_type(p) := pdf_action_page;
+ scan_int;
+ if cur_val <= 0 then
+ pdf_error("ext1", "page number must be positive");
+ pdf_action_id(p) := cur_val;
+ pdf_action_named_id(p) := 0;
+ scan_pdf_ext_toks;
+ pdf_action_tokens(p) := def_ref;
+ end
+ else if scan_keyword("name") then begin
+ scan_pdf_ext_toks;
+ pdf_action_named_id(p) := 1;
+ pdf_action_id(p) := def_ref;
+ end
+ else if scan_keyword("num") then begin
+ if (pdf_action_type(p) = pdf_action_goto) and
+ (pdf_action_file(p) <> null) then
+ pdf_error("ext1",
+ "`goto' option cannot be used with both `file' and `num'");
+ scan_int;
+ if cur_val <= 0 then
+ pdf_error("ext1", "num identifier must be positive");
+ pdf_action_named_id(p) := 0;
+ pdf_action_id(p) := cur_val;
+ end
+ else
+ pdf_error("ext1", "identifier type missing");
+ if scan_keyword("newwindow") then begin
+ pdf_action_new_window(p) := 1;
+ @<Scan an optional space@>; end
+ else if scan_keyword("nonewwindow") then begin
+ pdf_action_new_window(p) := 2;
+ @<Scan an optional space@>; end
+ else
+ pdf_action_new_window(p) := 0;
+ if (pdf_action_new_window(p) > 0) and
+ (((pdf_action_type(p) <> pdf_action_goto) and
+ (pdf_action_type(p) <> pdf_action_page)) or
+ (pdf_action_file(p) = null)) then
+ pdf_error("ext1",
+ "`newwindow'/`nonewwindow' must be used with `goto' and `file' option");
+end;
+
+procedure new_annot_whatsit(w: small_number); {create a new whatsit node for
+annotation}
+begin
+ new_whatsit(w);
+ scan_alt_rule; {scans |<rule spec>| to |alt_rule|}
+ pdf_width(tail) := width(alt_rule);
+ pdf_height(tail) := height(alt_rule);
+ pdf_depth(tail) := depth(alt_rule);
+ if (w = pdf_thread_node) or (w = pdf_start_thread_node) then begin
+ if scan_keyword("attr") then begin
+ scan_pdf_ext_toks;
+ pdf_thread_attr(tail) := def_ref;
+ end
+ else
+ pdf_thread_attr(tail) := null;
+ end;
+end;
+
+@ @<Glob...@>=
+@!pdf_last_annot: integer;
+
+@ @<Implement \.{\\pdfannot}@>=
+begin
+ check_pdfoutput("\pdfannot", true);
+ if scan_keyword("reserveobjnum") then begin
+ pdf_last_annot := pdf_new_objnum;
+ @<Scan an optional space@>; end
+ else begin
+ if scan_keyword("useobjnum") then begin
+ scan_int;
+ k := cur_val;
+ if (k <= 0) or (k > obj_ptr) or (obj_annot_ptr(k) <> 0) then
+ pdf_error("ext1", "invalid object number");
+ end
+ else
+ k := pdf_new_objnum;
+ new_annot_whatsit(pdf_annot_node);
+ pdf_annot_objnum(tail) := k;
+ scan_pdf_ext_toks;
+ pdf_annot_data(tail) := def_ref;
+ pdf_last_annot := k;
+ end
+end
+
+@ pdflastlink needs an extra global variable
+@<Glob...@>=
+@!pdf_last_link: integer;
+
+@ @<Implement \.{\\pdfstartlink}@>=
+begin
+ check_pdfoutput("\pdfstartlink", true);
+ if abs(mode) = vmode then
+ pdf_error("ext1", "\pdfstartlink cannot be used in vertical mode");
+ k := pdf_new_objnum;
+ new_annot_whatsit(pdf_start_link_node);
+ pdf_link_attr(tail) := null;
+ if scan_keyword("attr") then begin
+ scan_pdf_ext_toks;
+ pdf_link_attr(tail) := def_ref;
+ end;
+ r := scan_action; pdf_link_action(tail) := r;
+ pdf_link_objnum(tail) := k;
+ pdf_last_link := k;
+ {N.B.: although it is possible to set |obj_annot_ptr(k) := tail| here, it
+ is not safe if nodes are later copied/destroyed/moved; a better place
+ to do this is inside |do_link|, when the whatsit node is written out}
+end
+
+@ @<Implement \.{\\pdfendlink}@>=
+begin
+ check_pdfoutput("\pdfendlink", true);
+ if abs(mode) = vmode then
+ pdf_error("ext1", "\pdfendlink cannot be used in vertical mode");
+ new_whatsit(pdf_end_link_node);
+end
+
+@ @<Declare procedures needed in |do_ext...@>=
+function outline_list_count(p: pointer): integer; {return number of outline
+entries in the same level with |p|}
+var k: integer;
+begin
+ k := 1;
+ while obj_outline_prev(p) <> 0 do begin
+ incr(k);
+ p := obj_outline_prev(p);
+ end;
+ outline_list_count := k;
+end;
+
+@ @<Implement \.{\\pdfoutline}@>=
+begin
+ check_pdfoutput("\pdfoutline", true);
+ if scan_keyword("attr") then begin
+ scan_pdf_ext_toks;
+ r := def_ref;
+ end
+ else
+ r := 0;
+ p := scan_action;
+ if scan_keyword("count") then begin
+ scan_int;
+ i := cur_val;
+ end
+ else
+ i := 0;
+ scan_pdf_ext_toks;
+ q := def_ref;
+ pdf_new_obj(obj_type_others, 0, 1);
+ j := obj_ptr;
+ write_action(p);
+ pdf_end_obj;
+ delete_action_ref(p);
+ pdf_create_obj(obj_type_outline, 0);
+ k := obj_ptr;
+ obj_outline_ptr(k) := pdf_get_mem(pdfmem_outline_size);
+ obj_outline_action_objnum(k) := j;
+ obj_outline_count(k) := i;
+ pdf_new_obj(obj_type_others, 0, 1);
+ pdf_print_str_ln(tokens_to_string(q));
+ flush_str(last_tokens_string);
+ delete_token_ref(q);
+ pdf_end_obj;
+ obj_outline_title(k) := obj_ptr;
+ obj_outline_prev(k) := 0;
+ obj_outline_next(k) := 0;
+ obj_outline_first(k) := 0;
+ obj_outline_last(k) := 0;
+ obj_outline_parent(k) := pdf_parent_outline;
+ obj_outline_attr(k) := r;
+ if pdf_first_outline = 0 then
+ pdf_first_outline := k;
+ if pdf_last_outline = 0 then begin
+ if pdf_parent_outline <> 0 then
+ obj_outline_first(pdf_parent_outline) := k;
+ end
+ else begin
+ obj_outline_next(pdf_last_outline) := k;
+ obj_outline_prev(k) := pdf_last_outline;
+ end;
+ pdf_last_outline := k;
+ if obj_outline_count(k) <> 0 then begin
+ pdf_parent_outline := k;
+ pdf_last_outline := 0;
+ end
+ else if (pdf_parent_outline <> 0) and
+ (outline_list_count(k) = abs(obj_outline_count(pdf_parent_outline))) then
+ begin
+ j := pdf_last_outline;
+ repeat
+ obj_outline_last(pdf_parent_outline) := j;
+ j := pdf_parent_outline;
+ pdf_parent_outline := obj_outline_parent(pdf_parent_outline);
+ until (pdf_parent_outline = 0) or
+ (outline_list_count(j) < abs(obj_outline_count(pdf_parent_outline)));
+ if pdf_parent_outline = 0 then
+ pdf_last_outline := pdf_first_outline
+ else
+ pdf_last_outline := obj_outline_first(pdf_parent_outline);
+ while obj_outline_next(pdf_last_outline) <> 0 do
+ pdf_last_outline := obj_outline_next(pdf_last_outline);
+ end;
+end
+
+@ When a destination is created we need to check whether another destination
+with the same identifier already exists and give a warning if needed.
+
+@<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure warn_dest_dup(id: integer; byname: small_number; s1, s2: str_number);
+begin
+ pdf_warning(s1, "destination with the same identifier (", false, false);
+ if byname > 0 then begin
+ print("name");
+ print_mark(id);
+ end
+ else begin
+ print("num");
+ print_int(id);
+ end;
+ print(") ");
+ print(s2);
+ print_ln;
+ show_context;
+end;
+
+@ Notice that |scan_keyword| doesn't care if two words have same prefix; so
+we should be careful when scan keywords with same prefix. The main rule: if
+there are two or more keywords with the same prefix, then always test in
+order from the longest one to the shortest one.
+
+@<Implement \.{\\pdfdest}@>=
+begin
+ check_pdfoutput("\pdfdest", true);
+ q := tail;
+ new_whatsit(pdf_dest_node);
+ if scan_keyword("num") then begin
+ scan_int;
+ if cur_val <= 0 then
+ pdf_error("ext1", "num identifier must be positive");
+ if cur_val > max_halfword then
+ pdf_error("ext1", "number too big");
+ pdf_dest_id(tail) := cur_val;
+ pdf_dest_named_id(tail) := 0;
+ end
+ else if scan_keyword("name") then begin
+ scan_pdf_ext_toks;
+ pdf_dest_id(tail) := def_ref;
+ pdf_dest_named_id(tail) := 1;
+ end
+ else
+ pdf_error("ext1", "identifier type missing");
+ if scan_keyword("xyz") then begin
+ pdf_dest_type(tail) := pdf_dest_xyz;
+ if scan_keyword("zoom") then begin
+ scan_int;
+ if cur_val > max_halfword then
+ pdf_error("ext1", "number too big");
+ pdf_dest_xyz_zoom(tail) := cur_val;
+ end
+ else
+ pdf_dest_xyz_zoom(tail) := null;
+ end
+ else if scan_keyword("fitbh") then
+ pdf_dest_type(tail) := pdf_dest_fitbh
+ else if scan_keyword("fitbv") then
+ pdf_dest_type(tail) := pdf_dest_fitbv
+ else if scan_keyword("fitb") then
+ pdf_dest_type(tail) := pdf_dest_fitb
+ else if scan_keyword("fith") then
+ pdf_dest_type(tail) := pdf_dest_fith
+ else if scan_keyword("fitv") then
+ pdf_dest_type(tail) := pdf_dest_fitv
+ else if scan_keyword("fitr") then
+ pdf_dest_type(tail) := pdf_dest_fitr
+ else if scan_keyword("fit") then
+ pdf_dest_type(tail) := pdf_dest_fit
+ else
+ pdf_error("ext1", "destination type missing");
+ @<Scan an optional space@>;
+ if pdf_dest_type(tail) = pdf_dest_fitr then begin
+ scan_alt_rule; {scans |<rule spec>| to |alt_rule|}
+ pdf_width(tail) := width(alt_rule);
+ pdf_height(tail) := height(alt_rule);
+ pdf_depth(tail) := depth(alt_rule);
+ end;
+ if pdf_dest_named_id(tail) <> 0 then begin
+ i := tokens_to_string(pdf_dest_id(tail));
+ k := find_obj(obj_type_dest, i, true);
+ flush_str(i);
+ end
+ else
+ k := find_obj(obj_type_dest, pdf_dest_id(tail), false);
+ if (k <> 0) and (obj_dest_ptr(k) <> null) then begin
+ warn_dest_dup(pdf_dest_id(tail), pdf_dest_named_id(tail),
+ "ext4", "has been already used, duplicate ignored");
+ flush_node_list(tail);
+ tail := q;
+ vlink(q) := null;
+ end;
+end
+
+@ @<Declare procedures needed in |do_ext...@>=
+procedure scan_thread_id;
+begin
+ if scan_keyword("num") then begin
+ scan_int;
+ if cur_val <= 0 then
+ pdf_error("ext1", "num identifier must be positive");
+ if cur_val > max_halfword then
+ pdf_error("ext1", "number too big");
+ pdf_thread_id(tail) := cur_val;
+ pdf_thread_named_id(tail) := 0;
+ end
+ else if scan_keyword("name") then begin
+ scan_pdf_ext_toks;
+ pdf_thread_id(tail) := def_ref;
+ pdf_thread_named_id(tail) := 1;
+ end
+ else
+ pdf_error("ext1", "identifier type missing");
+end;
+
+@ @<Implement \.{\\pdfthread}@>=
+begin
+ check_pdfoutput("\pdfthread", true);
+ new_annot_whatsit(pdf_thread_node);
+ scan_thread_id;
+end
+
+@ @<Implement \.{\\pdfstartthread}@>=
+begin
+ check_pdfoutput("\pdfstartthread", true);
+ new_annot_whatsit(pdf_start_thread_node);
+ scan_thread_id;
+end
+
+@ @<Implement \.{\\pdfendthread}@>=
+begin
+ check_pdfoutput("\pdfendthread", true);
+ new_whatsit(pdf_end_thread_node);
+end
+
+@ @<Glob...@>=
+@!pdf_last_x_pos: integer;
+@!pdf_last_y_pos: integer;
+
+@ @<Implement \.{\\pdfsavepos}@>=
+begin
+ new_whatsit(pdf_save_pos_node);
+end
+
+@ To implement primitives as \.{\\pdfinfo}, \.{\\pdfcatalog} or
+\.{\\pdfnames} we need to concatenate tokens lists.
+
+@<Declare procedures needed in |do_ext...@>=
+function concat_tokens(q, r: pointer): pointer; {concat |q| and |r| and
+returns the result tokens list}
+var p: pointer;
+begin
+ if q = null then begin
+ concat_tokens := r;
+ return;
+ end;
+ p := q;
+ while link(p) <> null do
+ p := link(p);
+ link(p) := link(r);
+ free_avail(r);
+ concat_tokens := q;
+end;
+
+@ @<Implement \.{\\pdfinfo}@>=
+begin
+ check_pdfoutput("\pdfinfo", false);
+ scan_pdf_ext_toks;
+ if pdf_output > 0 then
+ pdf_info_toks := concat_tokens(pdf_info_toks, def_ref);
+end
+
+@ @<Implement \.{\\pdfcatalog}@>=
+begin
+ check_pdfoutput("\pdfcatalog", false);
+ scan_pdf_ext_toks;
+ if pdf_output > 0 then
+ pdf_catalog_toks := concat_tokens(pdf_catalog_toks, def_ref);
+ if scan_keyword("openaction") then begin
+ if pdf_catalog_openaction <> 0 then
+ pdf_error("ext1", "duplicate of openaction")
+ else begin
+ p := scan_action;
+ pdf_new_obj(obj_type_others, 0, 1);
+ if pdf_output > 0 then
+ pdf_catalog_openaction := obj_ptr;
+ write_action(p);
+ pdf_end_obj;
+ delete_action_ref(p);
+ end;
+ end
+end
+
+@ @<Implement \.{\\pdfnames}@>=
+begin
+ check_pdfoutput("\pdfnames", true);
+ scan_pdf_ext_toks;
+ pdf_names_toks := concat_tokens(pdf_names_toks, def_ref);
+end
+
+@ @<Implement \.{\\pdftrailer}@>=
+begin
+ check_pdfoutput("\pdftrailer", false);
+ scan_pdf_ext_toks;
+ if pdf_output > 0 then
+ pdf_trailer_toks := concat_tokens(pdf_trailer_toks, def_ref);
+end
+
+@ @<Glob...@>=
+@!pdf_retval: integer; {global multi-purpose return value}
+
+@ @<Set initial values of key variables@>=
+ seconds_and_micros(epochseconds,microseconds);
+ init_start_time;
+
+@ Negative random seed values are silently converted to positive ones
+
+@<Implement \.{\\pdfsetrandomseed}@>=
+begin
+ scan_int;
+ if cur_val<0 then negate(cur_val);
+ random_seed := cur_val;
+ init_randoms(random_seed);
+end
+
+@ @<Implement \.{\\savecatcodetable}@>=
+begin
+ scan_int;
+ if (cur_val<0)or(cur_val>@"FFFFFFF) then begin
+ print_err("Invalid \catcode table");
+ help1("All \catcode table ids must be between 0 and 0xFFFFFFF");
+ error;
+ end
+ else begin if cur_val=cat_code_table then begin
+ print_err("Invalid \catcode table");
+ help1("You cannot overwrite the current \catcode table");
+ error;
+ end
+ else
+ copy_cat_codes(cat_code_table,cur_val);
+ end;
+end
+
+@ @<Implement \.{\\initcatcodetable}@>=
+begin
+ scan_int;
+ if (cur_val<0)or(cur_val>@"FFFFFFF) then begin
+ print_err("Invalid \catcode table");
+ help1("All \catcode table ids must be between 0 and 0xFFFFFFF");
+ error;
+ end
+ else begin if cur_val=cat_code_table then begin
+ print_err("Invalid \catcode table");
+ help1("You cannot overwrite the current \catcode table");
+ error;
+ end
+ else
+ initex_cat_codes(cur_val);
+ end;
+end
+
+@ The following subroutines are about PDF-specific font issues.
+
+@<Declare procedures needed in |do_ext...@>=
+procedure pdf_include_chars;
+var s: str_number;
+ k: pool_pointer; {running indices}
+ f: internal_font_number;
+begin
+ scan_font_ident;
+ f := cur_val;
+ if f = null_font then
+ pdf_error("font", "invalid font identifier");
+ pdf_check_vf_cur_val;
+ if not font_used(f) then
+ pdf_init_font(f);
+ scan_pdf_ext_toks;
+ s := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ k := str_start_macro(s);
+ while k < str_start_macro(s + 1) do begin
+ pdf_mark_char(f, str_pool[k]);
+ incr(k);
+ end;
+ flush_str(s);
+end;
+
+procedure glyph_to_unicode;
+var s1, s2: str_number;
+begin
+ scan_pdf_ext_toks;
+ s1 := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ scan_pdf_ext_toks;
+ s2 := tokens_to_string(def_ref);
+ delete_token_ref(def_ref);
+ def_tounicode(s1, s2);
+ flush_str(s2);
+ flush_str(s1);
+end;
+
+@ @<Implement \.{\\pdfincludechars}@>=
+begin
+ check_pdfoutput("\pdfincludechars", true);
+ pdf_include_chars;
+end
+
+@ @<Implement \.{\\pdfglyphtounicode}@>=
+begin
+ glyph_to_unicode;
+end
+
+@ A change from \THANH's original code: the font attributes are simply
+initialized to zero now, this is easier to deal with from C than an
+empty \TeX{} string, and surely nobody will want to set
+\.{\\pdffontattr} to a string containing a single zero, as that
+would be nonsensical in the PDF output.
+
+@<Implement \.{\\pdffontattr}@>=
+begin
+ check_pdfoutput("\pdffontattr", true);
+ scan_font_ident;
+ k := cur_val;
+ if k = null_font then
+ pdf_error("font", "invalid font identifier");
+ scan_pdf_ext_toks;
+ set_pdf_font_attr(k, tokens_to_string(def_ref));
+ if length(pdf_font_attr(k)) = 0 then begin
+ flush_string;
+ set_pdf_font_attr(k,0);
+ end;
+end
+
+@ @<Implement \.{\\pdfmapfile}@>=
+begin
+ check_pdfoutput("\pdfmapfile", true);
+ scan_pdf_ext_toks;
+ pdfmapfile(def_ref);
+ delete_token_ref(def_ref);
+end
+
+@ @<Implement \.{\\pdfmapline}@>=
+begin
+ check_pdfoutput("\pdfmapline", true);
+ scan_pdf_ext_toks;
+ pdfmapline(def_ref);
+ delete_token_ref(def_ref);
+end
+
+@ The following function are needed for outputing article thread.
+
+@<Declare procedures needed in |do_ext...@>=
+procedure thread_title(thread: integer);
+begin
+ pdf_print("/Title (");
+ if obj_info(thread) < 0 then
+ pdf_print(-obj_info(thread))
+ else
+ pdf_print_int(obj_info(thread));
+ pdf_print_ln(")");
+end;
+
+procedure pdf_fix_thread(thread: integer);
+var a: pointer;
+begin
+ pdf_warning("thread", "destination ", false, false);
+ if obj_info(thread) < 0 then begin
+ print("name{");
+ print(-obj_info(thread));
+ print("}");
+ end
+ else begin
+ print("num");
+ print_int(obj_info(thread));
+ end;
+ print(" has been referenced but does not exist, replaced by a fixed one");
+ print_ln; print_ln;
+ pdf_new_dict(obj_type_others, 0, 0);
+ a := obj_ptr;
+ pdf_indirect_ln("T", thread);
+ pdf_indirect_ln("V", a);
+ pdf_indirect_ln("N", a);
+ pdf_indirect_ln("P", head_tab[obj_type_page]);
+ pdf_print("/R [0 0 ");
+ pdf_print_bp(page_width); pdf_out(" ");
+ pdf_print_bp(page_height);
+ pdf_print_ln("]");
+ pdf_end_dict;
+ pdf_begin_dict(thread, 1);
+ pdf_print_ln("/I << ");
+ thread_title(thread);
+ pdf_print_ln(">>");
+ pdf_indirect_ln("F", a);
+ pdf_end_dict;
+end;
+
+procedure out_thread(thread: integer);
+var a, b: pointer;
+ last_attr: integer;
+begin
+ if obj_thread_first(thread) = 0 then begin
+ pdf_fix_thread(thread);
+ return;
+ end;
+ pdf_begin_dict(thread, 1);
+ a := obj_thread_first(thread);
+ b := a;
+ last_attr := 0;
+ repeat
+ if obj_bead_attr(a) <> 0 then
+ last_attr := obj_bead_attr(a);
+ a := obj_bead_next(a);
+ until a = b;
+ if last_attr <> 0 then
+ pdf_print_ln(last_attr)
+ else begin
+ pdf_print_ln("/I << ");
+ thread_title(thread);
+ pdf_print_ln(">>");
+ end;
+ pdf_indirect_ln("F", a);
+ pdf_end_dict;
+ repeat
+ pdf_begin_dict(a, 1);
+ if a = b then
+ pdf_indirect_ln("T", thread);
+ pdf_indirect_ln("V", obj_bead_prev(a));
+ pdf_indirect_ln("N", obj_bead_next(a));
+ pdf_indirect_ln("P", obj_bead_page(a));
+ pdf_indirect_ln("R", obj_bead_rect(a));
+ pdf_end_dict;
+ a := obj_bead_next(a);
+ until a = b;
+end;
+
+@ @<Display <rule spec> for whatsit node created by \pdfTeX@>=
+print("(");
+print_rule_dimen(pdf_height(p));
+print_char("+");
+print_rule_dimen(pdf_depth(p));
+print(")x");
+print_rule_dimen(pdf_width(p))
+
+@ Each new type of node that appears in our data structure must be capable
+of being displayed, copied, destroyed, and so on. The routines that we
+need for write-oriented whatsits are somewhat like those for mark nodes;
+other extensions might, of course, involve more subtlety here.
+
+@<Basic printing...@>=
+procedure print_write_whatsit(@!s:str_number;@!p:pointer);
+begin print_esc(s);
+if write_stream(p)<16 then print_int(write_stream(p))
+else if write_stream(p)=16 then print_char("*")
+@.*\relax@>
+else print_char("-");
+end;
+
+@ Three extra node types carry information from |main_control|.
+
+@ |cancel_boundary_nodes| indicate that the next left boundary be
+ignored. These are created by the \.{\\noboundary} command in
+horizontal mode.
+
+@d cancel_boundary_node==pdf_restore_node+1
+@d cancel_boundary_size==3
+
+@<Append a |cancel_boundary_node| @>=
+begin new_whatsit(cancel_boundary_node);
+end
+
+@ User defined whatsits can be inserted into node lists to pass data
+along from one lua call to anotherb without interference from the
+typesetting engine itself. Each has an id, a type, and a value. The
+type of the value depends on the |user_node_type| field.
+
+@d user_defined_node==cancel_boundary_node+1
+@d user_defined_node_size=4
+@d user_node_id(#)==vlink(#+2)
+@d user_node_type(#)==vinfo(#+2)
+@d user_node_value(#)==vinfo(#+3)
+
+@ @<Display the whatsit...@>=
+case subtype(p) of
+open_node:begin print_write_whatsit("openout",p);
+ print_char("="); print_file_name(open_name(p),open_area(p),open_ext(p));
+ end;
+write_node:begin print_write_whatsit("write",p);
+ print_mark(write_tokens(p));
+ end;
+close_node:print_write_whatsit("closeout",p);
+special_node:begin print_esc("special");
+ print_mark(write_tokens(p));
+ end;
+dir_node:
+ if dir_dir(p)<0 then begin
+ print_esc("enddir"); print(" "); print_dir(dir_dir(p)+64);
+ end
+ else begin
+ print_esc("begindir"); print(" "); print_dir(dir_dir(p));
+ end;
+@<LOCAL: print out |local_paragraph| node@>;
+pdf_literal_node: begin
+ print_esc("pdfliteral");
+ case pdf_literal_mode(p) of
+ set_origin:
+ do_nothing;
+ direct_page:
+ print(" page");
+ direct_always:
+ print(" direct");
+ othercases confusion("literal2")
+ endcases;
+ print_mark(pdf_literal_data(p));
+end;
+pdf_colorstack_node: begin
+ print_esc("pdfcolorstack ");
+ print_int(pdf_colorstack_stack(p));
+ case pdf_colorstack_cmd(p) of
+ colorstack_set:
+ print(" set ");
+ colorstack_push:
+ print(" push ");
+ colorstack_pop:
+ print(" pop");
+ colorstack_current:
+ print(" current");
+ othercases confusion("pdfcolorstack")
+ endcases;
+ if pdf_colorstack_cmd(p) <= colorstack_data then
+ print_mark(pdf_colorstack_data(p));
+end;
+pdf_setmatrix_node: begin
+ print_esc("pdfsetmatrix");
+ print_mark(pdf_setmatrix_data(p));
+end;
+pdf_save_node: begin
+ print_esc("pdfsave");
+end;
+pdf_restore_node: begin
+ print_esc("pdfrestore");
+end;
+cancel_boundary_node: begin
+ print_esc("noboundary");
+end;
+late_lua_node: begin
+ print_esc("latelua");
+ print_int(late_lua_reg(p));
+ print_mark(late_lua_data(p));
+end;
+close_lua_node: begin
+ print_esc("closelua");
+ print_int(late_lua_reg(p));
+end;
+pdf_refobj_node: begin
+ print_esc("pdfrefobj");
+ if obj_obj_is_stream(pdf_obj_objnum(p)) > 0 then begin
+ if obj_obj_stream_attr(pdf_obj_objnum(p)) <> null then begin
+ print(" attr");
+ print_mark(obj_obj_stream_attr(pdf_obj_objnum(p)));
+ end;
+ print(" stream");
+ end;
+ if obj_obj_is_file(pdf_obj_objnum(p)) > 0 then
+ print(" file");
+ print_mark(obj_obj_data(pdf_obj_objnum(p)));
+end;
+pdf_refxform_node: begin
+ print_esc("pdfrefxform");
+ print("(");
+ print_scaled(obj_xform_height(pdf_xform_objnum(p)));
+ print_char("+");
+ print_scaled(obj_xform_depth(pdf_xform_objnum(p)));
+ print(")x");
+ print_scaled(obj_xform_width(pdf_xform_objnum(p)));
+end;
+pdf_refximage_node: begin
+ print_esc("pdfrefximage");
+ print("(");
+ print_scaled(pdf_height(p));
+ print_char("+");
+ print_scaled(pdf_depth(p));
+ print(")x");
+ print_scaled(pdf_width(p));
+end;
+pdf_annot_node: begin
+ print_esc("pdfannot");
+ @<Display <rule spec> for whatsit node created by \pdfTeX@>;
+ print_mark(pdf_annot_data(p));
+end;
+pdf_start_link_node: begin
+ print_esc("pdflink");
+ @<Display <rule spec> for whatsit node created by \pdfTeX@>;
+ if pdf_link_attr(p) <> null then begin
+ print(" attr");
+ print_mark(pdf_link_attr(p));
+ end;
+ print(" action");
+ if pdf_action_type(pdf_link_action(p)) = pdf_action_user then begin
+ print(" user");
+ print_mark(pdf_action_tokens(pdf_link_action(p)));
+ return;
+ end;
+ if pdf_action_file(pdf_link_action(p)) <> null then begin
+ print(" file");
+ print_mark(pdf_action_file(pdf_link_action(p)));
+ end;
+ case pdf_action_type(pdf_link_action(p)) of
+ pdf_action_goto: begin
+ if pdf_action_named_id(pdf_link_action(p)) > 0 then begin
+ print(" goto name");
+ print_mark(pdf_action_id(pdf_link_action(p)));
+ end
+ else begin
+ print(" goto num");
+ print_int(pdf_action_id(pdf_link_action(p)))
+ end;
+ end;
+ pdf_action_page: begin
+ print(" page");
+ print_int(pdf_action_id(pdf_link_action(p)));
+ print_mark(pdf_action_tokens(pdf_link_action(p)));
+ end;
+ pdf_action_thread: begin
+ if pdf_action_named_id(pdf_link_action(p)) > 0 then begin
+ print(" thread name");
+ print_mark(pdf_action_id(pdf_link_action(p)));
+ end
+ else begin
+ print(" thread num");
+ print_int(pdf_action_id(pdf_link_action(p)));
+ end;
+ end;
+ othercases pdf_error("displaying", "unknown action type");
+ endcases;
+end;
+pdf_end_link_node: print_esc("pdfendlink");
+pdf_dest_node: begin
+ print_esc("pdfdest");
+ if pdf_dest_named_id(p) > 0 then begin
+ print(" name");
+ print_mark(pdf_dest_id(p));
+ end
+ else begin
+ print(" num");
+ print_int(pdf_dest_id(p));
+ end;
+ print(" ");
+ case pdf_dest_type(p) of
+ pdf_dest_xyz: begin
+ print("xyz");
+ if pdf_dest_xyz_zoom(p) <> null then begin
+ print(" zoom");
+ print_int(pdf_dest_xyz_zoom(p));
+ end;
+ end;
+ pdf_dest_fitbh: print("fitbh");
+ pdf_dest_fitbv: print("fitbv");
+ pdf_dest_fitb: print("fitb");
+ pdf_dest_fith: print("fith");
+ pdf_dest_fitv: print("fitv");
+ pdf_dest_fitr: begin
+ print("fitr");
+ @<Display <rule spec> for whatsit node created by \pdfTeX@>;
+ end;
+ pdf_dest_fit: print("fit");
+ othercases print("unknown!");
+ endcases;
+end;
+pdf_thread_node,
+pdf_start_thread_node: begin
+ if subtype(p) = pdf_thread_node then
+ print_esc("pdfthread")
+ else
+ print_esc("pdfstartthread");
+ print("("); print_rule_dimen(pdf_height(p)); print_char("+");
+ print_rule_dimen(pdf_depth(p)); print(")x");
+ print_rule_dimen(pdf_width(p));
+ if pdf_thread_attr(p) <> null then begin
+ print(" attr");
+ print_mark(pdf_thread_attr(p));
+ end;
+ if pdf_thread_named_id(p) > 0 then begin
+ print(" name");
+ print_mark(pdf_thread_id(p));
+ end
+ else begin
+ print(" num");
+ print_int(pdf_thread_id(p));
+ end;
+end;
+pdf_end_thread_node: print_esc("pdfendthread");
+pdf_save_pos_node: print_esc("pdfsavepos");
+user_defined_node: begin
+ print_esc("whatsit");
+ print_int(user_node_id(p));
+ print_char("=");
+ case user_node_type(p) of
+ "a": print("<>");
+ "n": begin print("["); show_node_list(user_node_value(p)); print("]"); end;
+ "s": begin print(""""); print(user_node_value(p)); print(""""); end;
+ "t": print_mark(user_node_value(p));
+ othercases { only d }
+ print_int(user_node_value(p));
+ endcases;
+ end;
+othercases print("whatsit?")
+endcases
+
+@ @<Incorporate a whatsit node into a vbox@>=
+if (subtype(p) = pdf_refxform_node) or (subtype(p) = pdf_refximage_node) then
+begin x:=x+d+pdf_height(p); d:=pdf_depth(p);
+s:=0;
+if pdf_width(p)+s>w then w:=pdf_width(p)+s;
+end
+
+@ @<Incorporate a whatsit node into an hbox@>=
+begin
+if subtype(p)=dir_node then
+ begin
+ @<DIR: Adjust the dir stack for the |hpack| routine@>;
+ end
+else begin
+if (subtype(p) = pdf_refxform_node) or (subtype(p) = pdf_refximage_node) then
+begin x:=x+pdf_width(p);
+s:=0;
+if pdf_height(p)-s>h then h:=pdf_height(p)-s;
+if pdf_depth(p)+s>d then d:=pdf_depth(p)+s;
+end;
+end;
+end
+
+@ @<Let |d| be the width of the whatsit |p|@>=
+if (subtype(p) = pdf_refxform_node) or (subtype(p) = pdf_refximage_node) then
+ d := pdf_width(p)
+else
+ d := 0
+
+@ @<Prepare to move whatsit |p| to the current page, then |goto contribute|@>=
+begin
+ if (subtype(p) = pdf_refxform_node) or (subtype(p) = pdf_refximage_node) then
+ begin page_total:=page_total+page_depth+pdf_height(p);
+ page_depth:=pdf_depth(p);
+ end;
+ goto contribute;
+end
+
+@ @<Process whatsit |p| in |vert_break| loop, |goto not_found|@>=
+begin
+ if (subtype(p) = pdf_refxform_node) or (subtype(p) = pdf_refximage_node) then
+ begin cur_height:=cur_height+prev_dp+pdf_height(p); prev_dp:=pdf_depth(p);
+ end;
+ goto not_found;
+end
+
+@ @<Output the whatsit node |p| in a vlist@>=
+out_what(p)
+
+@ @<Output the whatsit node |p| in an hlist@>=
+if subtype(p)<>dir_node then out_what(p)
+else @<Output a reflection instruction if the direction has changed@>
+
+@ After all this preliminary shuffling, we come finally to the routines
+that actually send out the requested data. Let's do \.{\\special} first
+(it's easier).
+
+@<Declare procedures needed in |hlist_out|, |vlist_out|@>=
+procedure special_out(@!p:pointer);
+var old_setting:0..max_selector; {holds print |selector|}
+@!k:pool_pointer; {index into |str_pool|}
+begin synch_h; synch_v;@/
+old_setting:=selector; selector:=new_string;
+show_token_list(link(write_tokens(p)),null,pool_size-pool_ptr);
+selector:=old_setting;
+str_room(1);
+if cur_length<256 then
+ begin dvi_out(xxx1); dvi_out(cur_length);
+ end
+else begin dvi_out(xxx4); dvi_four(cur_length);
+ end;
+for k:=str_start_macro(str_ptr) to pool_ptr-1 do dvi_out(so(str_pool[k]));
+pool_ptr:=str_start_macro(str_ptr); {erase the string}
+end;
+
+@ To write a token list, we must run it through \TeX's scanner, expanding
+macros and \.{\\the} and \.{\\number}, etc. This might cause runaways,
+if a delimited macro parameter isn't matched, and runaways would be
+extremely confusing since we are calling on \TeX's scanner in the middle
+of a \.{\\shipout} command. Therefore we will put a dummy control sequence as
+a ``stopper,'' right after the token list. This control sequence is
+artificially defined to be \.{\\outer}.
+@:end_write_}{\.{\\endwrite}@>
+
+@<Initialize table...@>=
+text(end_write):="endwrite"; eq_level(end_write):=level_one;
+eq_type(end_write):=outer_call; equiv(end_write):=null;
+
+@ @<Declare procedures needed in |hlist_out|, |vlist_out|@>=
+procedure write_out(@!p:pointer);
+var old_setting:0..max_selector; {holds print |selector|}
+@!old_mode:integer; {saved |mode|}
+@!j:small_number; {write stream number}
+@!q,@!r:pointer; {temporary variables for list manipulation}
+begin @<Expand macros in the token list
+ and make |link(def_ref)| point to the result@>;
+old_setting:=selector; j:=write_stream(p);
+if write_open[j] then selector:=j
+else begin {write to the terminal if file isn't open}
+ if (j=17)and(selector=term_and_log) then selector:=log_only;
+ print_nl("");
+ end;
+token_show(def_ref); print_ln;
+flush_list(def_ref); selector:=old_setting;
+end;
+
+@ The final line of this routine is slightly subtle; at least, the author
+didn't think about it until getting burnt! There is a used-up token list
+@^Knuth, Donald Ervin@>
+on the stack, namely the one that contained |end_write_token|. (We
+insert this artificial `\.{\\endwrite}' to prevent runaways, as explained
+above.) If it were not removed, and if there were numerous writes on a
+single page, the stack would overflow.
+
+@d end_write_token==cs_token_flag+end_write
+
+@<Expand macros in the token list and...@>=
+q:=get_avail; info(q):=right_brace_token+"}";@/
+r:=get_avail; link(q):=r; info(r):=end_write_token; ins_list(q);@/
+begin_token_list(write_tokens(p),write_text);@/
+q:=get_avail; info(q):=left_brace_token+"{"; ins_list(q);
+{now we're ready to scan
+ `\.\{$\langle\,$token list$\,\rangle$\.{\} \\endwrite}'}
+old_mode:=mode; mode:=0;
+ {disable \.{\\prevdepth}, \.{\\spacefactor}, \.{\\lastskip}, \.{\\prevgraf}}
+cur_cs:=write_loc; q:=scan_toks(false,true); {expand macros, etc.}
+get_token;@+if cur_tok<>end_write_token then
+ @<Recover from an unbalanced write command@>;
+mode:=old_mode;
+end_token_list {conserve stack space}
+
+@ @<Recover from an unbalanced write command@>=
+begin print_err("Unbalanced write command");
+@.Unbalanced write...@>
+help2("On this page there's a \write with fewer real {'s than }'s.")@/
+("I can't handle that very well; good luck."); error;
+repeat get_token;
+until cur_tok=end_write_token;
+end
+
+@ The |out_what| procedure takes care of outputting whatsit nodes for
+|vlist_out| and |hlist_out|\kern-.3pt.
+
+@<Declare procedures needed in |hlist_out|, |vlist_out|@>=
+procedure out_what(@!p:pointer);
+var j:small_number; {write stream number}
+begin case subtype(p) of
+open_node,write_node,close_node:@<Do some work that has been queued up
+ for \.{\\write}@>;
+special_node:special_out(p);
+pdf_save_pos_node:
+ @<Save current position in DVI mode@>;
+local_par_node:do_nothing;
+cancel_boundary_node: do_nothing;
+othercases confusion("ext4") {TH: those will be pdf extension nodes in dvi mode, most likely}
+@:this can't happen ext4}{\quad ext4@>
+endcases;
+end;
+
+@ @<Save current position in DVI mode@>=
+begin
+ pdf_last_x_pos := cur_h + one_inch;
+ pdf_last_y_pos := cur_page_height - cur_v - one_inch;
+end
+
+@ We don't implement \.{\\write} inside of leaders. (The reason is that
+the number of times a leader box appears might be different in different
+implementations, due to machine-dependent rounding in the glue calculations.)
+@^leaders@>
+
+@<Do some work that has been queued up...@>=
+if not doing_leaders then
+ begin j:=write_stream(p);
+ if subtype(p)=write_node then write_out(p)
+ else begin if write_open[j] then lua_a_close_out(write_file[j]);
+ if subtype(p)=close_node then write_open[j]:=false
+ else if j<16 then
+ begin cur_name:=open_name(p); cur_area:=open_area(p);
+ cur_ext:=open_ext(p);
+ if cur_ext="" then cur_ext:=".tex";
+ pack_cur_name;
+ while not lua_a_open_out(write_file[j],(j+1)) do
+ prompt_file_name("output file name",".tex");
+ write_file[j]:= name_file_pointer;
+ write_open[j]:=true;
+ end;
+ end;
+ end
+
+@ The presence of `\.{\\immediate}' causes the |do_extension| procedure
+to descend to one level of recursion. Nothing happens unless \.{\\immediate}
+is followed by `\.{\\openout}', `\.{\\write}', or `\.{\\closeout}'.
+@^recursion@>
+
+@<Implement \.{\\immediate}@>=
+begin get_x_token;
+if cur_cmd=extension then begin
+ if cur_chr<=close_node then
+ begin p:=tail; do_extension; {append a whatsit node}
+ out_what(tail); {do the action immediately}
+ flush_node_list(tail); tail:=p; vlink(p):=null;
+ end
+ else case cur_chr of
+ close_lua_node: begin
+ scan_register_num;
+ closelua(cur_val);
+ end;
+ pdf_obj_code: begin
+ do_extension; {scan object and set |pdf_last_obj|}
+ if obj_data_ptr(pdf_last_obj) = 0 then {this object has not been initialized yet}
+ pdf_error("ext1", "`\pdfobj reserveobjnum' cannot be used with \immediate");
+ pdf_write_obj(pdf_last_obj);
+ end;
+ pdf_xform_code: begin
+ do_extension; {scan form and set |pdf_last_xform|}
+ pdf_cur_form := pdf_last_xform;
+ pdf_ship_out(obj_xform_box(pdf_last_xform), false);
+ end;
+ pdf_ximage_code: begin
+ do_extension; {scan image and set |pdf_last_ximage|}
+ pdf_write_image(pdf_last_ximage);
+ end;
+ othercases back_input
+ endcases;
+end
+else
+ back_input;
+end
+
+@ @<Finish the extensions@>=
+for k:=0 to 15 do if write_open[k] then lua_a_close_out(write_file[k])
+
+@
+@d local_pen_inter(#)==vinfo(#+2) {\.{\\localinterlinepenalty}}
+@d local_pen_broken(#)==vlink(#+2) {\.{\\localbrokenpenalty}}
+@d local_box_left(#)==vlink(#+3) {\.{\\localleftbox}}
+@d local_box_left_width(#)==vinfo(#+3)
+@d local_box_right(#)==vlink(#+4) {\.{\\localleftbox}}
+@d local_box_right_width(#)==vinfo(#+4)
+@d local_par_dir(#)==vinfo(#+5)
+@d local_par_size==6
+
+@<LOCAL: Declare |make_local_par_node|@>=
+function make_local_par_node:pointer;
+{This function creates a |local_paragraph| node}
+var p,q:pointer;
+begin
+p:=new_node(whatsit_node,local_par_node);
+local_pen_inter(p):=local_inter_line_penalty;
+local_pen_broken(p):=local_broken_penalty;
+if local_left_box<>null then begin
+ q:=copy_node_list(local_left_box); local_box_left(p):=q;
+ local_box_left_width(p):=width(local_left_box);
+ end;
+if local_right_box<>null then begin
+ q:=copy_node_list(local_right_box); local_box_right(p):=q;
+ local_box_right_width(p):=width(local_right_box);
+ end;
+local_par_dir(p):=par_direction;
+make_local_par_node:=p;
+end
+
+@ @<LOCAL: print out |local_paragraph| node@>=
+local_par_node: begin
+ print_esc("whatsit");
+ append_char(".");
+ print_ln; print_current_string;
+ print_esc("localinterlinepenalty"); print("=");
+ print_int(local_pen_inter(p));
+ print_ln; print_current_string;
+ print_esc("localbrokenpenalty"); print("=");
+ print_int(local_pen_broken(p));
+ print_ln; print_current_string;
+ print_esc("localleftbox");
+ if local_box_left(p)=null then print("=null")
+ else begin
+ append_char(".");
+ show_node_list(local_box_left(p));
+ decr(pool_ptr);
+ end;
+ print_ln; print_current_string;
+ print_esc("localrightbox");
+ if local_box_right(p)=null then print("=null")
+ else begin
+ append_char(".");
+ show_node_list(local_box_right(p));
+ decr(pool_ptr);
+ end;
+ decr(pool_ptr);
+ end
+
+@ @<LOCAL: Add local paragraph node@>=
+begin tail_append(make_local_par_node) end
+
+@ @<DIR: Assign direction codes@>=
+case cur_chr of
+dir_base+page_direction_code: begin
+ if its_all_over then begin
+ scan_direction;
+ eq_word_define(dir_base+page_direction_code,cur_val);
+ end;
+ end;
+dir_base+body_direction_code: begin
+ if its_all_over then begin
+ scan_direction;
+ eq_word_define(dir_base+body_direction_code,cur_val);
+ end;
+ end;
+dir_base+par_direction_code: begin
+ scan_direction;
+ eq_word_define(dir_base+par_direction_code,cur_val);
+ end;
+dir_base+text_direction_code: begin scan_direction;
+ if (no_local_dirs>0) and (abs(mode)=hmode) then begin
+ @<DIR: Add local dir node@>;
+ dir_dir(tail):=dir_dir(tail)-64;
+ end;
+ if dir_level(text_dir_ptr)=cur_level then
+ @<DIR: Remove from |text_dir_ptr|@>;
+ eq_word_define(dir_base+text_direction_code,cur_val);
+ @<DIR: Add to |text_dir_ptr|@>;
+ if abs(mode)=hmode then
+ begin
+ @<DIR: Add local dir node@>;
+ dir_level(tail):=cur_level;
+ end;
+ eq_word_define(int_base+no_local_dirs_code,no_local_dirs+1);
+ eq_word_define(int_base+level_local_dir_code,cur_level);
+ end;
+dir_base+math_direction_code: begin scan_direction;
+ eq_word_define(dir_base+math_direction_code,cur_val);
+ end;
+end;
+
+@
+@d push_dir(#)==
+begin dir_tmp:=new_dir(#);
+vlink(dir_tmp):=dir_ptr;
+dir_ptr:=dir_tmp;
+end
+
+@d push_dir_node(#)==
+begin dir_tmp:=copy_node(#);
+vlink(dir_tmp):=dir_ptr;
+dir_ptr:=dir_tmp;
+end
+
+@d pop_dir_node==
+begin dir_tmp:=dir_ptr;
+dir_ptr:=vlink(dir_tmp);
+flush_node(dir_tmp);
+end
+
+@ @<DIR: Declare |new_dir|@>=
+function new_dir(s:small_number): pointer;
+var p:pointer; {the new node}
+begin p:=new_node(whatsit_node,dir_node);
+dir_dir(p):=s; dir_dvi_ptr(p):=-1;
+dir_level(p):=cur_level; new_dir:=p;
+end
+
+@ @<Append a begin direction to the tail of the current list@>=
+tail_append(new_dir(math_direction))
+
+@ @<Append an end direction to the tail of the current list@>=
+tail_append(new_dir(math_direction-64))
+
+@ @<DIR: Add local dir node@>=
+tail_append(new_dir(text_direction))
+
+@ @<DIR: Adjust the dir stack for the |hpack| routine@>=
+begin
+if dir_dir(p)>=0 then begin
+ hpack_dir:=dir_dir(p);
+ push_dir_node(p);
+ end
+else begin
+ pop_dir_node;
+ if dir_ptr<>null then
+ hpack_dir:=dir_dir(dir_ptr);
+ end
+end
+
+@ @<DIR: Reset |dir_ptr|@>=
+begin
+ while dir_ptr<>null do
+ pop_dir_node
+end
+
+@ @<DIR: |unsave| math@>=
+begin
+unsave;
+decr(save_ptr);
+flush_node_list(text_dir_ptr);
+text_dir_ptr:=saved(0);
+end
+
+@ @<DIR: |new_save_level| math@>=
+begin
+saved(0):=text_dir_ptr;
+text_dir_ptr:=new_dir(math_direction);
+incr(save_ptr);
+new_save_level(c);
+eq_word_define(dir_base+body_direction_code,math_direction);
+eq_word_define(dir_base+par_direction_code,math_direction);
+eq_word_define(dir_base+text_direction_code,math_direction);
+eq_word_define(int_base+level_local_dir_code,cur_level);
+end
+
+@ @<DIR: Adjust |text_dir_ptr| for |scan_spec|@>=
+begin
+if spec_direction<>-1 then begin
+ saved(4):=text_dir_ptr;
+ text_dir_ptr:=new_dir(spec_direction);
+ end
+else saved(4):=null;
+end
+
+@ @<DIR: Adjust back |text_dir_ptr| for |scan_spec|@>=
+begin
+flush_node_list(text_dir_ptr);
+text_dir_ptr:=saved(4);
+end
+
+@ @<DIR: Add to |text_dir_ptr|@>=
+begin
+text_dir_tmp:=new_dir(text_direction);
+vlink(text_dir_tmp):=text_dir_ptr;
+text_dir_ptr:=text_dir_tmp;
+end
+
+@ @<DIR: Remove from |text_dir_ptr|@>=
+begin
+text_dir_tmp:=vlink(text_dir_ptr);
+flush_node(text_dir_ptr);
+text_dir_ptr:=text_dir_tmp;
+end
+
+@ @<DIR: Initialize |text_dir_ptr|@>=
+begin
+text_dir_ptr:=new_dir(0);
+end
+
+@ @<DIR: Initialize |dir_ptr| for |ship_out|@>=
+begin dir_ptr:=null; push_dir(dvi_direction);
+dir_dvi_ptr(dir_ptr):=dvi_ptr;
+end
+
+@ @<Output a reflection instruction if the direction has changed@>=
+begin
+if dir_dir(p)>=0 then
+ begin synch_h; synch_v;
+ push_dir_node(p);
+ if dir_opposite(dir_secondary[dir_dir(dir_ptr)])(dir_secondary[dvi_direction])
+ then begin
+ if (dir_secondary[dvi_direction]=0) or
+ (dir_secondary[dvi_direction]=2) then
+ dvi_out(down4)
+ else
+ dvi_out(right4);
+ dir_dvi_ptr(dir_ptr):=dvi_ptr;
+ dir_dvi_h(dir_ptr):=dvi_h;
+ dvi_four(0);
+ cur_h:=0; dvi_h:=0;
+ end
+ else begin
+ dir_dvi_ptr(dir_ptr):=dvi_ptr;
+ dir_dvi_h(dir_ptr):=dvi_h;
+ end;
+ dvi_direction:=dir_dir(dir_ptr);
+ end
+else begin
+ dvi_dir_h:=dir_dvi_h(dir_ptr);
+ dvi_dir_ptr:=dir_dvi_ptr(dir_ptr);
+ pop_dir_node;
+ synch_h; synch_v;
+ if dir_ptr<>null then
+ dvi_direction:=dir_dir(dir_ptr)
+ else
+ dvi_direction:=0;
+ if dir_opposite(dir_secondary[dir_dir(p)+64])(dir_secondary[dvi_direction])
+ then begin
+ dvi_temp_ptr:=dvi_ptr;
+ dvi_ptr:=dvi_dir_ptr;
+ if (dir_secondary[dvi_direction]=0) or
+ (dir_secondary[dvi_direction]=1) then
+ dvi_four(dvi_h)
+ else
+ dvi_four(-dvi_h);
+ dvi_ptr:=dvi_temp_ptr;
+ if (dir_secondary[dvi_direction]=0) or
+ (dir_secondary[dvi_direction]=2) then
+ dvi_out(down4)
+ else
+ dvi_out(right4);
+ if (dir_secondary[dvi_direction]=0) or
+ (dir_secondary[dvi_direction]=1) then
+ dvi_four(dvi_h)
+ else
+ dvi_four(-dvi_h);
+ end;
+ cur_h:=dvi_dir_h+dvi_h; dvi_h:=cur_h;
+ end
+end
+
+@ Many things regarding output work differently in pdf compared to dvi
+output. The easiest way to deal with in-line direction changes in pdf
+mode seems to be to move forward to find the needed width of the
+reversed section, then skip forward (or backward, depending on your
+viewpont) by that distance.
+
+@<(PDF) Output a reflection instruction if the direction has changed@>=
+begin
+if dir_dir(p)>=0 then begin
+ push_dir_node(p);
+ if dir_opposite(dir_secondary[dir_dir(dir_ptr)])(dir_secondary[dvi_direction])
+ then begin
+ @<(PDF) Calculate the needed width to the matching |enddir|, and store it in |w|, as
+ well as in the enddir's |dir_dvi_h|@>;
+ case box_direction(dvi_direction) of
+ dir_TL_,dir_BL_: pdf_dvicmd_right(w);
+ dir_TR_,dir_BR_: pdf_dvicmd_left(w);
+ end;
+ end;
+ dvi_direction:=dir_dir(dir_ptr);
+ end
+else begin
+ pop_dir_node;
+ if dir_ptr<>null then
+ dvi_direction:=dir_dir(dir_ptr)
+ else
+ dvi_direction:=0;
+ case box_direction(dvi_direction) of
+ dir_TL_,dir_BL_: pdf_dvicmd_right(dir_dvi_h(p));
+ dir_TR_,dir_BR_: pdf_dvicmd_left(dir_dvi_h(p));
+ end;
+ end
+end
+
+@ This code scans forward to the ending |dir_node| while keeping
+track of the needed width in |w|. When it finds the node that will end
+this segment, it stores the accumulated with in the |dir_dvi_h| field
+of that end node, so that when that node is found later in the
+processing, the correct glue correction can be applied.
+
+@<(PDF) Calculate the needed width to the matching |enddir|...@>=
+begin
+ q:=p; w:=0;
+ save_cur_g:=cur_g;
+ save_cur_glue:=cur_glue;
+ { to me, it looks like the next is needed. but Aleph doesn't do that,
+ so let us not do it either }
+ {|w:=w-cur_g; cur_glue:=0;|}
+ dir_nest:=1;
+ while (q<>null) and (vlink(q)<>null) do begin
+ q:=vlink(q);
+ if is_char_node(q) then begin
+ w:=w+glyph_width(q); {TODO no vertical support for now}
+ end
+ else begin
+ case type(q) of
+ hlist_node,vlist_node,rule_node,
+ margin_kern_node,kern_node:w:=w+width(q);
+ glue_node: begin
+ g:=glue_ptr(q);
+ w:=w+width(g)-cur_g;
+ if g_sign<>normal then
+ begin if g_sign=stretching then
+ begin if stretch_order(g)=g_order then
+ begin cur_glue:=cur_glue+stretch(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+ cur_g:=round(glue_temp);
+ end;
+ end
+ else if shrink_order(g)=g_order then
+ begin cur_glue:=cur_glue-shrink(g);
+ vet_glue(float(glue_set(this_box))*cur_glue);
+ cur_g:=round(glue_temp);
+ end;
+ end;
+ w:=w+cur_g;
+ end;
+ math_node: w:=w+surround(q);
+ whatsit_node: begin
+ if subtype(q)=dir_node then begin
+ if dir_dir(q)>=0 then incr(dir_nest) else decr(dir_nest);
+ if dir_nest=0 then begin
+ dir_dvi_h(q) := w;
+ q:=null;
+ end;
+ end
+ else if (subtype(q) = pdf_refxform_node) or
+ (subtype(q) = pdf_refximage_node) then
+ w:=w+pdf_width(q);
+ end;
+ othercases do_nothing;
+ endcases;
+ end;
+ end;
+ cur_g:=save_cur_g;
+ cur_glue:=save_cur_glue;
+end
+
+
+@ Shipping out PDF marks.
+
+@<Types...@>=
+dest_name_entry = record
+ objname: str_number; {destination name}
+ objnum: integer; {destination object number}
+end;
+
+@ @<Glob...@>=
+@!cur_page_width: scaled; {width of page being shipped}
+@!cur_page_height: scaled; {height of page being shipped}
+@!cur_right_offset: scaled; {horizontal inverted offset of page being shipped}
+@!cur_bottom_offset: scaled; {vertical inverted offset of page being shipped}
+@!pdf_obj_list: pointer; {list of objects in the current page}
+@!pdf_xform_list: pointer; {list of forms in the current page}
+@!pdf_ximage_list: pointer; {list of images in the current page}
+@!last_thread: pointer; {pointer to the last thread}
+@!pdf_thread_ht, pdf_thread_dp, pdf_thread_wd: scaled; {dimensions of the last
+thread}
+@!pdf_last_thread_id: halfword; {identifier of the last thread}
+@!pdf_last_thread_named_id: boolean; {is identifier of the last thread named}
+@!pdf_thread_level: integer; {depth of nesting of box containing the last thread}
+@!pdf_annot_list: pointer; {list of annotations in the current page}
+@!pdf_link_list: pointer; {list of link annotations in the current page}
+@!pdf_dest_list: pointer; {list of destinations in the current page}
+@!pdf_bead_list: pointer; {list of thread beads in the current page}
+@!pdf_obj_count: integer; {counter of objects}
+@!pdf_xform_count: integer; {counter of forms}
+@!pdf_ximage_count: integer; {counter of images}
+@!pdf_cur_form: integer; {the form being output}
+@!pdf_first_outline, pdf_last_outline, pdf_parent_outline: integer;
+@!pdf_info_toks: pointer; {additional keys of Info dictionary}
+@!pdf_catalog_toks: pointer; {additional keys of Catalog dictionary}
+@!pdf_catalog_openaction: integer;
+@!pdf_names_toks: pointer; {additional keys of Names dictionary}
+@!pdf_dest_names_ptr: integer; {first unused position in |dest_names|}
+@!dest_names_size: integer; {maximum number of names in name tree of PDF output file}
+@!dest_names: ^dest_name_entry;
+@!pk_dpi: integer; {PK pixel density value from \.{texmf.cnf}}
+@!image_orig_x, image_orig_y: integer; {origin of cropped PDF images}
+@!pdf_trailer_toks: pointer; {additional keys of Trailer dictionary}
+
+@ @<Set init...@>=
+pdf_first_outline:= 0;
+pdf_last_outline:= 0;
+pdf_parent_outline:= 0;
+pdf_obj_count := 0;
+pdf_xform_count := 0;
+pdf_ximage_count := 0;
+pdf_dest_names_ptr := 0;
+pdf_info_toks := null;
+pdf_catalog_toks := null;
+pdf_names_toks := null;
+pdf_catalog_openaction := 0;
+pdf_trailer_toks := null;
+
+@ The following procedures are needed for outputing whatsit nodes for
+\pdfTeX{}.
+
+@<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure write_action(p: pointer); {write an action specification}
+var s: str_number;
+ d: integer;
+begin d:=0;
+ if pdf_action_type(p) = pdf_action_user then begin
+ pdf_print_toks_ln(pdf_action_tokens(p));
+ return;
+ end;
+ pdf_print("<< ");
+ if pdf_action_file(p) <> null then begin
+ pdf_print("/F ");
+ s := tokens_to_string(pdf_action_file(p));
+ if (str_pool[str_start_macro(s)] = 40) and
+ (str_pool[str_start_macro(s) + length(s) - 1] = 41) then
+ pdf_print(s)
+ else begin
+ pdf_print_str(s);
+ end;
+ flush_str(s);
+ pdf_print(" ");
+ if pdf_action_new_window(p) > 0 then begin
+ pdf_print("/NewWindow ");
+ if pdf_action_new_window(p) = 1 then
+ pdf_print("true ")
+ else
+ pdf_print("false ");
+ end;
+ end;
+ case pdf_action_type(p) of
+ pdf_action_page: begin
+ if pdf_action_file(p) = null then begin
+ pdf_print("/S /GoTo /D [");
+ pdf_print_int(get_obj(obj_type_page, pdf_action_id(p), false));
+ pdf_print(" 0 R");
+ end
+ else begin
+ pdf_print("/S /GoToR /D [");
+ pdf_print_int(pdf_action_id(p) - 1);
+ end;
+ pdf_out(" ");
+ pdf_print(tokens_to_string(pdf_action_tokens(p)));
+ flush_str(last_tokens_string);
+ pdf_out("]");
+ end;
+ pdf_action_goto: begin
+ if pdf_action_file(p) = null then begin
+ pdf_print("/S /GoTo ");
+ d := get_obj(obj_type_dest, pdf_action_id(p),
+ pdf_action_named_id(p));
+ end
+ else
+ pdf_print("/S /GoToR ");
+ if pdf_action_named_id(p) > 0 then begin
+ pdf_str_entry("D", tokens_to_string(pdf_action_id(p)));
+ flush_str(last_tokens_string);
+ end
+ else if pdf_action_file(p) = null then
+ pdf _indirect("D", d)
+ else
+ pdf_error("ext4", "`goto' option cannot be used with both `file' and `num'");
+ end;
+ pdf_action_thread: begin
+ pdf_print("/S /Thread ");
+ if pdf_action_file(p) = null then
+ d := get_obj(obj_type_thread, pdf_action_id(p),
+ pdf_action_named_id(p));
+ if pdf_action_named_id(p) > 0 then begin
+ pdf_str_entry("D", tokens_to_string(pdf_action_id(p)));
+ flush_str(last_tokens_string);
+ end
+ else if pdf_action_file(p) = null then
+ pdf_indirect("D", d)
+ else
+ pdf_int_entry("D", pdf_action_id(p));
+ end;
+ endcases;
+ pdf_print_ln(" >>");
+end;
+
+procedure set_rect_dimens(p, parent_box: pointer; x, y, w, h, d, margin: scaled);
+begin
+ pdf_left(p) := cur_h;
+ if is_running(w) then
+ pdf_right(p) := x + width(parent_box)
+ else
+ pdf_right(p) := cur_h + w;
+ if is_running(h) then
+ pdf_top(p) := y - height(parent_box)
+ else
+ pdf_top(p) := cur_v - h;
+ if is_running(d) then
+ pdf_bottom(p) := y + depth(parent_box)
+ else
+ pdf_bottom(p) := cur_v + d;
+ if is_shipping_page and matrixused then begin
+ matrixtransformrect(pdf_left(p), cur_page_height - pdf_bottom(p),
+ pdf_right(p), cur_page_height - pdf_top(p));
+ pdf_left(p) := getllx;
+ pdf_bottom(p) := cur_page_height - getlly;
+ pdf_right(p) := geturx;
+ pdf_top(p) := cur_page_height - getury;
+ end;
+ pdf_left(p) := pdf_left(p) - margin;
+ pdf_top(p) := pdf_top(p) - margin;
+ pdf_right(p) := pdf_right(p) + margin;
+ pdf_bottom(p) := pdf_bottom(p) + margin;
+end;
+
+procedure do_annot(p, parent_box: pointer; x, y: scaled);
+begin
+ if not is_shipping_page then
+ pdf_error("ext4", "annotations cannot be inside an XForm");
+ if doing_leaders then
+ return;
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p), 0);
+ obj_annot_ptr(pdf_annot_objnum(p)) := p;
+ pdf_append_list(pdf_annot_objnum(p))(pdf_annot_list);
+end;
+
+@ To implement nesting link annotations, we need a stack to hold copy of
+|pdf_start_link_node|'s that are being written out, together with their box
+nesting level.
+
+@d pdf_link_stack_top == pdf_link_stack[pdf_link_stack_ptr]
+
+@<Constants...@>=
+@!pdf_max_link_level = 10; {maximum depth of link nesting}
+
+@ @<Types...@>=
+@!pdf_link_stack_record = record
+ nesting_level: small_number;
+ link_node: pointer; {holds a copy of the corresponding |pdf_start_link_node|}
+ ref_link_node: pointer; {points to original |pdf_start_link_node|, or a
+ copy of |link_node| created by |append_link| in
+ case of multi-line link}
+end;
+
+@ @<Glob...@>=
+@!pdf_link_stack: array[1..pdf_max_link_level] of pdf_link_stack_record;
+@!pdf_link_stack_ptr: small_number;
+
+@ @<Set init...@>=
+pdf_link_stack_ptr := 0;
+
+@ @<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure push_link_level(p: pointer);
+begin
+ if pdf_link_stack_ptr >= pdf_max_link_level then
+ overflow("pdf link stack size", pdf_max_link_level);
+ pdfassert((type(p) = whatsit_node) and (subtype(p) = pdf_start_link_node));
+ incr(pdf_link_stack_ptr);
+ pdf_link_stack_top.nesting_level := cur_s;
+ pdf_link_stack_top.link_node := copy_node_list(p);
+ pdf_link_stack_top.ref_link_node := p;
+end;
+
+procedure pop_link_level;
+begin
+ pdfassert(pdf_link_stack_ptr > 0);
+ flush_node_list(pdf_link_stack_top.link_node);
+ decr(pdf_link_stack_ptr);
+end;
+
+procedure do_link(p, parent_box: pointer; x, y: scaled);
+begin
+ if not is_shipping_page then
+ pdf_error("ext4", "link annotations cannot be inside an XForm");
+ pdfassert(type(parent_box) = hlist_node);
+ push_link_level(p);
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_link_margin);
+ obj_annot_ptr(pdf_link_objnum(p)) := p; {the reference for the pdf annot object
+ must be set here}
+ pdf_append_list(pdf_link_objnum(p))(pdf_link_list);
+end;
+
+procedure end_link;
+var p: pointer;
+begin
+ if pdf_link_stack_ptr < 1 then
+ pdf_error("ext4", "pdf_link_stack empty, \pdfendlink used without \pdfstartlink?");
+ if pdf_link_stack_top.nesting_level <> cur_s then
+ pdf_error("ext4", "\pdfendlink ended up in different nesting level than \pdfstartlink");
+
+ {N.B.: test for running link must be done on |link_node| and not |ref_link_node|,
+ as |ref_link_node| can be set by |do_link| or |append_link| already}
+
+ if is_running(pdf_width(pdf_link_stack_top.link_node)) then begin
+ p := pdf_link_stack_top.ref_link_node;
+ if is_shipping_page and matrixused then begin
+ matrixrecalculate(cur_h + pdf_link_margin);
+ pdf_left(p) := getllx - pdf_link_margin;
+ pdf_top(p) := cur_page_height - getury - pdf_link_margin;
+ pdf_right(p) := geturx + pdf_link_margin;
+ pdf_bottom(p) := cur_page_height - getlly + pdf_link_margin;
+ end
+ else
+ pdf_right(p) := cur_h + pdf_link_margin;
+ end;
+ pop_link_level;
+end;
+
+@ For ``running'' annotations we must append a new node when the end of
+annotation is in other box than its start. The new created node is identical to
+corresponding whatsit node representing the start of annotation, but its
+|info| field is |max_halfword|. We set |info| field just before destroying the
+node, in order to use |flush_node_list| to do the job.
+
+@<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure append_link(parent_box: pointer; x, y: scaled; i: small_number); {append a new
+pdf annot to |pdf_link_list|}
+var p: pointer;
+begin
+ pdfassert(type(parent_box) = hlist_node);
+ p := copy_node(pdf_link_stack[i].link_node);
+ pdf_link_stack[i].ref_link_node := p;
+ subtype(p) := pdf_link_data_node; { this node is not a normal link node}
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_link_margin);
+ pdf_create_obj(obj_type_others, 0);
+ obj_annot_ptr(obj_ptr) := p;
+ pdf_append_list(obj_ptr)(pdf_link_list);
+end;
+
+@ Threads are handled in similar way as link annotations.
+
+@<Declare procedures needed in |pdf_hlist_out|, |pdf_vlist_out|@>=
+procedure append_bead(p: pointer);
+var a, b, c, t: integer;
+begin
+ if not is_shipping_page then
+ pdf_error("ext4", "threads cannot be inside an XForm");
+ t := get_obj(obj_type_thread, pdf_thread_id(p), pdf_thread_named_id(p));
+ b := pdf_new_objnum;
+ obj_bead_ptr(b) := pdf_get_mem(pdfmem_bead_size);
+ obj_bead_page(b) := pdf_last_page;
+ obj_bead_data(b) := p;
+ if pdf_thread_attr(p) <> null then
+ obj_bead_attr(b) := tokens_to_string(pdf_thread_attr(p))
+ else
+ obj_bead_attr(b) := 0;
+ if obj_thread_first(t) = 0 then begin
+ obj_thread_first(t) := b;
+ obj_bead_next(b) := b;
+ obj_bead_prev(b) := b;
+ end
+ else begin
+ a := obj_thread_first(t);
+ c := obj_bead_prev(a);
+ obj_bead_prev(b) := c;
+ obj_bead_next(b) := a;
+ obj_bead_prev(a) := b;
+ obj_bead_next(c) := b;
+ end;
+ pdf_append_list(b)(pdf_bead_list);
+end;
+
+procedure do_thread(p, parent_box: pointer; x, y: scaled);
+begin
+ if doing_leaders then
+ return;
+ if subtype(p) = pdf_start_thread_node then begin
+ pdf_thread_wd := pdf_width(p);
+ pdf_thread_ht := pdf_height(p);
+ pdf_thread_dp := pdf_depth(p);
+ pdf_last_thread_id := pdf_thread_id(p);
+ pdf_last_thread_named_id := (pdf_thread_named_id(p) > 0);
+ if pdf_last_thread_named_id then
+ add_token_ref(pdf_thread_id(p));
+ pdf_thread_level := cur_s;
+ end;
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_thread_margin);
+ append_bead(p);
+ last_thread := p;
+end;
+
+procedure append_thread(parent_box: pointer; x, y: scaled);
+var p: pointer;
+begin
+ p := new_node(whatsit_node,pdf_thread_data_node);
+ pdf_width(p) := pdf_thread_wd;
+ pdf_height(p) := pdf_thread_ht;
+ pdf_depth(p) := pdf_thread_dp;
+ pdf_thread_attr(p) := null;
+ pdf_thread_id(p) := pdf_last_thread_id;
+ if pdf_last_thread_named_id then begin
+ add_token_ref(pdf_thread_id(p));
+ pdf_thread_named_id(p) := 1;
+ end
+ else
+ pdf_thread_named_id(p) := 0;
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_thread_margin);
+ append_bead(p);
+ last_thread := p;
+end;
+
+procedure end_thread;
+begin
+ if pdf_thread_level <> cur_s then
+ pdf_error("ext4", "\pdfendthread ended up in different nesting level than \pdfstartthread");
+ if is_running(pdf_thread_dp) and (last_thread <> null) then
+ pdf_bottom(last_thread) := cur_v + pdf_thread_margin;
+ if pdf_last_thread_named_id then
+ delete_token_ref(pdf_last_thread_id);
+ last_thread := null;
+end;
+
+function open_subentries(p: pointer): integer;
+var k, c: integer;
+ l, r: integer;
+begin
+ k := 0;
+ if obj_outline_first(p) <> 0 then begin
+ l := obj_outline_first(p);
+ repeat
+ incr(k);
+ c := open_subentries(l);
+ if obj_outline_count(l) > 0 then
+ k := k + c;
+ obj_outline_parent(l) := p;
+ r := obj_outline_next(l);
+ if r = 0 then
+ obj_outline_last(p) := l;
+ l := r;
+ until l = 0;
+ end;
+ if obj_outline_count(p) > 0 then
+ obj_outline_count(p) := k
+ else
+ obj_outline_count(p) := -k;
+ open_subentries := k;
+end;
+
+procedure do_dest(p, parent_box: pointer; x, y: scaled);
+var k: integer;
+begin
+ if not is_shipping_page then
+ pdf_error("ext4", "destinations cannot be inside an XForm");
+ if doing_leaders then
+ return;
+ k := get_obj(obj_type_dest, pdf_dest_id(p), pdf_dest_named_id(p));
+ if obj_dest_ptr(k) <> null then begin
+ warn_dest_dup(pdf_dest_id(p), pdf_dest_named_id(p),
+ "ext4", "has been already used, duplicate ignored");
+ return;
+ end;
+ obj_dest_ptr(k) := p;
+ pdf_append_list(k)(pdf_dest_list);
+ case pdf_dest_type(p) of
+ pdf_dest_xyz:
+ if matrixused then
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_dest_margin)
+ else begin
+ pdf_left(p) := cur_h;
+ pdf_top(p) := cur_v;
+ end;
+ pdf_dest_fith,
+ pdf_dest_fitbh:
+ if matrixused then
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_dest_margin)
+ else
+ pdf_top(p) := cur_v;
+ pdf_dest_fitv,
+ pdf_dest_fitbv:
+ if matrixused then
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_dest_margin)
+ else
+ pdf_left(p) := cur_h;
+ pdf_dest_fit,
+ pdf_dest_fitb:
+ do_nothing;
+ pdf_dest_fitr:
+ set_rect_dimens(p, parent_box, x, y,
+ pdf_width(p), pdf_height(p), pdf_depth(p),
+ pdf_dest_margin);
+ endcases;
+end;
+
+procedure out_form(p: pointer);
+var v: scaled;
+begin
+ pdf_end_text;
+ pdf_print_ln("q");
+ if pdf_lookup_list(pdf_xform_list, pdf_xform_objnum(p)) = null then
+ pdf_append_list(pdf_xform_objnum(p))(pdf_xform_list);
+ v := cur_v + obj_xform_depth(pdf_xform_objnum(p));
+ pdf_set_origin_temp(cur_h, v);
+ pdf_print("/Fm");
+ pdf_print_int(obj_info(pdf_xform_objnum(p)));
+ pdf_print_resname_prefix;
+ pdf_print_ln(" Do");
+ pdf_print_ln("Q");
+end;
+
+@ @<Output the whatsit node |p| in |pdf_vlist_out|@>=
+case subtype(p) of
+pdf_literal_node:
+ pdf_out_literal(p);
+pdf_colorstack_node:
+ pdf_out_colorstack(p);
+pdf_setmatrix_node:
+ pdf_out_setmatrix(p);
+pdf_save_node:
+ pdf_out_save;
+pdf_restore_node:
+ pdf_out_restore;
+late_lua_node:
+ do_late_lua(p);
+close_lua_node:
+ closelua(late_lua_reg(p));
+pdf_refobj_node:
+ pdf_append_list(pdf_obj_objnum(p))(pdf_obj_list);
+pdf_refxform_node:
+ @<Output a Form node in a vlist@>;
+pdf_refximage_node:
+ @<Output a Image node in a vlist@>;
+pdf_annot_node:
+ do_annot(p, this_box, left_edge, top_edge + height(this_box));
+pdf_start_link_node:
+ pdf_error("ext4", "\pdfstartlink ended up in vlist");
+pdf_end_link_node:
+ pdf_error("ext4", "\pdfendlink ended up in vlist");
+pdf_dest_node:
+ do_dest(p, this_box, left_edge, top_edge + height(this_box));
+pdf_thread_node,
+pdf_start_thread_node:
+ do_thread(p, this_box, left_edge, top_edge + height(this_box));
+pdf_end_thread_node:
+ end_thread;
+pdf_save_pos_node:
+ @<Save current position to |pdf_last_x_pos|, |pdf_last_y_pos|@>;
+special_node:
+ pdf_special(p);
+othercases out_what(p);
+endcases
+
+@ @<Glob...@>=
+@!is_shipping_page: boolean; {set to |shipping_page| when |pdf_ship_out| starts}
+
+@ @<Save current position to |pdf_last_x_pos|, |pdf_last_y_pos|@>=
+begin
+ pdf_last_x_pos := cur_h;
+ pdf_last_y_pos := cur_page_height - cur_v
+end
+
+@ @<Output a Image node in a vlist@>=
+begin cur_v:=cur_v+pdf_height(p)+pdf_depth(p);
+ cur_h:=left_edge;
+ out_image(pdf_ximage_ref(p), cur_h-pdf_origin_h, pdf_origin_v-cur_v);
+ if pdf_lookup_list(pdf_ximage_list, image_objnum(pdf_ximage_ref(p))) = null then
+ pdf_append_list(image_objnum(pdf_ximage_ref(p)))(pdf_ximage_list);
+end
+
+@ @<Output a Form node in a vlist@>=
+begin cur_v:=cur_v+pdf_height(p);
+ cur_h:=left_edge;
+ out_form(p);
+ cur_v:=cur_v+pdf_depth(p);
+end
+
+@ @<Output the whatsit node |p| in |pdf_hlist_out|@>=
+case subtype(p) of
+pdf_literal_node:
+ pdf_out_literal(p);
+pdf_colorstack_node:
+ pdf_out_colorstack(p);
+pdf_setmatrix_node:
+ pdf_out_setmatrix(p);
+pdf_save_node:
+ pdf_out_save;
+pdf_restore_node:
+ pdf_out_restore;
+late_lua_node:
+ do_late_lua(p);
+close_lua_node:
+ closelua(late_lua_reg(p));
+pdf_refobj_node:
+ pdf_append_list(pdf_obj_objnum(p))(pdf_obj_list);
+pdf_refxform_node:
+ @<Output a Form node in a hlist@>;
+pdf_refximage_node:
+ @<Output a Image node in a hlist@>;
+pdf_annot_node:
+ do_annot(p, this_box, left_edge, base_line);
+pdf_start_link_node:
+ do_link(p, this_box, left_edge, base_line);
+pdf_end_link_node:
+ end_link;
+pdf_dest_node:
+ do_dest(p, this_box, left_edge, base_line);
+pdf_thread_node:
+ do_thread(p, this_box, left_edge, base_line);
+pdf_start_thread_node:
+ pdf_error("ext4", "\pdfstartthread ended up in hlist");
+pdf_end_thread_node:
+ pdf_error("ext4", "\pdfendthread ended up in hlist");
+pdf_save_pos_node:
+ @<Save current position to |pdf_last_x_pos|, |pdf_last_y_pos|@>;
+special_node:
+ pdf_special(p);
+othercases if subtype(p)<>dir_node then out_what(p)
+else @<(PDF) Output a reflection instruction if the direction has changed@>;
+endcases
+
+@ @<Output a Image node in a hlist@>=
+begin
+ cur_v:=base_line+pdf_depth(p);
+ out_image(pdf_ximage_ref(p), cur_h-pdf_origin_h, pdf_origin_v-cur_v);
+ if pdf_lookup_list(pdf_ximage_list, image_objnum(pdf_ximage_ref(p))) = null then
+ pdf_append_list(image_objnum(pdf_ximage_ref(p)))(pdf_ximage_list);
+ edge:=cur_h+pdf_width(p); cur_h:=edge; cur_v:=base_line;
+end
+
+@ @<Output a Form node in a hlist@>=
+begin
+ cur_v:=base_line;
+ out_form(p);
+ edge:=cur_h+pdf_width(p); cur_h:=edge;
+end
+
+@* \[53a] The extended features of \eTeX.
+The program has two modes of operation: (1)~In \TeX\ compatibility mode
+it fully deserves the name \TeX\ and there are neither extended features
+nor additional primitive commands. There are, however, a few
+modifications that would be legitimate in any implementation of \TeX\
+such as, e.g., preventing inadequate results of the glue to \.{DVI}
+unit conversion during |ship_out|. (2)~In extended mode there are
+additional primitive commands and the extended features of \eTeX\ are
+available.
+
+The distinction between these two modes of operation initially takes
+place when a `virgin' \.{eINITEX} starts without reading a format file.
+Later on the values of all \eTeX\ state variables are inherited when
+\.{eVIRTEX} (or \.{eINITEX}) reads a format file.
+
+The code below is designed to work for cases where `$|init|\ldots|tini|$'
+is a run-time switch.
+
+@<Enable \eTeX, if requested@>=
+@!init if format_ident=" (INITEX)" then
+ begin no_new_control_sequence:=false;
+ @<Generate all \eTeX\ primitives@>@;
+ if buffer[loc]="*" then incr(loc);
+ end;
+tini@;@/
+if not no_new_control_sequence then {just entered extended mode ?}
+ no_new_control_sequence:=true@+else
+
+@ The \eTeX\ features available in extended mode are grouped into two
+categories: (1)~Some of them are permanently enabled and have no
+semantic effect as long as none of the additional primitives are
+executed. (2)~The remaining \eTeX\ features are optional and can be
+individually enabled and disabled. For each optional feature there is
+an \eTeX\ state variable named \.{\\...state}; the feature is enabled,
+resp.\ disabled by assigning a positive, resp.\ non-positive value to
+that integer.
+
+
+@d Aleph_version_code=Aleph_int {code for \.{\\Alephversion}}
+@d Omega_version_code=Aleph_int+1 {code for \.{\\Omegaversion}}
+@d Aleph_minor_version_code=Aleph_int+2 {code for \.{\\Alephminorversion}}
+@d Omega_minor_version_code=Aleph_int+3 {code for \.{\\Omegaminorversion}}
+@d eTeX_minor_version_code=Aleph_int+4 {code for \.{\\eTeXminorversion}}
+@d eTeX_version_code=eTeX_int {code for \.{\\eTeXversion}}
+@d Aleph_revision_code=job_name_code+1 {command code for \.{\\Alephrevision}}
+@d Omega_revision_code=job_name_code+2 {command code for \.{\\Omegarevision}}
+@d eTeX_revision_code=job_name_code+3 {command code for \.{\\eTeXrevision}}
+
+@<Generate all \eTeX...@>=
+primitive("lastnodetype",last_item,last_node_type_code);
+@!@:last_node_type_}{\.{\\lastnodetype} primitive@>
+primitive("Alephversion",last_item,Aleph_version_code);
+@!@:eTeX_version_}{\.{\\Alephversion} primitive@>
+primitive("Omegaversion",last_item,Omega_version_code);
+@!@:eTeX_version_}{\.{\\Omegaversion} primitive@>
+primitive("eTeXversion",last_item,eTeX_version_code);
+@!@:eTeX_version_}{\.{\\eTeXversion} primitive@>
+primitive("Alephminorversion",last_item,Aleph_minor_version_code);
+@!@:eTeX_minor_version_}{\.{\\Alephminorversion} primitive@>
+primitive("Omegaminorversion",last_item,Omega_minor_version_code);
+@!@:eTeX_minor_version_}{\.{\\Omegaminorversion} primitive@>
+primitive("eTeXminorversion",last_item,eTeX_minor_version_code);
+@!@:eTeX_minor_version_}{\.{\\eTeXminorversion} primitive@>
+primitive("Alephrevision",convert,Aleph_revision_code);@/
+@!@:eTeX_revision_}{\.{\\Alephrevision} primitive@>
+primitive("Omegarevision",convert,Omega_revision_code);@/
+@!@:eTeX_revision_}{\.{\\Omegarevision} primitive@>
+primitive("eTeXrevision",convert,eTeX_revision_code);@/
+@!@:eTeX_revision_}{\.{\\eTeXrevision} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+last_node_type_code: print_esc("lastnodetype");
+Aleph_version_code: print_esc("Alephversion");
+Omega_version_code: print_esc("Omegaversion");
+eTeX_version_code: print_esc("eTeXversion");
+Aleph_minor_version_code: print_esc("Alephminorversion");
+Omega_minor_version_code: print_esc("Omegaminorversion");
+eTeX_minor_version_code: print_esc("eTeXminorversion");
+
+
+@ @<Cases for fetching an integer value@>=
+Aleph_version_code: cur_val:=Aleph_version;
+Omega_version_code: cur_val:=Omega_version;
+eTeX_version_code: cur_val:=eTeX_version;
+Aleph_minor_version_code: cur_val:=Aleph_minor_version;
+Omega_minor_version_code: cur_val:=Omega_minor_version;
+eTeX_minor_version_code: cur_val:=eTeX_minor_version;
+
+@ @<Cases of |convert| for |print_cmd_chr|@>=
+Aleph_revision_code: print_esc("Alephrevision");
+Omega_revision_code: print_esc("Omegarevision");
+eTeX_revision_code: print_esc("eTeXrevision");
+
+@ @<Cases of `Scan the argument for command |c|'@>=
+Aleph_revision_code: do_nothing;
+Omega_revision_code: do_nothing;
+eTeX_revision_code: do_nothing;
+
+@ @<Cases of `Print the result of command |c|'@>=
+Aleph_revision_code: print(Aleph_revision);
+Omega_revision_code: print(Omega_revision);
+eTeX_revision_code: print(eTeX_revision);
+
+@ First we implement the additional \eTeX\ parameters in the table of
+equivalents.
+
+@<Generate all \eTeX...@>=
+primitive("everyeof",assign_toks,every_eof_loc);
+@!@:every_eof_}{\.{\\everyeof} primitive@>
+primitive("tracingassigns",assign_int,int_base+tracing_assigns_code);@/
+@!@:tracing_assigns_}{\.{\\tracingassigns} primitive@>
+primitive("tracinggroups",assign_int,int_base+tracing_groups_code);@/
+@!@:tracing_groups_}{\.{\\tracinggroups} primitive@>
+primitive("tracingifs",assign_int,int_base+tracing_ifs_code);@/
+@!@:tracing_ifs_}{\.{\\tracingifs} primitive@>
+primitive("tracingscantokens",assign_int,int_base+tracing_scan_tokens_code);@/
+@!@:tracing_scan_tokens_}{\.{\\tracingscantokens} primitive@>
+primitive("tracingnesting",assign_int,int_base+tracing_nesting_code);@/
+@!@:tracing_nesting_}{\.{\\tracingnesting} primitive@>
+primitive("predisplaydirection",
+ assign_int,int_base+pre_display_direction_code);@/
+@!@:pre_display_direction_}{\.{\\predisplaydirection} primitive@>
+primitive("lastlinefit",assign_int,int_base+last_line_fit_code);@/
+@!@:last_line_fit_}{\.{\\lastlinefit} primitive@>
+primitive("savingvdiscards",assign_int,int_base+saving_vdiscards_code);@/
+@!@:saving_vdiscards_}{\.{\\savingvdiscards} primitive@>
+primitive("savinghyphcodes",assign_int,int_base+saving_hyph_codes_code);@/
+@!@:saving_hyph_codes_}{\.{\\savinghyphcodes} primitive@>
+primitive("suppressfontnotfounderror",assign_int,int_base+suppress_fontnotfound_error_code);@/
+@!@:suppress_fontnotfound_error_codes_}{\.{\\suppressfontnotfounderror} primitive@>
+
+@ @d every_eof==equiv(every_eof_loc)
+
+@<Cases of |assign_toks| for |print_cmd_chr|@>=
+every_eof_loc: print_esc("everyeof");
+
+@ @<Cases for |print_param|@>=
+tracing_assigns_code:print_esc("tracingassigns");
+tracing_groups_code:print_esc("tracinggroups");
+tracing_ifs_code:print_esc("tracingifs");
+tracing_scan_tokens_code:print_esc("tracingscantokens");
+tracing_nesting_code:print_esc("tracingnesting");
+pre_display_direction_code:print_esc("predisplaydirection");
+last_line_fit_code:print_esc("lastlinefit");
+saving_vdiscards_code:print_esc("savingvdiscards");
+saving_hyph_codes_code:print_esc("savinghyphcodes");
+suppress_fontnotfound_error_code:print_esc("suppressfontnotfounderror");
+
+@ In order to handle \.{\\everyeof} we need an array |eof_seen| of
+boolean variables.
+
+@<Glob...@>=
+@!eof_seen : array[1..max_in_open] of boolean; {has eof been seen?}
+
+@ The |print_group| procedure prints the current level of grouping and
+the name corresponding to |cur_group|.
+
+@<Declare \eTeX\ procedures for tr...@>=
+procedure print_group(@!e:boolean);
+label exit;
+begin case cur_group of
+ bottom_level: begin print("bottom level"); return;
+ end;
+ simple_group,semi_simple_group:
+ begin if cur_group=semi_simple_group then print("semi ");
+ print("simple");
+ end;
+ hbox_group,adjusted_hbox_group:
+ begin if cur_group=adjusted_hbox_group then print("adjusted ");
+ print("hbox");
+ end;
+ vbox_group: print("vbox");
+ vtop_group: print("vtop");
+ align_group,no_align_group:
+ begin if cur_group=no_align_group then print("no ");
+ print("align");
+ end;
+ output_group: print("output");
+ disc_group: print("disc");
+ insert_group: print("insert");
+ vcenter_group: print("vcenter");
+ math_group,math_choice_group,math_shift_group,math_left_group:
+ begin print("math");
+ if cur_group=math_choice_group then print(" choice")
+ else if cur_group=math_shift_group then print(" shift")
+ else if cur_group=math_left_group then print(" left");
+ end;
+ end; {there are no other cases}
+print(" group (level "); print_int(qo(cur_level)); print_char(")");
+if saved(-1)<>0 then
+ begin if e then print(" entered at line ") else print(" at line ");
+ print_int(saved(-1));
+ end;
+exit:end;
+
+@ The |group_trace| procedure is called when a new level of grouping
+begins (|e=false|) or ends (|e=true|) with |saved(-1)| containing the
+line number.
+
+@<Declare \eTeX\ procedures for tr...@>=
+@!stat procedure group_trace(@!e:boolean);
+begin begin_diagnostic; print_char("{");
+if e then print("leaving ") else print("entering ");
+print_group(e); print_char("}"); end_diagnostic(false);
+end;
+tats
+
+@ The \.{\\currentgrouplevel} and \.{\\currentgrouptype} commands return
+the current level of grouping and the type of the current group
+respectively.
+
+@d current_group_level_code=eTeX_int+1 {code for \.{\\currentgrouplevel}}
+@d current_group_type_code=eTeX_int+2 {code for \.{\\currentgrouptype}}
+
+@<Generate all \eTeX...@>=
+primitive("currentgrouplevel",last_item,current_group_level_code);
+@!@:current_group_level_}{\.{\\currentgrouplevel} primitive@>
+primitive("currentgrouptype",last_item,current_group_type_code);
+@!@:current_group_type_}{\.{\\currentgrouptype} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+current_group_level_code: print_esc("currentgrouplevel");
+current_group_type_code: print_esc("currentgrouptype");
+
+@ @<Cases for fetching an integer value@>=
+current_group_level_code: cur_val:=cur_level-level_one;
+current_group_type_code: cur_val:=cur_group;
+
+@ The \.{\\currentiflevel}, \.{\\currentiftype}, and
+\.{\\currentifbranch} commands return the current level of conditionals
+and the type and branch of the current conditional.
+
+@d current_if_level_code=eTeX_int+3 {code for \.{\\currentiflevel}}
+@d current_if_type_code=eTeX_int+4 {code for \.{\\currentiftype}}
+@d current_if_branch_code=eTeX_int+5 {code for \.{\\currentifbranch}}
+
+@<Generate all \eTeX...@>=
+primitive("currentiflevel",last_item,current_if_level_code);
+@!@:current_if_level_}{\.{\\currentiflevel} primitive@>
+primitive("currentiftype",last_item,current_if_type_code);
+@!@:current_if_type_}{\.{\\currentiftype} primitive@>
+primitive("currentifbranch",last_item,current_if_branch_code);
+@!@:current_if_branch_}{\.{\\currentifbranch} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+current_if_level_code: print_esc("currentiflevel");
+current_if_type_code: print_esc("currentiftype");
+current_if_branch_code: print_esc("currentifbranch");
+
+@ @<Cases for fetching an integer value@>=
+current_if_level_code: begin q:=cond_ptr; cur_val:=0;
+ while q<>null do
+ begin incr(cur_val); q:=vlink(q);
+ end;
+ end;
+current_if_type_code: if cond_ptr=null then cur_val:=0
+ else if cur_if<unless_code then cur_val:=cur_if+1
+ else cur_val:=-(cur_if-unless_code+1);
+current_if_branch_code:
+ if (if_limit=or_code)or(if_limit=else_code) then cur_val:=1
+ else if if_limit=fi_code then cur_val:=-1
+ else cur_val:=0;
+
+@ The \.{\\fontcharwd}, \.{\\fontcharht}, \.{\\fontchardp}, and
+\.{\\fontcharic} commands return information about a character in a
+font.
+
+@d font_char_wd_code=eTeX_dim {code for \.{\\fontcharwd}}
+@d font_char_ht_code=eTeX_dim+1 {code for \.{\\fontcharht}}
+@d font_char_dp_code=eTeX_dim+2 {code for \.{\\fontchardp}}
+@d font_char_ic_code=eTeX_dim+3 {code for \.{\\fontcharic}}
+
+@<Generate all \eTeX...@>=
+primitive("charwd",last_item,font_char_wd_code);
+primitive("fontcharwd",last_item,font_char_wd_code);
+@!@:font_char_wd_}{\.{\\fontcharwd} primitive@>
+primitive("charht",last_item,font_char_ht_code);
+primitive("fontcharht",last_item,font_char_ht_code);
+@!@:font_char_ht_}{\.{\\fontcharht} primitive@>
+primitive("chardp",last_item,font_char_dp_code);
+primitive("fontchardp",last_item,font_char_dp_code);
+@!@:font_char_dp_}{\.{\\fontchardp} primitive@>
+primitive("charic",last_item,font_char_ic_code);
+primitive("fontcharic",last_item,font_char_ic_code);
+@!@:font_char_ic_}{\.{\\fontcharic} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+font_char_wd_code: print_esc("fontcharwd");
+font_char_ht_code: print_esc("fontcharht");
+font_char_dp_code: print_esc("fontchardp");
+font_char_ic_code: print_esc("fontcharic");
+
+@ @<Cases for fetching a dimension value@>=
+font_char_wd_code,
+font_char_ht_code,
+font_char_dp_code,
+font_char_ic_code: begin scan_font_ident; q:=cur_val; scan_char_num;
+ if char_exists(q,cur_val) then
+ begin
+ case m of
+ font_char_wd_code: cur_val:=char_width(q,cur_val);
+ font_char_ht_code: cur_val:=char_height(q,cur_val);
+ font_char_dp_code: cur_val:=char_depth(q,cur_val);
+ font_char_ic_code: cur_val:=char_italic(q,cur_val);
+ end; {there are no other cases}
+ end
+ else cur_val:=0;
+ end;
+
+@ The \.{\\parshapedimen}, \.{\\parshapeindent}, and \.{\\parshapelength}
+commands return the indent and length parameters of the current
+\.{\\parshape} specification.
+
+@d par_shape_length_code=eTeX_dim+4 {code for \.{\\parshapelength}}
+@d par_shape_indent_code=eTeX_dim+5 {code for \.{\\parshapeindent}}
+@d par_shape_dimen_code=eTeX_dim+6 {code for \.{\\parshapedimen}}
+
+@<Generate all \eTeX...@>=
+primitive("parshapelength",last_item,par_shape_length_code);
+@!@:par_shape_length_}{\.{\\parshapelength} primitive@>
+primitive("parshapeindent",last_item,par_shape_indent_code);
+@!@:par_shape_indent_}{\.{\\parshapeindent} primitive@>
+primitive("parshapedimen",last_item,par_shape_dimen_code);
+@!@:par_shape_dimen_}{\.{\\parshapedimen} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+par_shape_length_code: print_esc("parshapelength");
+par_shape_indent_code: print_esc("parshapeindent");
+par_shape_dimen_code: print_esc("parshapedimen");
+
+@ @<Cases for fetching a dimension value@>=
+par_shape_length_code,
+par_shape_indent_code,
+par_shape_dimen_code: begin q:=cur_chr-par_shape_length_code; scan_int;
+ if (par_shape_ptr=null)or(cur_val<=0) then cur_val:=0
+ else begin if q=2 then
+ begin q:=cur_val mod 2; cur_val:=(cur_val+q)div 2;
+ end;
+ if cur_val>vinfo(par_shape_ptr) then cur_val:=vinfo(par_shape_ptr);
+ cur_val:=vmem(par_shape_ptr+2*cur_val-q).sc;
+ end;
+ cur_val_level:=dimen_val;
+ end;
+
+@ The \.{\\showgroups} command displays all currently active grouping
+levels.
+
+@d show_groups=4 { \.{\\showgroups} }
+
+@<Generate all \eTeX...@>=
+primitive("showgroups",xray,show_groups);
+@!@:show_groups_}{\.{\\showgroups} primitive@>
+
+@ @<Cases of |xray| for |print_cmd_chr|@>=
+show_groups:print_esc("showgroups");
+
+@ @<Cases for |show_whatever|@>=
+show_groups: begin begin_diagnostic; show_save_groups;
+ end;
+
+@ @<Types...@>=
+@!save_pointer=0..save_size; {index into |save_stack|}
+
+@ The modifications of \TeX\ required for the display produced by the
+|show_save_groups| procedure were first discussed by Donald~E. Knuth in
+{\sl TUGboat\/} {\bf 11}, 165--170 and 499--511, 1990.
+@^Knuth, Donald Ervin@>
+
+In order to understand a group type we also have to know its mode.
+Since unrestricted horizontal modes are not associated with grouping,
+they are skipped when traversing the semantic nest.
+
+@<Declare \eTeX\ procedures for use...@>=
+procedure show_save_groups;
+label found1,found2,found,done;
+var p:0..nest_size; {index into |nest|}
+@!m:-mmode..mmode; {mode}
+@!v:save_pointer; {saved value of |save_ptr|}
+@!l:quarterword; {saved value of |cur_level|}
+@!c:group_code; {saved value of |cur_group|}
+@!a:-1..1; {to keep track of alignments}
+@!i:integer;
+@!j:quarterword;
+@!s:str_number;
+begin p:=nest_ptr; nest[p]:=cur_list; {put the top level into the array}
+v:=save_ptr; l:=cur_level; c:=cur_group;
+save_ptr:=cur_boundary; decr(cur_level);@/
+a:=1; s:="";
+print_nl(""); print_ln;
+loop@+begin print_nl("### "); print_group(true);
+ if cur_group=bottom_level then goto done;
+ repeat m:=nest[p].mode_field;
+ if p>0 then decr(p) else m:=vmode;
+ until m<>hmode;
+ print(" (");
+ case cur_group of
+ simple_group: begin incr(p); goto found2;
+ end;
+ hbox_group,adjusted_hbox_group: s:="hbox";
+ vbox_group: s:="vbox";
+ vtop_group: s:="vtop";
+ align_group: if a=0 then
+ begin if m=-vmode then s:="halign" else s:="valign";
+ a:=1; goto found1;
+ end
+ else begin if a=1 then print("align entry") else print_esc("cr");
+ if p>=a then p:=p-a;
+ a:=0; goto found;
+ end;
+ no_align_group:
+ begin incr(p); a:=-1; print_esc("noalign"); goto found2;
+ end;
+ output_group:
+ begin print_esc("output"); goto found;
+ end;
+ math_group: goto found2;
+ disc_group,math_choice_group:
+ begin if cur_group=disc_group then print_esc("discretionary")
+ else print_esc("mathchoice");
+ for i:=1 to 3 do if i<=saved(-2) then print("{}");
+ goto found2;
+ end;
+ insert_group:
+ begin if saved(-2)=255 then print_esc("vadjust")
+ else begin print_esc("insert"); print_int(saved(-2));
+ end;
+ goto found2;
+ end;
+ vcenter_group: begin s:="vcenter"; goto found1;
+ end;
+ semi_simple_group: begin incr(p); print_esc("begingroup"); goto found;
+ end;
+ math_shift_group:
+ begin if m=mmode then print_char("$")
+ else if nest[p].mode_field=mmode then
+ begin print_cmd_chr(eq_no,saved(-2)); goto found;
+ end;
+ print_char("$"); goto found;
+ end;
+ math_left_group:
+ begin if type(nest[p+1].eTeX_aux_field)=left_noad then print_esc("left")
+ else print_esc("middle");
+ goto found;
+ end;
+ end; {there are no other cases}
+ @<Show the box context@>;
+ found1: print_esc(s); @<Show the box packaging info@>;
+ found2: print_char("{");
+ found: print_char(")"); decr(cur_level);
+ cur_group:=save_level(save_ptr); save_ptr:=save_index(save_ptr)
+ end;
+done: save_ptr:=v; cur_level:=l; cur_group:=c;
+end;
+
+@ @<Show the box packaging info@>=
+if saved(-2)<>0 then
+ begin print_char(" ");
+ if saved(-3)=exactly then print("to") else print("spread");
+ print_scaled(saved(-2)); print("pt");
+ end
+
+@ @<Show the box context@>=
+i:=saved(-4);
+if i<>0 then
+ if i<box_flag then
+ begin if abs(nest[p].mode_field)=vmode then j:=hmove else j:=vmove;
+ if i>0 then print_cmd_chr(j,0) else print_cmd_chr(j,1);
+ print_scaled(abs(i)); print("pt");
+ end
+ else if i<ship_out_flag then
+ begin if i>=global_box_flag then
+ begin print_esc("global"); i:=i-(global_box_flag-box_flag);
+ end;
+ print_esc("setbox"); print_int(i-box_flag); print_char("=");
+ end
+ else print_cmd_chr(leader_ship,i-(leader_flag-a_leaders))
+
+@ The |scan_general_text| procedure is much like |scan_toks(false,false)|,
+but will be invoked via |expand|, i.e., recursively.
+@^recursion@>
+
+@<Declare \eTeX\ procedures for sc...@>=
+procedure@?scan_general_text; forward;@t\2@>
+
+@ The token list (balanced text) created by |scan_general_text| begins
+at |link(temp_token_head)| and ends at |cur_val|. (If |cur_val=temp_token_head|,
+the list is empty.)
+
+@<Declare \eTeX\ procedures for tok...@>=
+procedure scan_general_text;
+label found;
+var s:normal..absorbing; {to save |scanner_status|}
+@!w:pointer; {to save |warning_index|}
+@!d:pointer; {to save |def_ref|}
+@!p:pointer; {tail of the token list being built}
+@!q:pointer; {new node being added to the token list via |store_new_token|}
+@!unbalance:halfword; {number of unmatched left braces}
+begin s:=scanner_status; w:=warning_index; d:=def_ref;
+scanner_status:=absorbing; warning_index:=cur_cs;
+p:=get_avail; def_ref:=p; token_ref_count(def_ref):=0; p:=def_ref;
+scan_left_brace; {remove the compulsory left brace}
+unbalance:=1;
+loop@+ begin get_token;
+ if cur_tok<right_brace_limit then
+ if cur_cmd<right_brace then incr(unbalance)
+ else begin decr(unbalance);
+ if unbalance=0 then goto found;
+ end;
+ store_new_token(cur_tok);
+ end;
+found: q:=link(def_ref); free_avail(def_ref); {discard reference count}
+if q=null then cur_val:=temp_token_head @+ else cur_val:=p;
+link(temp_token_head):=q;
+scanner_status:=s; warning_index:=w; def_ref:=d;
+end;
+
+@ The \.{\\showtokens} command displays a token list.
+
+@d show_tokens=5 { \.{\\showtokens} , must be odd! }
+
+@<Generate all \eTeX...@>=
+primitive("showtokens",xray,show_tokens);
+@!@:show_tokens_}{\.{\\showtokens} primitive@>
+
+@ @<Cases of |xray| for |print_cmd_chr|@>=
+show_tokens:print_esc("showtokens");
+
+@ The \.{\\unexpanded} primitive prevents expansion of tokens much as
+the result from \.{\\the} applied to a token variable. The
+\.{\\detokenize} primitive converts a token list into a list of
+character tokens much as if the token list were written to a file. We
+use the fact that the command modifiers for \.{\\unexpanded} and
+\.{\\detokenize} are odd whereas those for \.{\\the} and \.{\\showthe}
+are even.
+
+@<Generate all \eTeX...@>=
+primitive("unexpanded",the,1);@/
+@!@:unexpanded_}{\.{\\unexpanded} primitive@>
+primitive("detokenize",the,show_tokens);@/
+@!@:detokenize_}{\.{\\detokenize} primitive@>
+
+@ @<Cases of |the| for |print_cmd_chr|@>=
+else if chr_code=1 then print_esc("unexpanded")
+else print_esc("detokenize")
+
+@ @<Handle \.{\\unexpanded} or \.{\\detokenize} and |return|@>=
+if odd(cur_chr) then
+ begin c:=cur_chr; scan_general_text;
+ if c=1 then the_toks:=cur_val
+ else begin old_setting:=selector; selector:=new_string; b:=pool_ptr;
+ p:=get_avail; link(p):=link(temp_token_head);
+ token_show(p); flush_list(p);
+ selector:=old_setting; the_toks:=str_toks(b);
+ end;
+ return;
+ end
+
+@ The \.{\\showifs} command displays all currently active conditionals.
+
+@d show_ifs=6 { \.{\\showifs} }
+
+@<Generate all \eTeX...@>=
+primitive("showifs",xray,show_ifs);
+@!@:show_ifs_}{\.{\\showifs} primitive@>
+
+@ @<Cases of |xray| for |print_cmd_chr|@>=
+show_ifs:print_esc("showifs");
+
+@
+@d print_if_line(#)==if #<>0 then
+ begin print(" entered on line "); print_int(#);
+ end
+
+@<Cases for |show_whatever|@>=
+show_ifs: begin begin_diagnostic; print_nl(""); print_ln;
+ if cond_ptr=null then
+ begin print_nl("### "); print("no active conditionals");
+ end
+ else begin p:=cond_ptr; n:=0;
+ repeat incr(n); p:=vlink(p);@+until p=null;
+ p:=cond_ptr; t:=cur_if; l:=if_line; m:=if_limit;
+ repeat print_nl("### level "); print_int(n); print(": ");
+ print_cmd_chr(if_test,t);
+ if m=fi_code then print_esc("else");
+ print_if_line(l);
+ decr(n); t:=if_limit_subtype(p); l:=if_line_field(p); m:=if_limit_type(p); p:=vlink(p);
+ until p=null;
+ end;
+ end;
+
+@ The \.{\\interactionmode} primitive allows to query and set the
+interaction mode.
+
+@<Generate all \eTeX...@>=
+primitive("interactionmode",set_page_int,2);
+@!@:interaction_mode_}{\.{\\interactionmode} primitive@>
+
+@ @<Cases of |set_page_int| for |print_cmd_chr|@>=
+else if chr_code=2 then print_esc("interactionmode")
+
+@ @<Cases for `Fetch the |dead_cycles| or the |insert_penalties|'@>=
+else if m=2 then cur_val:=interaction
+
+@ @<Declare \eTeX\ procedures for use...@>=
+procedure@?new_interaction; forward;@t\2@>
+
+@ @<Cases for |alter_integer|@>=
+else if c=2 then
+ begin if (cur_val<batch_mode)or(cur_val>error_stop_mode) then
+ begin print_err("Bad interaction mode");
+@.Bad interaction mode@>
+ help2("Modes are 0=batch, 1=nonstop, 2=scroll, and")@/
+ ("3=errorstop. Proceed, and I'll ignore this case.");
+ int_error(cur_val);
+ end
+ else begin cur_chr:=cur_val; new_interaction;
+ end;
+ end
+
+@ The |middle| feature of \eTeX\ allows one ore several \.{\\middle}
+delimiters to appear between \.{\\left} and \.{\\right}.
+
+@<Generate all \eTeX...@>=
+primitive("middle",left_right,middle_noad);
+@!@:middle_}{\.{\\middle} primitive@>
+
+@ @<Cases of |left_right| for |print_cmd_chr|@>=
+else if chr_code=middle_noad then print_esc("middle")
+
+@ The |scan_tokens| feature of \eTeX\ defines the \.{\\scantokens}
+primitive.
+
+@<Generate all \eTeX...@>=
+primitive("scantokens",input,2);
+@!@:scan_tokens_}{\.{\\scantokens} primitive@>
+primitive("scantextokens",input,3);
+@!@:scan_tex_tokens_}{\.{\\scantextokens} primitive@>
+
+@ @<Cases of |input| for |print_cmd_chr|@>=
+else if chr_code=2 then print_esc("scantokens")
+else if chr_code=3 then print_esc("scantextokens")
+
+@ @<Cases for |input|@>=
+else if cur_chr=2 then pseudo_start
+else if cur_chr=3 then begin pseudo_start; name := 19; end
+
+@ The global variable |pseudo_files| is used to maintain a stack of
+pseudo files. The |pseudo_lines| field of each pseudo file points to
+a linked list of variable size nodes representing lines not yet
+processed: the |subtype| field contains the size of this node,
+all the following words contain ASCII codes.
+
+@<Glob...@>=
+@!pseudo_files:pointer; {stack of pseudo files}
+
+@ @<Set init...@>=
+pseudo_files:=null;
+
+@ The |pseudo_start| procedure initiates reading from a pseudo file.
+
+@<Declare \eTeX\ procedures for ex...@>=
+procedure@?pseudo_start; forward;@t\2@>
+
+@ @<Declare \eTeX\ procedures for tok...@>=
+procedure pseudo_start;
+var old_setting:0..max_selector; {holds |selector| setting}
+@!s:str_number; {string to be converted into a pseudo file}
+@!p:pointer; {for list construction}
+begin scan_general_text;
+old_setting:=selector; selector:=new_string;
+token_show(temp_token_head); selector:=old_setting;
+flush_list(link(temp_token_head));
+str_room(1); s:=make_string;
+@<Convert string |s| into a new pseudo file@>;
+flush_string;
+@<Initiate input from new pseudo file@>;
+end;
+
+procedure pseudo_from_string;
+var @!s:str_number; {string to be converted into a pseudo file}
+@!p:pointer; {for list construction}
+begin
+s:=make_string;
+@<Convert string |s| into a new pseudo file@>;
+flush_string;
+@<Initiate input from new pseudo file@>;
+end;
+
+procedure lua_string_start;
+begin
+begin_file_reading; {set up |cur_file| and new level of input}
+line:=0; limit:=start; loc:=limit+1; {force line read}
+name:=21; luacstring_start(index);
+end;
+
+@ @<Convert string |s| into a new pseudo file@>=
+str_pool[pool_ptr]:=si(" ");
+p:=string_to_pseudo(str_start_macro(s),pool_ptr,new_line_char);
+vlink(p):=pseudo_files; pseudo_files:=p
+
+@ @<Initiate input from new pseudo file@>=
+begin_file_reading; {set up |cur_file| and new level of input}
+line:=0; limit:=start; loc:=limit+1; {force line read}
+if tracing_scan_tokens>0 then
+ begin if term_offset>max_print_line-3 then print_ln
+ else if (term_offset>0)or(file_offset>0) then print_char(" ");
+ name:=20; print("( "); incr(open_parens); update_terminal;
+ end
+else name:=18
+
+@ Here we read a line from the current pseudo file into |buffer|.
+
+@d pseudo_lines(#)==vlink(#+1)
+
+@<Declare \eTeX\ procedures for tr...@>=
+function pseudo_input: boolean; {inputs the next line or returns |false|}
+var p:pointer; {current line from pseudo file}
+@!sz:integer; {size of node |p|}
+@!w:four_quarters; {four ASCII codes}
+@!r:pointer; {loop index}
+begin last:=first; {cf.\ Matthew 19\thinspace:\thinspace30}
+p:=pseudo_lines(pseudo_files);
+if p=null then begin pseudo_input:=false; end
+else begin pseudo_lines(pseudo_files):=vlink(p); sz:=subtype(p);
+ if 4*sz-3>=buf_size-last then
+ check_buffer_overflow(last+4*sz);
+ last:=first;
+ for r:=p+1 to p+sz-1 do
+ begin w:=vmem(r).qqqq;
+ buffer[last]:=w.b0; buffer[last+1]:=w.b1;
+ buffer[last+2]:=w.b2; buffer[last+3]:=w.b3;
+ last:=last+4;
+ end;
+ if last>=max_buf_stack then max_buf_stack:=last+1;
+ while (last>first)and(buffer[last-1]=" ") do decr(last);
+ flush_node(p);
+ pseudo_input:=true;
+ end;
+end;
+
+@ When we are done with a pseudo file we `close' it.
+
+@<Declare \eTeX\ procedures for tr...@>=
+procedure pseudo_close; {close the top level pseudo file}
+var p,@!q: pointer;
+begin p:=vlink(pseudo_files);
+flush_node(pseudo_files);
+pseudo_files:=p;
+end;
+
+@ @<Close the pseudo files@>=
+while pseudo_files<>null do pseudo_close; {flush pseudo files}
+
+@ @<Generate all \eTeX...@>=
+primitive("readline",read_to_cs,1);@/
+@!@:read_line_}{\.{\\readline} primitive@>
+
+@ @<Cases of |read| for |print_cmd_chr|@>=
+else print_esc("readline")
+
+@ @<Handle \.{\\readline} and |goto done|@>=
+if j=1 then
+ begin while loc<=limit do {current line not yet finished}
+ begin cur_chr:=buffer[loc]; incr(loc);
+ if cur_chr=" " then cur_tok:=space_token
+ @+else cur_tok:=cur_chr+other_token;
+ store_new_token(cur_tok);
+ end;
+ goto done;
+ end
+
+@ Here we define the additional conditionals of \eTeX\ as well as the
+\.{\\unless} prefix.
+
+@d if_def_code=17 { `\.{\\ifdefined}' }
+@d if_cs_code=18 { `\.{\\ifcsname}' }
+@d if_font_char_code=19 { `\.{\\iffontchar}' }
+@d if_in_csname_code=20 { `\.{\\ifincsname}' }
+@d if_abs_num_code=22 { `\.{\\ifabsnum}' } { 21 = |if_primitive|}
+@d if_abs_dim_code=23 { `\.{\\ifabsdim}' }
+
+@<Generate all \eTeX...@>=
+primitive("unless",expand_after,1);@/
+@!@:unless_}{\.{\\unless} primitive@>
+primitive("ifdefined",if_test,if_def_code);
+@!@:if_defined_}{\.{\\ifdefined} primitive@>
+primitive("ifcsname",if_test,if_cs_code);
+@!@:if_cs_name_}{\.{\\ifcsname} primitive@>
+primitive("iffontchar",if_test,if_font_char_code);
+@!@:if_font_char_}{\.{\\iffontchar} primitive@>
+primitive("ifincsname",if_test,if_in_csname_code);
+@!@:if_in_csname_}{\.{\\ifincsname} primitive@>
+primitive("ifabsnum",if_test,if_abs_num_code);
+@!@:if_abs_num_}{\.{\\ifabsnum} primitive@>
+primitive("ifabsdim",if_test,if_abs_dim_code);
+@!@:if_abs_dim_}{\.{\\ifabsdim} primitive@>
+primitive("ifpdfabsnum",if_test,if_abs_num_code);
+@!@:if_abs_num_}{\.{\\ifpdfabsnum} primitive@>
+primitive("ifpdfabsdim",if_test,if_abs_dim_code);
+@!@:if_abs_dim_}{\.{\\ifpdfabsdim} primitive@>
+
+@ @<Cases of |expandafter| for |print_cmd_chr|@>=
+else print_esc("unless")
+
+@ @<Cases of |if_test| for |print_cmd_chr|@>=
+if_def_code:print_esc("ifdefined");
+if_cs_code:print_esc("ifcsname");
+if_font_char_code:print_esc("iffontchar");
+if_in_csname_code:print_esc("ifincsname");
+if_abs_num_code:print_esc("ifabsnum");
+if_abs_dim_code:print_esc("ifabsdim");
+
+@ The result of a boolean condition is reversed when the conditional is
+preceded by \.{\\unless}.
+
+@<Negate a boolean conditional and |goto reswitch|@>=
+begin get_token;
+if (cur_cmd=if_test)and(cur_chr<>if_case_code) then
+ begin cur_chr:=cur_chr+unless_code; goto reswitch;
+ end;
+print_err("You can't use `"); print_esc("unless"); print("' before `");
+@.You can't use \\unless...@>
+print_cmd_chr(cur_cmd,cur_chr); print_char("'");
+help1("Continue, and I'll forget that it ever happened.");
+back_error;
+end
+
+@ The conditional \.{\\ifdefined} tests if a control sequence is
+defined.
+
+We need to reset |scanner_status|, since \.{\\outer} control sequences
+are allowed, but we might be scanning a macro definition or preamble.
+
+@<Cases for |conditional|@>=
+if_def_code:begin save_scanner_status:=scanner_status;
+ scanner_status:=normal;
+ get_filtered_next; b:=(cur_cmd<>undefined_cs);
+ scanner_status:=save_scanner_status;
+ end;
+
+@ The conditional \.{\\ifcsname} is equivalent to \.{\{\\expandafter}
+\.{\}\\expandafter} \.{\\ifdefined} \.{\\csname}, except that no new
+control sequence will be entered into the hash table (once all tokens
+preceding the mandatory \.{\\endcsname} have been expanded).
+
+@<Cases for |conditional|@>=
+if_cs_code:begin n:=get_avail; p:=n; {head of the list of characters}
+ b:=false;
+ repeat get_x_token;
+ if cur_cs=0 then store_new_token(cur_tok);
+ until cur_cs<>0;
+ if cur_cmd<>end_cs_name then @<Complain about missing \.{\\endcsname}@>;
+ @<Look up the characters of list |n| in the hash table, and set |cur_cs|@>;
+ flush_list(n);
+ b:=(eq_type(cur_cs)<>undefined_cs);
+ end;
+
+@ @<Look up the characters of list |n| in the hash table...@>=
+m:=first; p:=link(n);
+while p<>null do
+ begin if m>=max_buf_stack then
+ begin max_buf_stack:=m+4;
+ if max_buf_stack=buf_size then
+ check_buffer_overflow(max_buf_stack);
+@:TeX capacity exceeded buffer size}{\quad buffer size@>
+ end;
+ s := info(p) mod string_offset;
+ if s <= @"7F then begin
+ buffer[m]:=s; incr(m);
+ end
+ else if s<=@"7FF then begin
+ buffer[m]:=@"C0 + s div @"40; incr(m);
+ buffer[m]:=@"80 + s mod @"40; incr(m);
+ end
+ else if s<=@"FFFF then begin
+ buffer[m]:=@"E0 + s div @"1000; incr(m);
+ buffer[m]:=@"80 + (s mod @"1000) div @"40; incr(m);
+ buffer[m]:=@"80 + (s mod @"1000) mod @"40; incr(m);
+ end
+ else begin
+ buffer[m]:=@"F0 + s div @"40000; incr(m);
+ buffer[m]:=@"80 + (s mod @"40000) div @"1000; incr(m);
+ buffer[m]:=@"80 + ((s mod @"40000) mod @"1000) div @"40; incr(m);
+ buffer[m]:=@"80 + ((s mod @"40000) mod @"1000) mod @"40; incr(m);
+ end;
+ p:=link(p);
+ end;
+if m>first then
+ cur_cs:=id_lookup(first,m-first) {|no_new_control_sequence| is |true|}
+else if m=first then cur_cs:=null_cs {the list is empty}
+
+@ The conditional \.{\\iffontchar} tests the existence of a character in
+a font.
+
+@<Cases for |conditional|@>=
+if_in_csname_code: b := is_in_csname;
+if_abs_dim_code, if_abs_num_code: begin
+ if this_if=if_abs_num_code then scan_int@+else scan_normal_dimen;
+ n:=cur_val;
+ if n < 0 then negate(n);
+ @<Get the next non-blank non-call...@>;
+ if (cur_tok>=other_token+"<")and(cur_tok<=other_token+">") then
+ r:=cur_tok-other_token
+ else begin print_err("Missing = inserted for ");
+ @.Missing = inserted@>
+ print_cmd_chr(if_test,this_if);
+ help1("I was expecting to see `<', `=', or `>'. Didn't.");
+ back_error; r:="=";
+ end;
+ if this_if=if_abs_num_code then scan_int@+else scan_normal_dimen;
+ if cur_val < 0 then negate(cur_val);
+ case r of
+ "<": b:=(n<cur_val);
+ "=": b:=(n=cur_val);
+ ">": b:=(n>cur_val);
+ end;
+ end;
+if_font_char_code:begin scan_font_ident; n:=cur_val; scan_char_num;
+ b:=char_exists(n,cur_val);
+ end;
+
+@ The |protected| feature of \eTeX\ defines the \.{\\protected} prefix
+command for macro definitions. Such macros are protected against
+expansions when lists of expanded tokens are built, e.g., for \.{\\edef}
+or during \.{\\write}.
+
+@<Generate all \eTeX...@>=
+primitive("protected",prefix,8);
+@!@:protected_}{\.{\\protected} primitive@>
+
+@ @<Cases of |prefix| for |print_cmd_chr|@>=
+else if chr_code=8 then print_esc("protected")
+
+@ The |get_x_or_protected| procedure is like |get_x_token| except that
+protected macros are not expanded.
+
+@<Declare \eTeX\ procedures for sc...@>=
+procedure get_x_or_protected; {sets |cur_cmd|, |cur_chr|, |cur_tok|,
+ and expands non-protected macros}
+label exit;
+begin loop@+begin get_token;
+ if cur_cmd<=max_command then return;
+ if (cur_cmd>=call)and(cur_cmd<end_template) then
+ if info(link(cur_chr))=protected_token then return;
+ expand;
+ end;
+exit:end;
+
+@ A group entered (or a conditional started) in one file may end in a
+different file. Such slight anomalies, although perfectly legitimate,
+may cause errors that are difficult to locate. In order to be able to
+give a warning message when such anomalies occur, \eTeX\ uses the
+|grp_stack| and |if_stack| arrays to record the initial |cur_boundary|
+and |cond_ptr| values for each input file.
+
+@<Glob...@>=
+@!grp_stack : array[0..max_in_open] of save_pointer; {initial |cur_boundary|}
+@!if_stack : array[0..max_in_open] of pointer; {initial |cond_ptr|}
+
+@ When a group ends that was apparently entered in a different input
+file, the |group_warning| procedure is invoked in order to update the
+|grp_stack|. If moreover \.{\\tracingnesting} is positive we want to
+give a warning message. The situation is, however, somewhat complicated
+by two facts: (1)~There may be |grp_stack| elements without a
+corresponding \.{\\input} file or \.{\\scantokens} pseudo file (e.g.,
+error insertions from the terminal); and (2)~the relevant information is
+recorded in the |name_field| of the |input_stack| only loosely
+synchronized with the |in_open| variable indexing |grp_stack|.
+
+@<Declare \eTeX\ procedures for tr...@>=
+procedure group_warning;
+var i:0..max_in_open; {index into |grp_stack|}
+@!w:boolean; {do we need a warning?}
+begin base_ptr:=input_ptr; input_stack[base_ptr]:=cur_input;
+ {store current state}
+i:=in_open; w:=false;
+while (grp_stack[i]=cur_boundary)and(i>0) do
+ begin @<Set variable |w| to indicate if this case should be reported@>;
+ grp_stack[i]:=save_index(save_ptr); decr(i);
+ end;
+if w then
+ begin print_nl("Warning: end of "); print_group(true);
+@.Warning: end of...@>
+ print(" of a different file"); print_ln;
+ if tracing_nesting>1 then show_context;
+ if history=spotless then history:=warning_issued;
+ end;
+end;
+
+@ This code scans the input stack in order to determine the type of the
+current input file.
+
+@<Set variable |w| to...@>=
+if tracing_nesting>0 then
+ begin while (input_stack[base_ptr].state_field=token_list)or@|
+ (input_stack[base_ptr].index_field>i) do decr(base_ptr);
+ if input_stack[base_ptr].name_field>17 then w:=true;
+ end
+
+@ When a conditional ends that was apparently started in a different
+input file, the |if_warning| procedure is invoked in order to update the
+|if_stack|. If moreover \.{\\tracingnesting} is positive we want to
+give a warning message (with the same complications as above).
+
+@<Declare \eTeX\ procedures for tr...@>=
+procedure if_warning;
+var i:0..max_in_open; {index into |if_stack|}
+@!w:boolean; {do we need a warning?}
+begin base_ptr:=input_ptr; input_stack[base_ptr]:=cur_input;
+ {store current state}
+i:=in_open; w:=false;
+while if_stack[i]=cond_ptr do
+ begin @<Set variable |w| to...@>;
+ if_stack[i]:=vlink(cond_ptr); decr(i);
+ end;
+if w then
+ begin print_nl("Warning: end of "); print_cmd_chr(if_test,cur_if);
+@.Warning: end of...@>
+ print_if_line(if_line); print(" of a different file"); print_ln;
+ if tracing_nesting>1 then show_context;
+ if history=spotless then history:=warning_issued;
+ end;
+end;
+
+@ Conversely, the |file_warning| procedure is invoked when a file ends
+and some groups entered or conditionals started while reading from that
+file are still incomplete.
+
+@<Declare \eTeX\ procedures for tr...@>=
+procedure file_warning;
+var p:pointer; {saved value of |save_ptr| or |cond_ptr|}
+@!l:quarterword; {saved value of |cur_level| or |if_limit|}
+@!c:quarterword; {saved value of |cur_group| or |cur_if|}
+@!i:integer; {saved value of |if_line|}
+begin
+p:=save_ptr; l:=cur_level; c:=cur_group; save_ptr:=cur_boundary;
+while grp_stack[in_open]<>save_ptr do
+ begin decr(cur_level);
+ print_nl("Warning: end of file when ");
+@.Warning: end of file when...@>
+ print_group(true); print(" is incomplete");@/
+ cur_group:=save_level(save_ptr); save_ptr:=save_index(save_ptr)
+ end;
+save_ptr:=p; cur_level:=l; cur_group:=c; {restore old values}
+p:=cond_ptr; l:=if_limit; c:=cur_if; i:=if_line;
+while if_stack[in_open]<>cond_ptr do
+ begin print_nl("Warning: end of file when ");
+@.Warning: end of file when...@>
+ print_cmd_chr(if_test,cur_if);
+ if if_limit=fi_code then print_esc("else");
+ print_if_line(if_line); print(" is incomplete");@/
+ if_line:=if_line_field(cond_ptr); cur_if:=if_limit_subtype(cond_ptr);
+ if_limit:=if_limit_type(cond_ptr); cond_ptr:=vlink(cond_ptr);
+ end;
+cond_ptr:=p; if_limit:=l; cur_if:=c; if_line:=i; {restore old values}
+print_ln;
+if tracing_nesting>1 then show_context;
+if history=spotless then history:=warning_issued;
+end;
+
+@ Here are the additional \eTeX\ primitives for expressions.
+
+@<Generate all \eTeX...@>=
+primitive("numexpr",last_item,eTeX_expr-int_val+int_val);
+@!@:num_expr_}{\.{\\numexpr} primitive@>
+primitive("dimexpr",last_item,eTeX_expr-int_val+dimen_val);
+@!@:dim_expr_}{\.{\\dimexpr} primitive@>
+primitive("glueexpr",last_item,eTeX_expr-int_val+glue_val);
+@!@:glue_expr_}{\.{\\glueexpr} primitive@>
+primitive("muexpr",last_item,eTeX_expr-int_val+mu_val);
+@!@:mu_expr_}{\.{\\muexpr} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+eTeX_expr-int_val+int_val: print_esc("numexpr");
+eTeX_expr-int_val+dimen_val: print_esc("dimexpr");
+eTeX_expr-int_val+glue_val: print_esc("glueexpr");
+eTeX_expr-int_val+mu_val: print_esc("muexpr");
+
+@ This code for reducing |cur_val_level| and\slash or negating the
+result is similar to the one for all the other cases of
+|scan_something_internal|, with the difference that |scan_expr| has
+already increased the reference count of a glue specification.
+
+@<Process an expression and |return|@>=
+begin if m<eTeX_mu then
+ begin case m of
+ @/@<Cases for fetching a glue value@>@/
+ end; {there are no other cases}
+ cur_val_level:=glue_val;
+ end
+else if m<eTeX_expr then
+ begin case m of
+ @/@<Cases for fetching a mu value@>@/
+ end; {there are no other cases}
+ cur_val_level:=mu_val;
+ end
+else begin cur_val_level:=m-eTeX_expr+int_val; scan_expr;
+ end;
+while cur_val_level>level do
+ begin if cur_val_level=glue_val then
+ begin m:=cur_val; cur_val:=width(m); delete_glue_ref(m);
+ end
+ else if cur_val_level=mu_val then mu_error;
+ decr(cur_val_level);
+ end;
+if negative then
+ if cur_val_level>=glue_val then
+ begin m:=cur_val; cur_val:=new_spec(m); delete_glue_ref(m);
+ @<Negate all three glue components of |cur_val|@>;
+ end
+ else negate(cur_val);
+return;
+end
+
+@ @<Declare \eTeX\ procedures for sc...@>=
+procedure@?scan_expr; forward;@t\2@>
+
+@ The |scan_expr| procedure scans and evaluates an expression.
+
+@<Declare procedures needed for expressions@>=
+@t\4@>@<Declare subprocedures for |scan_expr|@>
+procedure scan_expr; {scans and evaluates an expression}
+label restart, continue, found;
+var a,@!b:boolean; {saved values of |arith_error|}
+@!l:small_number; {type of expression}
+@!r:small_number; {state of expression so far}
+@!s:small_number; {state of term so far}
+@!o:small_number; {next operation or type of next factor}
+@!e:integer; {expression so far}
+@!t:integer; {term so far}
+@!f:integer; {current factor}
+@!n:integer; {numerator of combined multiplication and division}
+@!p:pointer; {top of expression stack}
+@!q:pointer; {for stack manipulations}
+begin l:=cur_val_level; a:=arith_error; b:=false; p:=null;
+@<Scan and evaluate an expression |e| of type |l|@>;
+if b then
+ begin print_err("Arithmetic overflow");
+@.Arithmetic overflow@>
+ help2("I can't evaluate this expression,")@/
+ ("since the result is out of range.");
+ error;
+ if l>=glue_val then
+ begin delete_glue_ref(e); e:=zero_glue; add_glue_ref(e);
+ end
+ else e:=0;
+ end;
+arith_error:=a; cur_val:=e; cur_val_level:=l;
+end;
+
+@ Evaluating an expression is a recursive process: When the left
+parenthesis of a subexpression is scanned we descend to the next level
+of recursion; the previous level is resumed with the matching right
+parenthesis.
+
+@d expr_none=0 {\.( seen, or \.( $\langle\it expr\rangle$ \.) seen}
+@d expr_add=1 {\.( $\langle\it expr\rangle$ \.+ seen}
+@d expr_sub=2 {\.( $\langle\it expr\rangle$ \.- seen}
+@d expr_mult=3 {$\langle\it term\rangle$ \.* seen}
+@d expr_div=4 {$\langle\it term\rangle$ \./ seen}
+@d expr_scale=5 {$\langle\it term\rangle$ \.*
+ $\langle\it factor\rangle$ \./ seen}
+
+@<Scan and eval...@>=
+restart: r:=expr_none; e:=0; s:=expr_none; t:=0; n:=0;
+continue: if s=expr_none then o:=l@+else o:=int_val;
+@<Scan a factor |f| of type |o| or start a subexpression@>;
+found: @<Scan the next operator and set |o|@>;
+arith_error:=b;
+@<Make sure that |f| is in the proper range@>;
+case s of @<Cases for evaluation of the current term@>@;
+end; {there are no other cases}
+if o>expr_sub then s:=o@+else @<Evaluate the current expression@>;
+b:=arith_error;
+if o<>expr_none then goto continue;
+if p<>null then @<Pop the expression stack and |goto found|@>
+
+@ @<Scan the next op...@>=
+@<Get the next non-blank non-call token@>;
+if cur_tok=other_token+"+" then o:=expr_add
+else if cur_tok=other_token+"-" then o:=expr_sub
+else if cur_tok=other_token+"*" then o:=expr_mult
+else if cur_tok=other_token+"/" then o:=expr_div
+else begin o:=expr_none;
+ if p=null then
+ begin if cur_cmd<>relax then back_input;
+ end
+ else if cur_tok<>other_token+")" then
+ begin print_err("Missing ) inserted for expression");
+@.Missing ) inserted@>
+ help1("I was expecting to see `+', `-', `*', `/', or `)'. Didn't.");
+ back_error;
+ end;
+ end
+
+@ @<Scan a factor...@>=
+@<Get the next non-blank non-call token@>;
+if cur_tok=other_token+"(" then
+ @<Push the expression stack and |goto restart|@>;
+back_input;
+if (o=int_val)or(o=attr_val) then scan_int
+else if o=dimen_val then scan_normal_dimen
+else if o=glue_val then scan_normal_glue
+else scan_mu_glue;
+f:=cur_val
+
+@ @<Declare \eTeX\ procedures for sc...@>=
+procedure@?scan_normal_glue; forward;@t\2@>@/
+procedure@?scan_mu_glue; forward;@t\2@>
+
+@ Here we declare to trivial procedures in order to avoid mutually
+recursive procedures with parameters.
+
+@<Declare procedures needed for expressions@>=
+procedure scan_normal_glue;
+begin scan_glue(glue_val);
+end;
+@#
+procedure scan_mu_glue;
+begin scan_glue(mu_val);
+end;
+
+@ Parenthesized subexpressions can be inside expressions, and this
+nesting has a stack. Seven local variables represent the top of the
+expression stack: |p| points to pushed-down entries, if any; |l|
+specifies the type of expression currently beeing evaluated; |e| is the
+expression so far and |r| is the state of its evaluation; |t| is the
+term so far and |s| is the state of its evaluation; finally |n| is the
+numerator for a combined multiplication and division, if any.
+
+@d expr_node=39 { stack entry for subexpressions}
+@d expr_type(#)==type(#+1)
+@d expr_state(#)==subtype(#+1)
+@d expr_e_field(#)==vlink(#+1) {saved expression so far}
+@d expr_t_field(#)==vlink(#+2) {saved term so far}
+@d expr_n_field(#)==vinfo(#+2) {saved numerator}
+
+@<Push the expression...@>=
+begin q:=new_node(expr_node,0); vlink(q):=p;
+expr_type(q):=l; expr_state(q):=4*s+r;
+expr_e_field(q):=e; expr_t_field(q):=t; expr_n_field(q):=n;
+p:=q; l:=o; goto restart;
+end
+
+@ @<Pop the expression...@>=
+begin f:=e; q:=p;
+e:=expr_e_field(q); t:=expr_t_field(q); n:=expr_n_field(q);
+s:=expr_state(q) div 4; r:=expr_state(q) mod 4;
+l:=expr_type(q); p:=vlink(q); flush_node(q);
+goto found;
+end
+
+@ We want to make sure that each term and (intermediate) result is in
+the proper range. Integer values must not exceed |infinity|
+($2^{31}-1$) in absolute value, dimensions must not exceed |max_dimen|
+($2^{30}-1$). We avoid the absolute value of an integer, because this
+might fail for the value $-2^{31}$ using 32-bit arithmetic.
+
+@d num_error(#)== {clear a number or dimension and set |arith_error|}
+ begin arith_error:=true; #:=0;
+ end
+@d glue_error(#)== {clear a glue spec and set |arith_error|}
+ begin arith_error:=true; delete_glue_ref(#); #:=new_spec(zero_glue);
+ end
+
+@<Make sure that |f|...@>=
+if ((l=int_val)or(l=attr_val))or(s>expr_sub) then
+ begin if (f>infinity)or(f<-infinity) then num_error(f);
+ end
+else if l=dimen_val then
+ begin if abs(f)>max_dimen then num_error(f);
+ end
+else begin if (abs(width(f))>max_dimen)or@|
+ (abs(stretch(f))>max_dimen)or@|
+ (abs(shrink(f))>max_dimen) then glue_error(f);
+ end
+
+@ Applying the factor |f| to the partial term |t| (with the operator
+|s|) is delayed until the next operator |o| has been scanned. Here we
+handle the first factor of a partial term. A glue spec has to be copied
+unless the next operator is a right parenthesis; this allows us later on
+to simply modify the glue components.
+
+@d normalize_glue(#)==
+ if stretch(#)=0 then stretch_order(#):=normal;
+ if shrink(#)=0 then shrink_order(#):=normal
+
+@<Cases for evaluation of the current term@>=
+expr_none: if (l>=glue_val)and(o<>expr_none) then
+ begin t:=new_spec(f); delete_glue_ref(f); normalize_glue(t);
+ end
+ else t:=f;
+
+@ When a term |t| has been completed it is copied to, added to, or
+subtracted from the expression |e|.
+
+@d expr_add_sub(#)==add_or_sub(#,r=expr_sub)
+@d expr_a(#)==expr_add_sub(#,max_dimen)
+
+@<Evaluate the current expression@>=
+begin s:=expr_none;
+if r=expr_none then e:=t
+else if (l=int_val)or(l=attr_val) then e:=expr_add_sub(e,t,infinity)
+else if l=dimen_val then e:=expr_a(e,t)
+else @<Compute the sum or difference of two glue specs@>;
+r:=o;
+end
+
+@ The function |add_or_sub(x,y,max_answer,negative)| computes the sum
+(for |negative=false|) or difference (for |negative=true|) of |x| and
+|y|, provided the absolute value of the result does not exceed
+|max_answer|.
+
+@<Declare subprocedures for |scan_expr|@>=
+function add_or_sub(@!x,@!y,@!max_answer:integer;@!negative:boolean):integer;
+var a:integer; {the answer}
+begin if negative then negate(y);
+if x>=0 then
+ if y<=max_answer-x then a:=x+y@+else num_error(a)
+else if y>=-max_answer-x then a:=x+y@+else num_error(a);
+add_or_sub:=a;
+end;
+
+@ We know that |stretch_order(e)>normal| implies |stretch(e)<>0| and
+|shrink_order(e)>normal| implies |shrink(e)<>0|.
+
+@<Compute the sum or diff...@>=
+begin width(e):=expr_a(width(e),width(t));
+if stretch_order(e)=stretch_order(t) then
+ stretch(e):=expr_a(stretch(e),stretch(t))
+else if (stretch_order(e)<stretch_order(t))and(stretch(t)<>0) then
+ begin stretch(e):=stretch(t); stretch_order(e):=stretch_order(t);
+ end;
+if shrink_order(e)=shrink_order(t) then
+ shrink(e):=expr_a(shrink(e),shrink(t))
+else if (shrink_order(e)<shrink_order(t))and(shrink(t)<>0) then
+ begin shrink(e):=shrink(t); shrink_order(e):=shrink_order(t);
+ end;
+delete_glue_ref(t); normalize_glue(e);
+end
+
+@ If a multiplication is followed by a division, the two operations are
+combined into a `scaling' operation. Otherwise the term |t| is
+multiplied by the factor |f|.
+
+@d expr_m(#)==#:=nx_plus_y(#,f,0)
+
+@<Cases for evaluation of the current term@>=
+expr_mult: if o=expr_div then
+ begin n:=f; o:=expr_scale;
+ end
+ else if (l=int_val)or(l=attr_val) then t:=mult_integers(t,f)
+ else if l=dimen_val then expr_m(t)
+ else begin expr_m(width(t)); expr_m(stretch(t)); expr_m(shrink(t));
+ end;
+
+@ Here we divide the term |t| by the factor |f|.
+
+@d expr_d(#)==#:=quotient(#,f)
+
+@<Cases for evaluation of the current term@>=
+expr_div: if l<glue_val then expr_d(t)
+ else begin expr_d(width(t)); expr_d(stretch(t)); expr_d(shrink(t));
+ end;
+
+@ The function |quotient(n,d)| computes the rounded quotient
+$q=\lfloor n/d+{1\over2}\rfloor$, when $n$ and $d$ are positive.
+
+@<Declare subprocedures for |scan_expr|@>=
+function quotient(@!n,@!d:integer):integer;
+var negative:boolean; {should the answer be negated?}
+@!a:integer; {the answer}
+begin if d=0 then num_error(a)
+else begin if d>0 then negative:=false
+ else begin negate(d); negative:=true;
+ end;
+ if n<0 then
+ begin negate(n); negative:=not negative;
+ end;
+ a:=n div d; n:=n-a*d; d:=n-d; {avoid certain compiler optimizations!}
+ if d+n>=0 then incr(a);
+ if negative then negate(a);
+ end;
+quotient:=a;
+end;
+
+@ Here the term |t| is multiplied by the quotient $n/f$.
+
+@d expr_s(#)==#:=fract(#,n,f,max_dimen)
+
+@<Cases for evaluation of the current term@>=
+expr_scale: if (l=int_val)or(l=attr_val) then t:=fract(t,n,f,infinity)
+ else if l=dimen_val then expr_s(t)
+ else begin expr_s(width(t)); expr_s(stretch(t)); expr_s(shrink(t));
+ end;
+
+@ Finally, the function |fract(x,n,d,max_answer)| computes the integer
+$q=\lfloor xn/d+{1\over2}\rfloor$, when $x$, $n$, and $d$ are positive
+and the result does not exceed |max_answer|. We can't use floating
+point arithmetic since the routine must produce identical results in all
+cases; and it would be too dangerous to multiply by~|n| and then divide
+by~|d|, in separate operations, since overflow might well occur. Hence
+this subroutine simulates double precision arithmetic, somewhat
+analogous to \MF's |make_fraction| and |take_fraction| routines.
+
+@d too_big=88 {go here when the result is too big}
+
+@<Declare subprocedures for |scan_expr|@>=
+function fract(@!x,@!n,@!d,@!max_answer:integer):integer;
+label found, found1, too_big, done;
+var negative:boolean; {should the answer be negated?}
+@!a:integer; {the answer}
+@!f:integer; {a proper fraction}
+@!h:integer; {smallest integer such that |2*h>=d|}
+@!r:integer; {intermediate remainder}
+@!t:integer; {temp variable}
+begin if d=0 then goto too_big;
+a:=0;
+if d>0 then negative:=false
+else begin negate(d); negative:=true;
+ end;
+if x<0 then
+ begin negate(x); negative:=not negative;
+ end
+else if x=0 then goto done;
+if n<0 then
+ begin negate(n); negative:=not negative;
+ end;
+t:=n div d;
+if t>max_answer div x then goto too_big;
+a:=t*x; n:=n-t*d;
+if n=0 then goto found;
+t:=x div d;
+if t>(max_answer-a) div n then goto too_big;
+a:=a+t*n; x:=x-t*d;
+if x=0 then goto found;
+if x<n then
+ begin t:=x; x:=n; n:=t;
+ end; {now |0<n<=x<d|}
+@<Compute \(f)$f=\lfloor xn/d+{1\over2}\rfloor$@>@;
+if f>(max_answer-a) then goto too_big;
+a:=a+f;
+found: if negative then negate(a);
+goto done;
+too_big: num_error(a);
+done: fract:=a;
+end;
+
+@ The loop here preserves the following invariant relations
+between |f|, |x|, |n|, and~|r|:
+(i)~$f+\lfloor(xn+(r+d))/d\rfloor=\lfloor x_0n_0/d+{1\over2}\rfloor$;
+(ii)~|-d<=r<0<n<=x<d|, where $x_0$, $n_0$ are the original values of~$x$
+and $n$.
+
+Notice that the computation specifies |(x-d)+x| instead of |(x+x)-d|,
+because the latter could overflow.
+
+@<Compute \(f)$f=\lfloor xn/d+{1\over2}\rfloor$@>=
+f:=0; r:=(d div 2)-d; h:=-r;
+loop@+begin if odd(n) then
+ begin r:=r+x;
+ if r>=0 then
+ begin r:=r-d; incr(f);
+ end;
+ end;
+ n:=n div 2;
+ if n=0 then goto found1;
+ if x<h then x:=x+x
+ else begin t:=x-d; x:=t+x; f:=f+n;
+ if x<n then
+ begin if x=0 then goto found1;
+ t:=x; x:=n; n:=t;
+ end;
+ end;
+ end;
+found1:
+
+@ The \.{\\gluestretch}, \.{\\glueshrink}, \.{\\gluestretchorder}, and
+\.{\\glueshrinkorder} commands return the stretch and shrink components
+and their orders of ``infinity'' of a glue specification.
+
+@d glue_stretch_order_code=eTeX_int+6 {code for \.{\\gluestretchorder}}
+@d glue_shrink_order_code=eTeX_int+7 {code for \.{\\glueshrinkorder}}
+@d glue_stretch_code=eTeX_dim+7 {code for \.{\\gluestretch}}
+@d glue_shrink_code=eTeX_dim+8 {code for \.{\\glueshrink}}
+
+@<Generate all \eTeX...@>=
+primitive("gluestretchorder",last_item,glue_stretch_order_code);
+@!@:glue_stretch_order_}{\.{\\gluestretchorder} primitive@>
+primitive("glueshrinkorder",last_item,glue_shrink_order_code);
+@!@:glue_shrink_order_}{\.{\\glueshrinkorder} primitive@>
+primitive("gluestretch",last_item,glue_stretch_code);
+@!@:glue_stretch_}{\.{\\gluestretch} primitive@>
+primitive("glueshrink",last_item,glue_shrink_code);
+@!@:glue_shrink_}{\.{\\glueshrink} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+glue_stretch_order_code: print_esc("gluestretchorder");
+glue_shrink_order_code: print_esc("glueshrinkorder");
+glue_stretch_code: print_esc("gluestretch");
+glue_shrink_code: print_esc("glueshrink");
+
+@ @<Cases for fetching an integer value@>=
+glue_stretch_order_code, glue_shrink_order_code:
+ begin scan_normal_glue; q:=cur_val;
+ if m=glue_stretch_order_code then cur_val:=stretch_order(q)
+ else cur_val:=shrink_order(q);
+ delete_glue_ref(q);
+ end;
+
+@ @<Cases for fetching a dimension value@>=
+glue_stretch_code, glue_shrink_code:
+ begin scan_normal_glue; q:=cur_val;
+ if m=glue_stretch_code then cur_val:=stretch(q)
+ else cur_val:=shrink(q);
+ delete_glue_ref(q);
+ end;
+
+@ The \.{\\mutoglue} and \.{\\gluetomu} commands convert ``math'' glue
+into normal glue and vice versa; they allow to manipulate math glue with
+\.{\\gluestretch} etc.
+
+@d mu_to_glue_code=eTeX_glue {code for \.{\\mutoglue}}
+@d glue_to_mu_code=eTeX_mu {code for \.{\\gluetomu}}
+
+@<Generate all \eTeX...@>=
+primitive("mutoglue",last_item,mu_to_glue_code);
+@!@:mu_to_glue_}{\.{\\mutoglue} primitive@>
+primitive("gluetomu",last_item,glue_to_mu_code);
+@!@:glue_to_mu_}{\.{\\gluetomu} primitive@>
+
+@ @<Cases of |last_item| for |print_cmd_chr|@>=
+mu_to_glue_code: print_esc("mutoglue");
+glue_to_mu_code: print_esc("gluetomu");
+
+@ @<Cases for fetching a glue value@>=
+mu_to_glue_code: scan_mu_glue;
+
+@ @<Cases for fetching a mu value@>=
+glue_to_mu_code: scan_normal_glue;
+
+@ @<Glob...@>=
+@!last_line_fill:pointer; {the |par_fill_skip| glue node of the new paragraph}
+
+@ When |saving_vdiscards| is positive then the glue, kern, and penalty
+nodes removed by the page builder or by \.{\\vsplit} from the top of a
+vertical list are saved in special lists instead of being discarded.
+
+@d tail_page_disc==disc_ptr[copy_code] {last item removed by page builder}
+@d page_disc==disc_ptr[last_box_code] {first item removed by page builder}
+@d split_disc==disc_ptr[vsplit_code] {first item removed by \.{\\vsplit}}
+
+@<Glob...@>=
+@!disc_ptr:array[copy_code..vsplit_code] of pointer; {list pointers}
+
+@ @<Set init...@>=
+page_disc:=null; split_disc:=null;
+
+@ The \.{\\pagediscards} and \.{\\splitdiscards} commands share the
+command code |un_vbox| with \.{\\unvbox} and \.{\\unvcopy}, they are
+distinguished by their |chr_code| values |last_box_code| and
+|vsplit_code|. These |chr_code| values are larger than |box_code| and
+|copy_code|.
+
+@<Generate all \eTeX...@>=
+primitive("pagediscards",un_vbox,last_box_code);@/
+@!@:page_discards_}{\.{\\pagediscards} primitive@>
+primitive("splitdiscards",un_vbox,vsplit_code);@/
+@!@:split_discards_}{\.{\\splitdiscards} primitive@>
+
+@ @<Cases of |un_vbox| for |print_cmd_chr|@>=
+else if chr_code=last_box_code then print_esc("pagediscards")
+else if chr_code=vsplit_code then print_esc("splitdiscards")
+
+@ @<Handle saved items and |goto done|@>=
+begin vlink(tail):=disc_ptr[cur_chr]; disc_ptr[cur_chr]:=null;
+goto done;
+end
+
+@ The \.{\\interlinepenalties}, \.{\\clubpenalties}, \.{\\widowpenalties},
+and \.{\\displaywidowpenalties} commands allow to define arrays of
+penalty values to be used instead of the corresponding single values.
+
+@d inter_line_penalties_ptr==equiv(inter_line_penalties_loc)
+@d club_penalties_ptr==equiv(club_penalties_loc)
+@d widow_penalties_ptr==equiv(widow_penalties_loc)
+@d display_widow_penalties_ptr==equiv(display_widow_penalties_loc)
+
+@<Generate all \eTeX...@>=
+primitive("interlinepenalties",set_shape,inter_line_penalties_loc);@/
+@!@:inter_line_penalties_}{\.{\\interlinepenalties} primitive@>
+primitive("clubpenalties",set_shape,club_penalties_loc);@/
+@!@:club_penalties_}{\.{\\clubpenalties} primitive@>
+primitive("widowpenalties",set_shape,widow_penalties_loc);@/
+@!@:widow_penalties_}{\.{\\widowpenalties} primitive@>
+primitive("displaywidowpenalties",set_shape,display_widow_penalties_loc);@/
+@!@:display_widow_penalties_}{\.{\\displaywidowpenalties} primitive@>
+
+@ @<Cases of |set_shape| for |print_cmd_chr|@>=
+inter_line_penalties_loc: print_esc("interlinepenalties");
+club_penalties_loc: print_esc("clubpenalties");
+widow_penalties_loc: print_esc("widowpenalties");
+display_widow_penalties_loc: print_esc("displaywidowpenalties");
+
+@ @<Fetch a penalties array element@>=
+begin scan_int;
+if (equiv(m)=null)or(cur_val<0) then cur_val:=0
+else begin if cur_val>penalty(equiv(m)) then cur_val:=penalty(equiv(m));
+ cur_val:=penalty(equiv(m)+cur_val);
+ end;
+end
+
+@ This is needed to get the relative order of the marks code correct
+
+@<Show the meaning of a mark node@>=
+if (cur_cmd=top_bot_mark)and(cur_chr<marks_code) then
+ begin print_char(":"); print_ln;
+ case cur_chr of
+ first_mark_code: token_show(first_mark(0));
+ bot_mark_code: token_show(bot_mark(0));
+ split_first_mark_code: token_show(split_first_mark(0));
+ split_bot_mark_code: token_show(split_bot_mark(0));
+ othercases token_show(top_mark(0));
+ endcases;
+end
+
+
+@ The lua interface needs some extra pascal functions. The functions
+themselves are quite boring, but they are handy because otherwise this
+internal stuff has to be accessed from C directly, where lots of the
+pascal defines are not available.
+
+@p function get_tex_dimen_register (j:integer):scaled;
+begin
+ get_tex_dimen_register := dimen(j);
+end;
+
+function set_tex_dimen_register (j:integer;v:scaled):integer;
+var a:small_number;
+begin {return non-nil for error}
+a:=0;
+word_define(j+scaled_base,v);
+set_tex_dimen_register := 0;
+end;
+
+function get_tex_count_register (j:integer):scaled;
+begin
+ get_tex_count_register := count(j);
+end;
+
+function set_tex_count_register (j:integer;v:scaled):integer;
+var a:small_number;
+begin {return non-nil for error}
+a:=0;
+word_define(j+count_base,v);
+set_tex_count_register := 0;
+end;
+
+function get_tex_attribute_register (j:integer):scaled;
+begin
+ get_tex_attribute_register := attribute(j);
+end;
+
+function set_tex_attribute_register (j:integer;v:scaled):integer;
+var a:small_number;
+begin {return non-nil for error}
+a:=0;
+word_define(j+attribute_base,v);
+set_tex_attribute_register := 0;
+end;
+
+function get_tex_toks_register (j:integer):str_number;
+var s:str_number;
+begin
+ s:="";
+ if toks(j) <> min_halfword then begin
+ s := tokens_to_string(toks(j));
+ end;
+ get_tex_toks_register := s;
+end;
+
+function set_tex_toks_register (j:integer;s:str_number):integer;
+var s_pool_ptr:pool_pointer;
+ ref:pointer;
+ a:small_number;
+ junk:pointer;
+begin
+ set_tex_toks_register := 0;
+ s_pool_ptr := pool_ptr;
+ pool_ptr := str_start_macro(s+1);
+ ref := get_avail;
+ junk := str_toks(str_start_macro(s));
+ pool_ptr := s_pool_ptr;
+ token_ref_count(ref) := 0;
+ link(ref) := link(temp_token_head);
+ a:=0;
+ define(j+toks_base,call,ref);
+ flush_str(s);
+end;
+
+function get_tex_box_register (j:integer):integer;
+begin
+ get_tex_box_register := box(j);
+end;
+
+function set_tex_box_register (j:integer;v:scaled):integer;
+var a:small_number;
+begin {return non-nil for error}
+a:=0;
+eq_define(j+box_base,box_ref,v);
+set_tex_box_register := 0;
+end;
+
+
+function get_tex_box_width (j:integer):scaled;
+var q:pointer;
+begin
+ q := box(j);
+ get_tex_box_width := 0;
+ if q <> min_halfword then
+ get_tex_box_width := width(q);
+end;
+
+function set_tex_box_width (j:integer;v:scaled):integer;
+var q:pointer;
+begin
+ q := box(j);
+ set_tex_box_width := 0;
+ if q <> min_halfword then
+ width(q) := v
+ else
+ set_tex_box_width := 1;
+end;
+
+function get_tex_box_height (j:integer):scaled;
+var q:pointer;
+begin
+ q := box(j);
+ get_tex_box_height := 0;
+ if q <> min_halfword then
+ get_tex_box_height := height(q);
+end;
+
+function set_tex_box_height (j:integer;v:scaled):integer;
+var q:pointer;
+begin
+ q := box(j);
+ set_tex_box_height := 0;
+ if q <> min_halfword then
+ height(q) := v
+ else
+ set_tex_box_height := 1;
+end;
+
+function get_tex_box_depth (j:integer):scaled;
+var q:pointer;
+begin
+ q := box(j);
+ get_tex_box_depth := 0;
+ if q <> min_halfword then
+ get_tex_box_depth := depth(q);
+end;
+
+function set_tex_box_depth (j:integer;v:scaled):integer;
+var q:pointer;
+begin
+ q := box(j);
+ set_tex_box_depth := 0;
+ if q <> min_halfword then
+ depth(q) := v
+ else
+ set_tex_box_depth := 1;
+end;
+
+function get_cur_v: integer;
+begin
+ get_cur_v := cur_page_height - cur_v;
+end;
+
+function get_cur_h: integer;
+begin
+ get_cur_h := cur_h;
+end;
+
+@* \[54] $\Omega$ changes.
+
+@ Here we do the main work required for reading and interpreting
+ $\Omega$ Compiled Translation Processes.
+
+@ Here are all the instructions in our mini-assembler.
+@d otp_right_output=1
+@d otp_right_num=2
+@d otp_right_char=3
+@d otp_right_lchar=4
+@d otp_right_some=5
+
+@d otp_pback_output=6
+@d otp_pback_num=7
+@d otp_pback_char=8
+@d otp_pback_lchar=9
+@d otp_pback_some=10
+
+@d otp_add=11
+@d otp_sub=12
+@d otp_mult=13
+@d otp_div=14
+@d otp_mod=15
+@d otp_lookup=16
+@d otp_push_num=17
+@d otp_push_char=18
+@d otp_push_lchar=19
+
+@d otp_state_change=20
+@d otp_state_push=21
+@d otp_state_pop=22
+
+@d otp_left_start=23
+@d otp_left_return=24
+@d otp_left_backup=25
+
+@d otp_goto=26
+@d otp_goto_ne=27
+@d otp_goto_eq=28
+@d otp_goto_lt=29
+@d otp_goto_le=30
+@d otp_goto_gt=31
+@d otp_goto_ge=32
+@d otp_goto_no_advance=33
+@d otp_goto_beg=34
+@d otp_goto_end=35
+
+@d otp_stop=36
+
+@
+@<Glob...@>=
+@!otp_init_input_start:halfword;
+@!otp_init_input_last:halfword;
+@!otp_init_input_end:halfword;
+@!otp_i:halfword;
+@!otp_init_input_buf:array[0..20000] of quarterword;
+
+@!otp_input_start:halfword;
+@!otp_input_last:halfword;
+@!otp_input_end:halfword;
+@!otp_input_buf:array[0..20000] of quarterword;
+
+@!otp_output_end:halfword;
+@!otp_output_buf:array[0..20000] of quarterword;
+
+@!otp_stack_used:halfword;
+@!otp_stack_last:halfword;
+@!otp_stack_new:halfword;
+@!otp_stack_buf:array[0..1000] of quarterword;
+
+@!otp_pc:halfword;
+
+@!otp_calc_ptr:halfword;
+@!otp_calcs:array[0..1000] of halfword;
+@!otp_state_ptr:halfword;
+@!otp_states:array[0..1000] of halfword;
+
+@!otp_input_char:halfword;
+@!otp_calculated_char:halfword;
+@!otp_no_input_chars:halfword;
+
+@!otp_instruction:halfword;
+@!otp_instr:halfword;
+@!otp_arg:halfword;
+@!otp_first_arg:halfword;
+@!otp_second_arg:halfword;
+
+@!otp_input_ocp:halfword;
+@!otp_counter:halfword;
+
+@!otp_finished:boolean;
+@!otp_ext_str:integer;
+@!otp_ext_str_arg:integer;
+@!otp_ext_i:integer;
+
+@
+@<Initialize table...@>=
+
+@
+@<Create a buffer with character |cur_chr| and the following
+ characters (if~any) and then apply the current active OCP filter
+ to this buffer@>=
+begin
+@<Read in the buffer for treatment@>;
+@<Apply the OCP to the input buffer@>;
+@<Place the output buffer back on the stream@>;
+goto big_switch;
+end;
+
+@ The OTP input buffer is an array of 16-bit values.
+In the future, the range |@"D800| \dots |@"DFFF| will be used for
+surrogate pairs, so it cannot be used for simple 16-bit values
+like it is in Omega, so a future incompatibility with Aleph is
+unavoidable.
+
+@<Read in the buffer for treatment@>=
+begin
+otp_init_input_end:=0;
+while (cur_cmd=letter) or (cur_cmd=other_char) or
+ (cur_cmd=char_given) or (cur_cmd=spacer) do begin
+ incr(otp_init_input_end);
+ if otp_init_input_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ { |cur_chr| can cover the full range |0..0x10FFFF| }
+ if cur_chr<@"10000 then
+ otp_init_input_buf[otp_init_input_end]:=cur_chr
+ else begin
+ otp_init_input_buf[otp_init_input_end]:=((cur_chr - @"10000) div @"400) + @"D800;
+ incr(otp_init_input_end);
+ if otp_init_input_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ otp_init_input_buf[otp_init_input_end]:=((cur_chr - @"10000) mod @"400) + @"DC00;
+ end;
+ get_token;
+ if (cur_cmd<>letter) and (cur_cmd<>other_char) and
+ (cur_cmd<>char_given) then begin
+ x_token;
+ if (cur_cmd=char_num) then begin
+ scan_char_num; cur_cmd:=other_char; cur_chr:=cur_val;
+ end;
+ end;
+ end;
+back_input;
+otp_input_end:=otp_init_input_end;
+for otp_i:=0 to otp_init_input_end do begin
+ otp_input_buf[otp_i]:=otp_init_input_buf[otp_i];
+ end;
+end
+
+@
+@<Apply the OCP to the input buffer@>=
+begin
+otp_input_ocp:=active_ocp(active_real);
+if otp_input_ocp=0 then begin
+ print_err("Null ocp being used: all input lost");
+ error;
+ otp_output_end:=0;
+ end
+else if ocp_external(otp_input_ocp)=0 then begin
+ otp_input_start:=0;
+ otp_input_last:=0;
+ otp_stack_used:=0;
+ otp_stack_last:=0;
+ otp_stack_new:=0;
+ otp_output_end:=0;
+ otp_pc:=0;
+ otp_finished:=false;
+ otp_calc_ptr:=0;
+ otp_calcs[otp_calc_ptr]:=0;
+ otp_state_ptr:=0;
+ otp_states[otp_state_ptr]:=0;
+ while not otp_finished do
+ @<Run the OTP program@>;
+ end
+else begin
+ k:=0;
+ if nameoffile then libcfree (nameoffile);
+ otp_ext_str:=ocp_external(otp_input_ocp);
+ otp_ext_str_arg:=ocp_external_arg(otp_input_ocp);
+ nameoffile := xmalloc (4 + length(otp_ext_str) + length(otp_ext_str_arg));
+ for otp_ext_i:=str_start_macro(otp_ext_str) to
+ str_start_macro(otp_ext_str)+length(otp_ext_str)-1 do
+ append_to_name(str_pool[otp_ext_i]);
+ append_to_name(" ");
+ for otp_ext_i:=str_start_macro(otp_ext_str_arg) to
+ str_start_macro(otp_ext_str_arg)+length(otp_ext_str_arg)-1 do
+ append_to_name(str_pool[otp_ext_i]);
+ nameoffile[length(otp_ext_str)+length(otp_ext_str_arg)+2]:=0;
+ run_external_ocp(nameoffile);
+ end
+end
+
+@ The OTP output buffer is an array of 16-bit values. To convert back
+to the |buffer| it has to be re-encoded into UTF-8. An incompatibility
+with Aleph is unavoidable here: The range |@"D800| \dots |@"DFFF| is
+used for surrogate pairs, not for simple 16-bit values.
+
+@<Place the output buffer back on the stream@>=
+begin
+if (first+otp_output_end)>=ocp_buf_size then
+ overflow_ocp_buf_size;
+push_input;
+current_ocp_lstack:=active_lstack_no(active_real);
+current_ocp_no:=active_counter(active_real);
+state:=mid_line;
+start:=first;
+last:=start;
+loc:=start;
+for otp_counter:=1 to otp_output_end do begin
+ { convert back to utf-8 }
+ t := otp_output_buf[otp_counter];
+ if otp_counter < otp_output_end then
+ if ((t>=@"D800) and (t<@"DC00)) then
+ if (otp_output_buf[otp_counter+1]>=@"DC00)
+ and (otp_output_buf[otp_counter+1]<@"E000) then begin
+ incr(otp_counter);
+ t := (t-@"D800) * @"400 + (otp_output_buf[otp_counter]-@"DC00) + @"10000;
+ end
+ else if ((t>=@"DC00) and (t<@"E000)) then
+ if (otp_output_buf[otp_counter+1]>=@"D800)
+ and (otp_output_buf[otp_counter+1]<@"DC00) then begin
+ incr(otp_counter);
+ t := (otp_output_buf[otp_counter]-@"D800) * @"400 + (t-@"DC00) + @"10000;
+ end;
+ if t <= @"7F then
+ buffer[last]:= t
+ else if t<=@"7FF then begin
+ buffer[last]:=@"C0 + t div @"40;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ buffer[last]:=@"80 + t mod @"40;
+ end
+ else if t<=@"FFFF then begin
+ buffer[last]:=@"E0 + t div @"1000;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ buffer[last]:=@"80 + (t mod @"1000) div @"40;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ buffer[last]:=@"80 + (t mod @"1000) mod @"40;
+ end
+ else begin
+ buffer[last]:=@"F0 + t div @"40000;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ buffer[last]:=@"80 + (t mod @"40000) div @"1000;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ buffer[last]:=@"80 + ((t mod @"40000) mod @"1000) div @"40;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ buffer[last]:=@"80 + ((t mod @"40000) mod @"1000) mod @"40;
+ end;
+ incr(last);
+ if last=buf_size-2 then
+ @<Report overflow of the input buffer, and abort@>;
+ end;
+limit:=last-1;
+if (t>@"FFFF) then decr(limit);
+if (t>@"7FF) then decr(limit);
+if (t>@"7F) then decr(limit);
+first:=last;
+end
+
+@
+@d otp_cur_state==otp_states[otp_state_ptr]
+@d otp_set_instruction==begin
+if otp_pc>=ocp_state_no(otp_input_ocp)(otp_cur_state) then begin
+ print_err("bad OCP program -- PC not valid");
+ succumb;
+ end;
+otp_instruction:=ocp_state_entry(otp_input_ocp)(otp_cur_state)(otp_pc);
+otp_instr:=otp_instruction div @"1000000;
+otp_arg:=otp_instruction mod @"1000000;
+end
+
+@<Run the OTP program@>=
+begin
+otp_set_instruction;
+case otp_instr of
+ @<Run the |otp_right| instructions@>;
+ @<Run the |otp_pback| instructions@>;
+ @<Run the arithmetic instructions@>;
+ @<Run the |otp_state| instructions@>;
+ @<Run the |otp_left| instructions@>;
+ @<Run the |otp_goto| instructions@>;
+ @<Run the |otp_stop| instruction@>;
+ othercases begin
+ print_err("bad OCP program -- unknown instruction");
+ succumb;
+ end
+ endcases;
+end
+
+@
+
+@d otp_check_char(#)==
+if (1>#) or (#>otp_no_input_chars) then begin
+ print_err("right hand side of OCP expression is bad");
+ succumb;
+ end
+
+@d otp_get_char(#)==begin
+otp_check_char(#);
+if #>otp_stack_last then begin
+ otp_calculated_char:=otp_input_buf[otp_input_start+#-otp_stack_last];
+ end
+else begin
+ otp_calculated_char:=otp_stack_buf[#];
+ end;
+end
+
+@<Run the |otp_right| instructions@>=
+ otp_right_output: begin
+ incr(otp_output_end);
+ if otp_output_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ otp_output_buf[otp_output_end]:=otp_calcs[otp_calc_ptr];
+ decr(otp_calc_ptr);
+ incr(otp_pc);
+ end;
+ otp_right_num: begin
+ incr(otp_output_end);
+ if otp_output_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ otp_output_buf[otp_output_end]:=otp_arg;
+ incr(otp_pc);
+ end;
+ otp_right_char: begin
+ otp_get_char(otp_arg);
+ incr(otp_output_end);
+ if otp_output_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ otp_output_buf[otp_output_end]:=otp_calculated_char;
+ incr(otp_pc);
+ end;
+ otp_right_lchar: begin
+ otp_get_char(otp_no_input_chars-otp_arg);
+ incr(otp_output_end);
+ if otp_output_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ otp_output_buf[otp_output_end]:=otp_calculated_char;
+ incr(otp_pc);
+ end;
+ otp_right_some: begin
+ otp_first_arg:=otp_arg+1;
+ incr(otp_pc);
+ otp_set_instruction;
+ otp_second_arg:=otp_no_input_chars-otp_arg;
+ for otp_counter:=otp_first_arg to otp_second_arg do begin
+ otp_get_char(otp_counter);
+ incr(otp_output_end);
+ if otp_output_end >ocp_buf_size then
+ overflow_ocp_buf_size;
+ otp_output_buf[otp_output_end]:=otp_calculated_char;
+ end;
+ incr(otp_pc);
+ end
+
+@
+@<Run the |otp_pback| instructions@>=
+ otp_pback_output: begin
+ incr(otp_stack_new);
+ if otp_stack_new >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_stack_buf[otp_stack_new]:=otp_calcs[otp_calc_ptr];
+ decr(otp_calc_ptr);
+ incr(otp_pc);
+ end;
+ otp_pback_num: begin
+ incr(otp_stack_new);
+ if otp_stack_new >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_stack_buf[otp_stack_new]:=otp_arg;
+ incr(otp_pc);
+ end;
+ otp_pback_char: begin
+ otp_get_char(otp_arg);
+ incr(otp_stack_new);
+ if otp_stack_new >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_stack_buf[otp_stack_new]:=otp_calculated_char;
+ incr(otp_pc);
+ end;
+ otp_pback_lchar: begin
+ otp_get_char(otp_no_input_chars-otp_arg);
+ incr(otp_stack_new);
+ if otp_stack_new >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_stack_buf[otp_stack_new]:=otp_calculated_char;
+ incr(otp_pc);
+ end;
+ otp_pback_some: begin
+ otp_first_arg:=otp_arg+1;
+ incr(otp_pc);
+ otp_set_instruction;
+ otp_second_arg:=otp_no_input_chars-otp_arg;
+ for otp_counter:=otp_first_arg to otp_second_arg do begin
+ otp_get_char(otp_counter);
+ incr(otp_stack_new);
+ if otp_stack_new >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_stack_buf[otp_stack_new]:=otp_calculated_char;
+ end;
+ incr(otp_pc);
+ end
+
+@
+@<Run the arithmetic instructions@>=
+ otp_add: begin
+ otp_calcs[otp_calc_ptr-1] :=
+ otp_calcs[otp_calc_ptr-1] + otp_calcs[otp_calc_ptr];
+ incr(otp_pc);
+ decr(otp_calc_ptr);
+ end;
+ otp_sub: begin
+ otp_calcs[otp_calc_ptr-1] :=
+ otp_calcs[otp_calc_ptr-1] - otp_calcs[otp_calc_ptr];
+ incr(otp_pc);
+ decr(otp_calc_ptr);
+ end;
+ otp_mult: begin
+ otp_calcs[otp_calc_ptr-1] :=
+ otp_calcs[otp_calc_ptr-1] * otp_calcs[otp_calc_ptr];
+ incr(otp_pc);
+ decr(otp_calc_ptr);
+ end;
+ otp_div: begin
+ otp_calcs[otp_calc_ptr-1] :=
+ otp_calcs[otp_calc_ptr-1] div otp_calcs[otp_calc_ptr];
+ incr(otp_pc);
+ decr(otp_calc_ptr);
+ end;
+ otp_mod: begin
+ otp_calcs[otp_calc_ptr-1] :=
+ otp_calcs[otp_calc_ptr-1] mod otp_calcs[otp_calc_ptr];
+ incr(otp_pc);
+ decr(otp_calc_ptr);
+ end;
+ otp_lookup: begin
+ if otp_calcs[otp_calc_ptr]>=
+ ocp_table_no(otp_input_ocp)(otp_calcs[otp_calc_ptr-1]) then begin
+ print_err("bad OCP program -- table index not valid");
+ succumb;
+ end;
+ otp_calcs[otp_calc_ptr-1]:=
+ ocp_table_entry(otp_input_ocp)(otp_calcs[otp_calc_ptr-1])
+ (otp_calcs[otp_calc_ptr]);
+ incr(otp_pc);
+ decr(otp_calc_ptr);
+ end;
+ otp_push_num: begin
+ incr(otp_calc_ptr);
+ if otp_calc_ptr >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_calcs[otp_calc_ptr]:=otp_arg;
+ incr(otp_pc);
+ end;
+ otp_push_char: begin
+ otp_get_char(otp_arg);
+ incr(otp_calc_ptr);
+ if otp_calc_ptr >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_calcs[otp_calc_ptr]:=otp_calculated_char;
+ incr(otp_pc);
+ end;
+ otp_push_lchar: begin
+ otp_get_char(otp_no_input_chars-otp_arg);
+ incr(otp_calc_ptr);
+ if otp_calc_ptr >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_calcs[otp_calc_ptr]:=otp_calculated_char;
+ incr(otp_pc);
+ end
+
+@
+@<Run the |otp_state| instructions@>=
+ otp_state_change: begin
+ otp_input_start:=otp_input_last;
+ for otp_counter:=1 to (otp_stack_new-otp_stack_used) do begin
+ otp_stack_buf[otp_counter] :=
+ otp_stack_buf[otp_counter+otp_stack_used];
+ end;
+ otp_stack_new:=otp_stack_new-otp_stack_used;
+ otp_stack_last:=otp_stack_new;
+ otp_stack_used:=0;
+ otp_states[otp_state_ptr]:=otp_arg;
+ otp_pc:=0;
+ end;
+ otp_state_push: begin
+ otp_input_start:=otp_input_last;
+ for otp_counter:=1 to (otp_stack_new-otp_stack_used) do begin
+ otp_stack_buf[otp_counter] :=
+ otp_stack_buf[otp_counter+otp_stack_used];
+ end;
+ otp_stack_new:=otp_stack_new-otp_stack_used;
+ otp_stack_last:=otp_stack_new;
+ otp_stack_used:=0;
+ incr(otp_state_ptr);
+ if otp_state_ptr >= ocp_stack_size then
+ overflow_ocp_stack_size;
+ otp_states[otp_state_ptr]:=otp_arg;
+ otp_pc:=0;
+ end;
+ otp_state_pop: begin
+ otp_input_start:=otp_input_last;
+ for otp_counter:=1 to (otp_stack_new-otp_stack_used) do begin
+ otp_stack_buf[otp_counter] :=
+ otp_stack_buf[otp_counter+otp_stack_used];
+ end;
+ otp_stack_new:=otp_stack_new-otp_stack_used;
+ otp_stack_last:=otp_stack_new;
+ otp_stack_used:=0;
+ if otp_state_ptr>0 then decr(otp_state_ptr);
+ otp_pc:=0;
+ end
+
+@
+@<Run the |otp_left| instructions@>=
+ otp_left_start: begin
+ otp_input_start:=otp_input_last;
+ otp_input_last:=otp_input_start;
+ otp_stack_used:=0;
+ if (otp_stack_last=0) and (otp_input_last>=otp_input_end) then
+ otp_finished:=true
+ else if (otp_stack_used < otp_stack_last) then begin
+ incr(otp_stack_used); {no overflow problem}
+ otp_input_char:=otp_stack_buf[otp_stack_used];
+ otp_no_input_chars:=1;
+ incr(otp_pc);
+ end
+ else begin
+ incr(otp_input_last); {no overflow problem}
+ otp_input_char:=otp_input_buf[otp_input_last];
+ otp_no_input_chars:=1;
+ incr(otp_pc);
+ end;
+ end;
+ otp_left_return: begin
+ otp_input_last:=otp_input_start;
+ otp_stack_used:=0;
+ if (otp_stack_used < otp_stack_last) then begin
+ incr(otp_stack_used); {no overflow problem}
+ otp_input_char:=otp_stack_buf[otp_stack_used];
+ otp_no_input_chars:=1;
+ incr(otp_pc);
+ end
+ else begin
+ incr(otp_input_last); {no overflow problem}
+ otp_input_char:=otp_input_buf[otp_input_last];
+ otp_no_input_chars:=1;
+ incr(otp_pc);
+ end;
+ end;
+ otp_left_backup: begin
+ if otp_input_start < otp_input_last then begin
+ decr(otp_input_last); otp_input_char:=otp_input_buf[otp_input_last];
+ end
+ else begin
+ decr(otp_stack_used); otp_input_char:=otp_stack_buf[otp_stack_used];
+ end;
+ decr(otp_no_input_chars);
+ incr(otp_pc);
+ end
+
+@
+@<Run the |otp_goto| instructions@>=
+ otp_goto: begin
+ otp_pc:=otp_arg;
+ end;
+ otp_goto_ne: begin
+ otp_first_arg:=otp_arg;
+ incr(otp_pc);
+ otp_set_instruction;
+ if otp_input_char <> otp_first_arg then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_eq: begin
+ otp_first_arg:=otp_arg;
+ incr(otp_pc);
+ otp_set_instruction;
+ if otp_input_char = otp_first_arg then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_lt: begin
+ otp_first_arg:=otp_arg;
+ incr(otp_pc);
+ otp_set_instruction;
+ if otp_input_char < otp_first_arg then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_le: begin
+ otp_first_arg:=otp_arg;
+ incr(otp_pc);
+ otp_set_instruction;
+ if otp_input_char <= otp_first_arg then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_gt: begin
+ otp_first_arg:=otp_arg;
+ incr(otp_pc);
+ otp_set_instruction;
+ if otp_input_char > otp_first_arg then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_ge: begin
+ otp_first_arg:=otp_arg;
+ incr(otp_pc);
+ otp_set_instruction;
+ if otp_input_char >= otp_first_arg then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_no_advance: begin
+ if (otp_stack_used < otp_stack_last) then begin
+ incr(otp_stack_used); {no overflow problem}
+ otp_input_char:=otp_stack_buf[otp_stack_used];
+ incr(otp_no_input_chars); {no overflow problem}
+ incr(otp_pc);
+ end
+ else if otp_input_last>=otp_input_end then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_input_last); {no overflow problem}
+ otp_input_char:=otp_input_buf[otp_input_last];
+ incr(otp_no_input_chars); {no overflow problem}
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_beg: begin
+ if otp_input_last=0 then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end;
+ otp_goto_end: begin
+ if otp_input_last>=otp_input_end then begin
+ otp_pc:=otp_arg;
+ end
+ else begin
+ incr(otp_pc);
+ end;
+ end
+
+@
+@<Run the |otp_stop| instruction@>=
+ otp_stop: begin
+ otp_input_start:=otp_input_last;
+ for otp_counter:=1 to (otp_stack_new-otp_stack_used) do begin
+ otp_stack_buf[otp_counter] :=
+ otp_stack_buf[otp_counter+otp_stack_used];
+ end;
+ otp_stack_new:=otp_stack_new-otp_stack_used;
+ otp_stack_last:=otp_stack_new;
+ otp_stack_used:=0;
+ otp_pc:=0;
+ end
+
+@ @<Put each...@>=
+primitive("ocp", def_ocp, 0);
+primitive("externalocp", def_ocp, 1);
+primitive("ocplist", def_ocp_list, 0);
+primitive("pushocplist", push_ocp_list, 0);
+primitive("popocplist", pop_ocp_list, 0);
+primitive("clearocplists", clear_ocp_lists, 0);
+primitive("addbeforeocplist", ocp_list_op, add_before_op);
+primitive("addafterocplist", ocp_list_op, add_after_op);
+primitive("removebeforeocplist", ocp_list_op, remove_before_op);
+primitive("removeafterocplist", ocp_list_op, remove_after_op);
+primitive("ocptracelevel", ocp_trace_level, 0);
+equiv(ocp_trace_level_base):=0;
+
+@ @<Cases of |print_cmd_chr|...@>=
+set_ocp: begin
+ print("select ocp ");
+ slow_print(ocp_name(chr_code));
+ end;
+def_ocp: if cur_chr=0 then print_esc("ocp")
+ else print_esc("externalocp");
+set_ocp_list: print("select ocp list ");
+def_ocp_list: print_esc("ocplist");
+push_ocp_list: print_esc("pushocplist");
+pop_ocp_list: print_esc("popocplist");
+clear_ocp_lists: print_esc("clearocplists");
+ocp_list_op:
+ if chr_code=add_before_op then print_esc("addbeforeocplist")
+ else if chr_code=add_after_op then print_esc("addafterocplist")
+ else if chr_code=remove_before_op then print_esc("removebeforeocplist")
+ else {|chr_code|=|remove_after_op|} print_esc("removeafterocplist");
+ocp_trace_level: print_esc("ocptracelevel");
+
+@ @<Assignments@>=
+set_ocp: begin
+ print_err("To use ocps, use the "); print_esc("pushocplist");
+ print(" primitive");print_ln
+ end;
+def_ocp: new_ocp(a);
+set_ocp_list: begin
+ print_err("To use ocp lists, use the ");
+ print_esc("pushocplist"); print(" primitive");print_ln
+ end;
+def_ocp_list: new_ocp_list(a);
+push_ocp_list: do_push_ocp_list(a);
+pop_ocp_list: do_pop_ocp_list(a);
+clear_ocp_lists: do_clear_ocp_lists(a);
+ocp_list_op: begin
+ print_err("To build ocp lists, use the ");
+ print_esc("ocplist"); print(" primitive"); print_ln
+ end;
+ocp_trace_level: begin scan_optional_equals; scan_int;
+ if cur_val<>0 then cur_val:=1;
+ define(ocp_trace_level_base, data, cur_val);
+ end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure new_ocp(@!a:small_number);
+label common_ending;
+var u:pointer; {user's ocp identifier}
+@!f:internal_ocp_number; {runs through existing ocps}
+@!t:str_number; {name for the frozen ocp identifier}
+@!old_setting:0..max_selector; {holds |selector| setting}
+@!flushable_string:str_number; {string not yet referenced}
+@!external_ocp:boolean; {external binary file}
+begin if job_name=0 then open_log_file;
+ {avoid confusing \.{texput} with the ocp name}
+@.texput@>
+if cur_chr=1 then external_ocp:=true
+else external_ocp:=false;
+get_r_token; u:=cur_cs;
+if u>=hash_base then t:=text(u)
+else if u=null_cs then t:="OCP"
+else begin old_setting:=selector; selector:=new_string;
+ print("OCP"); print(u-active_base); selector:=old_setting;
+@.OCPx@>
+ str_room(1); t:=make_string;
+ end;
+define(u,set_ocp,null_ocp); scan_optional_equals; scan_file_name;
+@<If this ocp has already been loaded, set |f| to the internal
+ ocp number and |goto common_ending|@>;
+f:=read_ocp_info(u,cur_name,cur_area,cur_ext,external_ocp);
+common_ending:
+equiv(u):=f; eqtb[ocp_id_base+f] := eqtb[u];
+text(ocp_id_base+f) := t;
+if equiv(ocp_trace_level_base)=1 then begin
+ print_nl(""); print_esc("ocp"); print_esc(t); print("="); print(cur_name);
+ end;
+end;
+
+@ When the user gives a new identifier to a ocp that was previously loaded,
+the new name becomes the ocp identifier of record. OCP names `\.{xyz}' and
+`\.{XYZ}' are considered to be different.
+
+@<If this ocp has already been loaded...@>=
+flushable_string:=str_ptr-1;
+for f:=ocp_base+1 to ocp_ptr do
+ if str_eq_str(ocp_name(f),cur_name)and str_eq_str(ocp_area(f),cur_area) then
+ begin
+ if cur_name=flushable_string then begin
+ flush_string; cur_name:=ocp_name(f);
+ end;
+ goto common_ending
+ end
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure new_ocp_list(@!a:small_number);
+var u:pointer; {user's ocp list identifier}
+@!f:internal_ocp_list_number; {runs through existing ocp lists}
+@!t:str_number; {name for the frozen ocp list identifier}
+@!old_setting:0..max_selector; {holds |selector| setting}
+begin if job_name=0 then open_log_file;
+ {avoid confusing \.{texput} with the ocp list name}
+@.texput@>
+get_r_token; u:=cur_cs;
+if u>=hash_base then t:=text(u)
+else if u=null_cs then t:="OCPLIST"
+else begin old_setting:=selector; selector:=new_string;
+ print("OCPLIST"); print(u-active_base); selector:=old_setting;
+@.OCPx@>
+ str_room(1); t:=make_string;
+ end;
+define(u,set_ocp_list,null_ocp_list); scan_optional_equals;
+f:=read_ocp_list;
+ equiv(u) := f; eqtb[ocp_list_id_base+f] := eqtb[u];
+ text(ocp_list_id_base+f) := t;
+if equiv(ocp_trace_level_base)=1 then begin
+ print_nl(""); print_esc("ocplist"); print_esc(t); print("=");
+ print_ocp_list(ocp_list_list[f]);
+ end;
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure do_push_ocp_list(@!a:small_number);
+var ocp_list_no:halfword;
+ old_number:halfword;
+ i:integer;
+begin
+scan_ocp_list_ident; ocp_list_no:=cur_val;
+old_number:=equiv(ocp_active_number_base);
+define(ocp_active_base+old_number, data, ocp_list_no);
+define(ocp_active_number_base, data, (old_number+1));
+
+if equiv(ocp_trace_level_base)=1 then begin
+ print_nl("New active ocp list: {");
+ for i:=old_number downto 0 do begin
+ print_esc(ocp_list_id_text(equiv(ocp_active_base+i)));
+ print("="); print_ocp_list(ocp_list_list[equiv(ocp_active_base+i)]);
+ if i<>0 then print(",");
+ end;
+ print("}");
+ end;
+
+active_compile;
+define(ocp_active_min_ptr_base, data, active_min_ptr);
+define(ocp_active_max_ptr_base, data, active_max_ptr);
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure do_pop_ocp_list(@!a:small_number);
+var old_number:halfword;
+ i:integer;
+begin
+old_number:=equiv(ocp_active_number_base);
+if old_number=0 then begin
+ print_err("No active ocp lists to be popped");
+ end
+else
+ define(ocp_active_number_base, data, (old_number-1));
+
+if equiv(ocp_trace_level_base)=1 then begin
+ print_nl("New active ocp list: {");
+ for i:=(old_number-2) downto 0 do begin
+ print_esc(ocp_list_id_text(equiv(ocp_active_base+i)));
+ print("="); print_ocp_list(ocp_list_list[equiv(ocp_active_base+i)]);
+ if i<>0 then print(",");
+ end;
+ print("}");
+ end;
+
+active_compile;
+define(ocp_active_min_ptr_base, data, active_min_ptr);
+define(ocp_active_max_ptr_base, data, active_max_ptr);
+end;
+
+@ @<Declare subprocedures for |prefixed_command|@>=
+procedure do_clear_ocp_lists(@!a:small_number);
+begin
+define(ocp_active_number_base, data, 0);
+active_compile;
+define(ocp_active_min_ptr_base, data, active_min_ptr);
+define(ocp_active_max_ptr_base, data, active_max_ptr);
+end;
+
+
+@* \[54] System-dependent changes.
+This section should be replaced, if necessary, by any special
+modifications of the program
+that are necessary to make \TeX\ work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the published program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* \[55] Index.
+Here is where you can find all uses of each identifier in the program,
+with underlined entries pointing to where the identifier was defined.
+If the identifier is only one letter long, however, you get to see only
+the underlined entries. {\sl All references are to section numbers instead of
+page numbers.}
+
+This index also lists error messages and other aspects of the program
+that you might want to look up some day. For example, the entry
+for ``system dependencies'' lists all sections that should receive
+special attention from people who are installing \TeX\ in a new
+operating environment. A list of various things that can't happen appears
+under ``this can't happen''. Approximately 40 sections are listed under
+``inner loop''; these account for about 60\pct! of \TeX's running time,
+exclusive of input and output.
diff --git a/Build/source/texk/web2c/luatexdir/luatexextra.in b/Build/source/texk/web2c/luatexdir/luatexextra.in
new file mode 100644
index 00000000000..ffbd65f3c1c
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatexextra.in
@@ -0,0 +1,42 @@
+/*
+Copyright (c) 1996-2004 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+/* luatexextra.in: banner etc. for luaTeX.
+
+ This is included by luaTeX, from ../luatexextra.c
+ (generated from ../lib/texmfmp.c).
+*/
+
+#define BANNER "This is luaTeX, Version 3.141592-LUATEX-VERSION-ETEX-VERSION"
+#define COPYRIGHT_HOLDER "Taco Hoekwater"
+#define AUTHOR NULL
+#define PROGRAM_HELP LUATEXHELP
+#define BUG_ADDRESS "dev-luatex@ntg.nl"
+#define DUMP_VAR TEX_format_default
+#define DUMP_LENGTH_VAR format_default_length
+#define DUMP_OPTION "fmt"
+#define DUMP_EXT ".fmt"
+#define INPUT_FORMAT kpse_tex_format
+#define INI_PROGRAM "luainitex"
+#define VIR_PROGRAM "luavirtex"
+#define TEXMFENGINENAME "luatex"
+
diff --git a/Build/source/texk/web2c/luatexdir/luatexlib.mk b/Build/source/texk/web2c/luatexdir/luatexlib.mk
new file mode 100644
index 00000000000..b1239b203ba
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/luatexlib.mk
@@ -0,0 +1,214 @@
+## luatexlib.mk - Makefile fragment for libraries used by pdf[ex]tex.
+# $Id$
+# Public domain.
+
+# The pdf*tex programs depend on a number of libraries.
+# Include dependencies to get the built if we don't do make
+# from the top-level directory.
+
+Makefile: luatexdir/luatexlib.mk
+
+# libz
+
+ZLIBDIR=../../libs/zlib
+ZLIBSRCDIR=$(srcdir)/$(ZLIBDIR)
+ZLIBDEP = @ZLIBDEP@
+LDZLIB = @LDZLIB@
+
+$(ZLIBDIR)/libz.a: $(ZLIBSRCDIR)
+ cd $(ZLIBDIR) && $(MAKE) $(common_makeargs) libz.a
+
+# libpng
+
+LIBPNGDIR=../../libs/libpng
+LIBPNGSRCDIR=$(srcdir)/$(LIBPNGDIR)
+LIBPNGDEP = @LIBPNGDEP@
+LDLIBPNG = @LDLIBPNG@
+
+$(LIBPNGDIR)/libpng.a: $(LIBPNGSRCDIR)/*.c
+ cd $(LIBPNGDIR) && $(MAKE) $(common_makeargs) libpng.a
+
+
+# libxpdf
+
+LIBXPDFDIR=../../libs/xpdf
+LIBXPDFSRCDIR=$(srcdir)/$(LIBXPDFDIR)
+LIBXPDFDEP = @LIBXPDFDEP@
+LDLIBXPDF = @LDLIBXPDF@
+
+$(LIBXPDFDIR)/fofi/libfofi.a: $(LIBXPDFSRCDIR)/fofi/*.cc \
+ $(LIBXPDFSRCDIR)/fofi/*.h
+ cd $(LIBXPDFDIR)/fofi; $(MAKE) $(common_makeargs) libfofi.a
+$(LIBXPDFDIR)/goo/libGoo.a: $(LIBXPDFSRCDIR)/goo/*.cc \
+ $(LIBXPDFSRCDIR)/goo/*.c $(LIBXPDFSRCDIR)/goo/*.h
+ cd $(LIBXPDFDIR)/goo; $(MAKE) $(common_makeargs) libGoo.a
+$(LIBXPDFDIR)/xpdf/libxpdf.a: $(LIBXPDFSRCDIR)/xpdf/*.cc \
+ $(LIBXPDFSRCDIR)/xpdf/*.h
+ cd $(LIBXPDFDIR)/xpdf; $(MAKE) $(common_makeargs) libxpdf.a
+
+
+# md5
+
+LIBMD5DIR=../../libs/md5
+LIBMD5SRCDIR=$(srcdir)/$(LIBMD5DIR)
+LIBMD5DEP=$(LIBMD5DIR)/md5.o
+
+$(LIBMD5DEP): $(LIBMD5SRCDIR)/md5.c $(LIBMD5SRCDIR)/md5.h
+clean:: md5lib-clean
+md5lib-clean:
+ rm -f $(LIBMD5DEP)
+
+# obsdcompat
+LIBOBSDDIR=../../libs/obsdcompat
+LIBOBSDSRCDIR=$(srcdir)/$(LIBOBSDCOMPATDIR)
+LIBOBSDDEP=@LIBOBSDDEP@
+LDLIBOBSD=@LDLIBOBSD@
+
+$(LIBOBSDDIR)/libopenbsd-compat.a: $(LIBOBSDSRCDIR)/*.c $(LIBOBSDSRCDIR)/*.h
+# common_makeargs = $(MFLAGS) CC='$(CC)' CFLAGS='$(CFLAGS)' LDFLAGS='$(LDFLAGS)' $(XMAKEARGS)
+# CFLAGS setzt libopenbsd-compat selbst, nicht durchreichen!
+ cd $(LIBOBSDDIR); $(MAKE) $(MFLAGS) $(XMAKEARGS) libopenbsd-compat.a
+
+# libpdf itself
+pdflib = luatexdir/libpdf.a
+pdflib_sources = $(srcdir)/luatexdir/*.c $(srcdir)/luatexdir/*.cc \
+ $(srcdir)/luatexdir/*.h
+
+luatexdir/libpdf.a: $(pdflib_sources) luatexdir/luatexextra.h ctangle
+ cd luatexdir && mkdir -p font image lua lang tex && $(MAKE) $(common_makeargs) libpdf.a
+
+# makecpool:
+
+luatexdir/makecpool: luatexdir/makecpool.c
+ cd luatexdir && $(MAKE) $(common_makeargs) makecpool
+
+# lua
+
+LIBLUADIR=../../libs/lua51
+LIBLUASRCDIR=$(srcdir)/$(LIBLUADIR)
+LIBLUADEP=$(LIBLUADIR)/liblua.a
+
+luatarget=posix
+ifeq ($(target),i386-mingw32)
+ ifeq ($(host),i386-linux)
+ luatarget = mingwcross
+ else
+ luatarget = mingw
+ endif
+else
+ifeq ($(target),i386-linux)
+ luatarget = posix
+endif
+endif
+
+
+$(LIBLUADEP):
+ mkdir -p $(LIBLUADIR) && cd $(LIBLUADIR) && cp -f $(LIBLUASRCDIR)/* . && $(MAKE) $(luatarget)
+
+# slnunicode
+SLNUNICODEDIR=../../libs/slnunicode
+SLNUNICODESRCDIR=$(srcdir)/$(SLNUNICODEDIR)
+SLNUNICODEDEP=$(SLNUNICODEDIR)/slnunico.o
+$(SLNUNICODEDEP): $(SLNUNICODEDIR)/slnunico.c $(SLNUNICODEDIR)/slnudata.c
+ mkdir -p $(SLNUNICODEDIR) && cd $(SLNUNICODEDIR) && cp -f $(SLNUNICODESRCDIR)/* . && $(CC) $(CFLAGS) -I$(LIBLUADIR) -o slnunico.o -c slnunico.c
+
+# zziplib
+
+# zziplib is a configuration nightmare, because it is so stubborn
+# about using a pre-installed zlib. configure and make have to
+# be fooled in two different ways.
+# - configure needs to find
+# the subdirs 'include' and 'lib' in the --with-zlib prefix,
+# and these need to contain the proper headers and libraries.
+# - make needs to find the right headers using an -I via CPPFLAGS,
+# because the zlib path is relative and can't be found otherwise.
+#
+# final trickyness: configure writes a Makefile in the source
+# directory. it is needed by anything, so I delete it right away
+
+zzipretarget=
+
+ifeq ($(target),i386-mingw32)
+ zzipretarget=--target=$(target) --build=$(target) --host=$(host)
+endif
+
+
+ZZIPLIBDIR=../../libs/zziplib
+ZZIPLIBSRCDIR=$(srcdir)/$(ZZIPLIBDIR)
+ZZIPLIBDEP = $(ZZIPLIBDIR)/zzip/libzzip.a
+
+$(ZZIPLIBDEP): $(ZZIPLIBSRCDIR)
+ mkdir -p $(ZZIPLIBDIR)/zzip && cd $(ZZIPLIBDIR)/zzip && \
+ cp ../$(ZZIPLIBSRCDIR)/zzip/Makefile . && $(MAKE) $(common_makeargs)
+
+# luazip
+
+LUAZIPDIR=../../libs/luazip
+LUAZIPSRCDIR=$(srcdir)/$(LUAZIPDIR)
+LUAZIPDEP=$(LUAZIPDIR)/src/luazip.o
+LUAZIPINC=-I../../lua51 -I../$(ZZIPLIBSRCDIR) -I../$(ZZIPLIBDIR)
+
+$(LUAZIPDEP): $(LUAZIPDIR)/src/luazip.c
+ mkdir -p $(LUAZIPDIR) && cd $(LUAZIPDIR) && cp -R $(LUAZIPSRCDIR)/* . && \
+ cd src && $(CC) $(CFLAGS) $(LUAZIPINC) -g -o luazip.o -c luazip.c
+
+# luafilesystem
+
+LUAFSDIR=../../libs/luafilesystem
+LUAFSSRCDIR=$(srcdir)/$(LUAFSDIR)
+LUAFSDEP=$(LUAFSDIR)/src/lfs.o
+LUAFSINC=-I../../lua51
+
+$(LUAFSDEP): $(LUAFSDIR)/src/lfs.c $(LUAFSDIR)/src/lfs.h
+ mkdir -p $(LUAFSDIR) && cd $(LUAFSDIR) && cp -R $(LUAFSSRCDIR)/* . && \
+ cd src && $(CC) $(CFLAGS) $(LUAFSINC) -g -o lfs.o -c lfs.c
+
+# luapeg
+LUAPEGDIR=../../libs/luapeg
+LUAPEGSRCDIR=$(srcdir)/$(LUAPEGDIR)
+LUAPEGDEP=$(LUAPEGDIR)/lpeg.o
+$(LUAPEGDEP): $(LUAPEGDIR)/lpeg.c
+ mkdir -p $(LUAPEGDIR) && cd $(LUAPEGDIR) && cp -f $(LUAPEGSRCDIR)/* . && $(CC) $(CFLAGS) -I$(LIBLUADIR) -g -o lpeg.o -c lpeg.c
+
+
+# luamd5
+LUAMDVDIR=../../libs/luamd5
+LUAMDVSRCDIR=$(srcdir)/$(LUAMDVDIR)
+LUAMDVDEP=$(LUAMDVDIR)/md5lib.o $(LUAMDVDIR)/md5.o
+$(LUAMDVDEP): $(LUAMDVDIR)/md5lib.c $(LUAMDVDIR)/md5.h $(LUAMDVDIR)/md5.c
+ mkdir -p $(LUAMDVDIR) && cd $(LUAMDVDIR) && cp -f $(LUAMDVSRCDIR)/* . && $(CC) $(CFLAGS) -I$(LIBLUADIR) -g -o md5.o -c md5.c && $(CC) $(CFLAGS) -I$(LIBLUADIR) -g -o md5lib.o -c md5lib.c
+
+.PHONY: always
+
+# luaff
+LUAFFDIR=../../libs/luafontforge
+LUAFFSRCDIR=$(srcdir)/$(LUAFFDIR)
+LUAFFDEP=$(LUAFFDIR)/libff.a
+$(LUAFFDEP): always
+ mkdir -p $(LUAFFDIR) && cp -f $(LUAFFSRCDIR)/Makefile $(LUAFFDIR)
+ mkdir -p $(LUAFFDIR)/fontforge && cp -f $(LUAFFSRCDIR)/fontforge/fontforge/Makefile $(LUAFFDIR)/fontforge
+ mkdir -p $(LUAFFDIR)/Unicode && cp -f $(LUAFFSRCDIR)/fontforge/Unicode/Makefile $(LUAFFDIR)/Unicode
+ cd $(LUAFFDIR) && $(MAKE)
+
+
+# luazlib
+LUAZLIBDIR=../../libs/luazlib
+LUAZLIBSRCDIR=$(srcdir)/$(LUAZLIBDIR)
+LUAZLIBDEP=$(LUAZLIBDIR)/lgzip.o $(LUAZLIBDIR)/lzlib.o
+LUAZLIBINC=-I$(ZLIBSRCDIR) -I$(LIBLUASRCDIR)
+$(LUAZLIBDEP): $(LUAZLIBDIR)/lgzip.c $(LUAZLIBDIR)/lzlib.c
+ mkdir -p $(LUAZLIBDIR) && cd $(LUAZLIBDIR) && cp -f $(LUAZLIBSRCDIR)/* . && $(CC) $(CFLAGS) $(LUAZLIBINC) -g -o lgzip.o -c lgzip.c && $(CC) $(CFLAGS) $(LUAZLIBINC) -g -o lzlib.o -c lzlib.c
+
+
+# Convenience variables.
+
+luatexlibs = $(pdflib) $(LDLIBPNG) $(LDZLIB) $(LDLIBXPDF) $(LIBMD5DEP) $(LDLIBOBSD) \
+ $(LIBLUADEP) $(SLNUNICODEDEP) $(LUAZIPDEP) $(ZZIPLIBDEP) $(LUAFSDEP) \
+ $(LUAPEGDEP) $(LUAMDVDEP) $(LUAZLIBDEP) $(LUAFFDEP)
+
+luatexlibsdep = $(pdflib) $(LIBPNGDEP) $(ZLIBDEP) $(LIBXPDFDEP) $(LIBMD5DEP) $(LIBOBSDDEP) \
+ $(LIBLUADEP) $(SLNUNICODEDEP) $(ZZIPLIBDEP) $(LUAZIPDEP) $(LUAFSDEP) \
+ $(LUAPEGDEP) $(LUAMDVDEP) $(LUAZLIBDEP) $(LUAFFDEP) $(makecpool)
+
+## end of luatexlib.mk - Makefile fragment for libraries used by pdf[ex]tex.
+
diff --git a/Build/source/texk/web2c/luatexdir/macnames.c b/Build/source/texk/web2c/luatexdir/macnames.c
new file mode 100644
index 00000000000..832e05e052d
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/macnames.c
@@ -0,0 +1,312 @@
+/*
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+const char notdef[] = ".notdef";
+
+const char *mac_glyph_names[] = {
+/* 0x00 */
+ notdef,
+ ".null",
+ "CR",
+ "space",
+ "exclam",
+ "quotedbl",
+ "numbersign",
+ "dollar",
+ "percent",
+ "ampersand",
+ "quotesingle",
+ "parenleft",
+ "parenright",
+ "asterisk",
+ "plus",
+ "comma",
+/* 0x10 */
+ "hyphen",
+ "period",
+ "slash",
+ "zero",
+ "one",
+ "two",
+ "three",
+ "four",
+ "five",
+ "six",
+ "seven",
+ "eight",
+ "nine",
+ "colon",
+ "semicolon",
+ "less",
+/* 0x20 */
+ "equal",
+ "greater",
+ "question",
+ "at",
+ "A",
+ "B",
+ "C",
+ "D",
+ "E",
+ "F",
+ "G",
+ "H",
+ "I",
+ "J",
+ "K",
+ "L",
+/* 0x30 */
+ "M",
+ "N",
+ "O",
+ "P",
+ "Q",
+ "R",
+ "S",
+ "T",
+ "U",
+ "V",
+ "W",
+ "X",
+ "Y",
+ "Z",
+ "bracketleft",
+ "backslash",
+/* 0x40 */
+ "bracketright",
+ "asciicircum",
+ "underscore",
+ "grave",
+ "a",
+ "b",
+ "c",
+ "d",
+ "e",
+ "f",
+ "g",
+ "h",
+ "i",
+ "j",
+ "k",
+ "l",
+/* 0x50 */
+ "m",
+ "n",
+ "o",
+ "p",
+ "q",
+ "r",
+ "s",
+ "t",
+ "u",
+ "v",
+ "w",
+ "x",
+ "y",
+ "z",
+ "braceleft",
+ "bar",
+/* 0x60 */
+ "braceright",
+ "asciitilde",
+ "Adieresis",
+ "Aring",
+ "Ccedilla",
+ "Eacute",
+ "Ntilde",
+ "Odieresis",
+ "Udieresis",
+ "aacute",
+ "agrave",
+ "acircumflex",
+ "adieresis",
+ "atilde",
+ "aring",
+ "ccedilla",
+/* 0x70 */
+ "eacute",
+ "egrave",
+ "ecircumflex",
+ "edieresis",
+ "iacute",
+ "igrave",
+ "icircumflex",
+ "idieresis",
+ "ntilde",
+ "oacute",
+ "ograve",
+ "ocircumflex",
+ "odieresis",
+ "otilde",
+ "uacute",
+ "ugrave",
+/* 0x80 */
+ "ucircumflex",
+ "udieresis",
+ "dagger",
+ "degree",
+ "cent",
+ "sterling",
+ "section",
+ "bullet",
+ "paragraph",
+ "germandbls",
+ "registered",
+ "copyright",
+ "trademark",
+ "acute",
+ "dieresis",
+ "notequal",
+/* 0x90 */
+ "AE",
+ "Oslash",
+ "infinity",
+ "plusminus",
+ "lessequal",
+ "greaterequal",
+ "yen",
+ "mu",
+ "partialdiff",
+ "Sigma",
+ "Pi",
+ "pi",
+ "integral",
+ "ordfeminine",
+ "ordmasculine",
+ "Omega",
+/* 0xa0 */
+ "ae",
+ "oslash",
+ "questiondown",
+ "exclamdown",
+ "logicalnot",
+ "radical",
+ "florin",
+ "approxequal",
+ "Delta",
+ "guillemotleft",
+ "guillemotright",
+ "ellipsis",
+ "nbspace",
+ "Agrave",
+ "Atilde",
+ "Otilde",
+/* 0xb0 */
+ "OE",
+ "oe",
+ "endash",
+ "emdash",
+ "quotedblleft",
+ "quotedblright",
+ "quoteleft",
+ "quoteright",
+ "divide",
+ "lozenge",
+ "ydieresis",
+ "Ydieresis",
+ "fraction",
+ "currency",
+ "guilsinglleft",
+ "guilsinglright",
+/* 0xc0 */
+ "fi",
+ "fl",
+ "daggerdbl",
+ "periodcentered",
+ "quotesinglbase",
+ "quotedblbase",
+ "perthousand",
+ "Acircumflex",
+ "Ecircumflex",
+ "Aacute",
+ "Edieresis",
+ "Egrave",
+ "Iacute",
+ "Icircumflex",
+ "Idieresis",
+ "Igrave",
+/* 0xd0 */
+ "Oacute",
+ "Ocircumflex",
+ "applelogo",
+ "Ograve",
+ "Uacute",
+ "Ucircumflex",
+ "Ugrave",
+ "dotlessi",
+ "circumflex",
+ "tilde",
+ "macron",
+ "breve",
+ "dotaccent",
+ "ring",
+ "cedilla",
+ "hungarumlaut",
+/* 0xe0 */
+ "ogonek",
+ "caron",
+ "Lslash",
+ "lslash",
+ "Scaron",
+ "scaron",
+ "Zcaron",
+ "zcaron",
+ "brokenbar",
+ "Eth",
+ "eth",
+ "Yacute",
+ "yacute",
+ "Thorn",
+ "thorn",
+ "minus",
+/* 0xf0 */
+ "multiply",
+ "onesuperior",
+ "twosuperior",
+ "threesuperior",
+ "onehalf",
+ "onequarter",
+ "threequarters",
+ "franc",
+ "Gbreve",
+ "gbreve",
+ "Idot",
+ "Scedilla",
+ "scedilla",
+ "Cacute",
+ "cacute",
+ "Ccaron",
+/* 0x100 */
+ "ccaron",
+ "dmacron"
+};
+
+const char *ambiguous_names[] = {
+ "Delta", /* increment */
+ "Omega", /* Ohm */
+ "Pi", /* product */
+ "Sigma", /* summation */
+ "dmacron", /* dslash */
+ "macron", /* overscore */
+ "periodcentered", /* middot */
+ NULL
+};
diff --git a/Build/source/texk/web2c/luatexdir/makecpool.c b/Build/source/texk/web2c/luatexdir/makecpool.c
new file mode 100644
index 00000000000..162a4848482
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/makecpool.c
@@ -0,0 +1,60 @@
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+
+int main(int argc, char *argv[]) {
+ if (argc!=3) {
+ puts("Need exactly two arguments: pool_name and header_name");
+ exit(1);
+ }
+ char *filename = argv[1];
+ char *headername = argv[2];
+ FILE *fh = fopen(filename,"r");
+ char data[1024];
+ printf(
+ "/* This file is auto-generated by makecpool */\n"
+ "\n"
+ "#include <stdio.h>\n"
+ "#include \"%s\"\n"
+ "\n"
+ "static char *poolfilearr[] = {\n",headername);
+ while (fgets(data,1024,fh)) {
+ int len = strlen(data);
+ int o = 0; /* skip first o characters*/
+ int i;
+ if (data[len-1]=='\n') { /* chomp;*/
+ data[len-1] = 0;
+ len--;
+ }
+ if (data[0]=='*') break; /* last if !^\*!; */
+ if (data[0]>='0' && data[0]<='9' && data[1]>='0' && data[1]<='9') {
+ o=2; /* $data =~ s/^\d\d//; */
+ }
+ printf(" \"");
+ for (i=o; i<len; i++) {
+ if (data[i]=='"' || data[i]=='\\') putchar('\\');
+ if (data[i]=='?') printf("\" \""); /* suppress trigraphs */
+ putchar(data[i]);
+ } /* $data =~ s/(["\\])/\\$1/g; */
+ printf("\",\n");
+ }
+ fclose(fh);
+ printf(" NULL };\n"
+ "int loadpoolstrings (integer spare_size) {\n"
+ " strnumber g=0;\n"
+ " int i=0,j=0;\n"
+ " char *s;\n"
+ " while ((s = poolfilearr[j++])) {\n"
+ " int l = strlen (s);\n"
+ " i += l;\n"
+ " if (i>=spare_size) return 0;\n"
+ /*" while (l-- > 0) strpool[poolptr++] = *s++;\n"*/
+ " while (l-- > 0) str_pool[pool_ptr++] = *s++;\n"
+ /* " g = makestring();\n"*/
+ " g = make_string();\n"
+ /* " strref[g]= 127;\n"*/
+ " }\n"
+ " return g;\n"
+ "}\n");
+ return 0;
+}
diff --git a/Build/source/texk/web2c/luatexdir/managed-sa.c b/Build/source/texk/web2c/luatexdir/managed-sa.c
new file mode 100644
index 00000000000..cc63d7e75f5
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/managed-sa.c
@@ -0,0 +1,245 @@
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "managed-sa.h"
+
+
+static void
+store_sa_stack (sa_tree a, integer n, integer v, integer gl) {
+ sa_stack_item st;
+ st.code = n;
+ st.value = v;
+ st.level = gl;
+ if (a->stack == NULL) {
+ a->stack = Mxmalloc_array(sa_stack_item,a->stack_size);
+ } else if (((a->stack_ptr)+1)>=a->stack_size) {
+ a->stack_size += a->stack_step;
+ a->stack = Mxrealloc_array(a->stack,sa_stack_item,a->stack_size);
+ }
+ (a->stack_ptr)++;
+ a->stack[a->stack_ptr] = st;
+}
+
+static void
+skip_in_stack (sa_tree a, integer n) {
+ int p = a->stack_ptr;
+ if (a->stack == NULL)
+ return;
+ while (p>0) {
+ if (a->stack[p].code == n && a->stack[p].level > 0) {
+ a->stack[p].level = -(a->stack[p].level);
+ }
+ p--;
+ }
+}
+
+sa_tree_item
+get_sa_item (const sa_tree head, const integer n) {
+ register int h;
+ register int m;
+ if (head->tree != NULL) {
+ h = HIGHPART_PART(n);
+ if (head->tree[h] != NULL) {
+ m = MIDPART_PART(n);
+ if (head->tree[h][m] != NULL) {
+ return head->tree[h][m][LOWPART_PART(n)];
+ }
+ }
+ }
+ return head->dflt;
+}
+
+void
+set_sa_item (sa_tree head, integer n, sa_tree_item v, integer gl) {
+ int h,m,l;
+ int i;
+ h = HIGHPART_PART(n);
+ m = MIDPART_PART(n);
+ l = LOWPART_PART(n);
+ if (head->tree == NULL) {
+ head->tree = (sa_tree_item ***) Mxmalloc_array(sa_tree_item **,HIGHPART);
+ for (i=0; i<HIGHPART; i++) { head->tree[i] = NULL; }
+ }
+ if (head->tree[h] == NULL) {
+ head->tree[h] = (sa_tree_item **) Mxmalloc_array(sa_tree_item *,MIDPART);
+ for (i=0; i<MIDPART; i++) { head->tree[h][i] = NULL; }
+ }
+ if (head->tree[h][m] == NULL) {
+ head->tree[h][m] = (sa_tree_item *) Mxmalloc_array(sa_tree_item,LOWPART);
+ for (i=0; i<LOWPART; i++) { head->tree[h][m][i] = head->dflt; }
+ }
+ if (gl<=1) {
+ skip_in_stack(head,n);
+ } else {
+ store_sa_stack(head,n,head->tree[h][m][l],gl);
+ }
+ head->tree[h][m][l] = v;
+}
+
+static void
+rawset_sa_item (sa_tree head, integer n, integer v) {
+ head->tree[HIGHPART_PART(n)][MIDPART_PART(n)][LOWPART_PART(n)] = v;
+}
+
+void
+clear_sa_stack (sa_tree a) {
+ if (a->stack != NULL) {
+ Mxfree(a->stack);
+ }
+ a->stack = NULL;
+ a->stack_ptr = 0;
+ a->stack_size = a->stack_step;
+}
+
+void
+destroy_sa_tree (sa_tree a) {
+ int h,m;
+ if (a == NULL)
+ return;
+ if (a->tree != NULL) {
+ for (h=0; h<HIGHPART;h++ ) {
+ if (a->tree[h] != NULL) {
+ for (m=0; m<MIDPART; m++ ) {
+ if (a->tree[h][m] != NULL) {
+ Mxfree(a->tree[h][m]);
+ }
+ }
+ Mxfree(a->tree[h]);
+ }
+ }
+ Mxfree(a->tree);
+ }
+ if (a->stack != NULL) {
+ Mxfree(a->stack);
+ }
+ Mxfree(a);
+}
+
+
+sa_tree
+copy_sa_tree(sa_tree b) {
+ int h,m,l;
+ sa_tree a = (sa_tree)Mxmalloc_array(sa_tree_head,1);
+ a->stack_step = b->stack_step;
+ a->stack_size = b->stack_size;
+ a->dflt = b->dflt;
+ a->stack = NULL;
+ a->stack_ptr = 0;
+ a->tree = NULL;
+ if (b->tree !=NULL) {
+ a->tree = (sa_tree_item ***)Mxmalloc_array(void *,HIGHPART);
+ for (h=0; h<HIGHPART;h++ ) {
+ if (b->tree[h] != NULL) {
+ a->tree[h]=(sa_tree_item **)Mxmalloc_array(void *,MIDPART);
+ for (m=0; m<MIDPART; m++ ) {
+ if (b->tree[h][m]!=NULL) {
+ a->tree[h][m]=Mxmalloc_array(sa_tree_item,LOWPART);
+ for (l=0; l<LOWPART; l++) {
+ a->tree[h][m][l] = b->tree[h][m][l] ;
+ }
+ } else {
+ a->tree[h][m] = NULL;
+ }
+ }
+ } else {
+ a->tree[h]= NULL;
+ }
+ }
+ }
+ return a;
+}
+
+
+sa_tree
+new_sa_tree (integer size, sa_tree_item dflt) {
+ sa_tree_head *a;
+ a = (sa_tree_head *)xmalloc(sizeof(sa_tree_head));
+ a->dflt = dflt;
+ a->stack = NULL;
+ a->tree = NULL;
+ a->stack_size = size;
+ a->stack_step = size;
+ a->stack_ptr = 0;
+ return (sa_tree)a;
+}
+
+void
+restore_sa_stack (sa_tree head, integer gl) {
+ sa_stack_item st;
+ if (head->stack == NULL)
+ return;
+ while (head->stack_ptr>0 && abs(head->stack[head->stack_ptr].level)>=gl) {
+ st = head->stack[head->stack_ptr];
+ if (st.level>0) {
+ rawset_sa_item (head, st.code, st.value);
+ }
+ (head->stack_ptr)--;
+ }
+}
+
+
+void
+dump_sa_tree (sa_tree a) {
+ boolean f;
+ unsigned int x;
+ int h,m,l;
+ if (a == NULL)
+ return;
+ dump_int(a->stack_step);
+ dump_int(a->dflt);
+ if (a->tree != NULL) {
+ for (h=0; h<HIGHPART;h++ ) {
+ if (a->tree[h] != NULL) {
+ f = 1; dump_qqqq(f);
+ for (m=0; m<MIDPART; m++ ) {
+ if (a->tree[h][m] != NULL) {
+ f = 1; dump_qqqq(f);
+ for (l=0;l<LOWPART;l++) {
+ x = a->tree[h][m][l]; dump_int(x);
+ }
+ } else {
+ f = 0; dump_qqqq(f);
+ }
+ }
+ } else {
+ f = 0; dump_qqqq(f);
+ }
+ }
+ }
+}
+
+
+sa_tree
+undump_sa_tree(void) {
+ unsigned int x;
+ int h,m,l;
+ boolean f;
+ sa_tree a = (sa_tree)Mxmalloc_array(sa_tree_head,1);
+ undump_int(x) ; a->stack_step = x; a->stack_size = x;
+ undump_int(x) ; a->dflt = x;
+ a->stack = Mxmalloc_array(sa_stack_item,a->stack_size);
+ a->stack_ptr = 0;
+ a->tree = (sa_tree_item ***)Mxmalloc_array(void *,HIGHPART);
+ for (h=0; h<HIGHPART;h++ ) {
+ undump_qqqq(f);
+ if (f>0) {
+ a->tree[h]=(sa_tree_item **)Mxmalloc_array(void *,MIDPART);
+ for (m=0; m<MIDPART; m++ ) {
+ undump_qqqq(f);
+ if (f>0) {
+ a->tree[h][m]=Mxmalloc_array(sa_tree_item,LOWPART);
+ for (l=0; l<LOWPART; l++) {
+ undump_int(x); a->tree[h][m][l] = x;
+ }
+ } else {
+ a->tree[h][m] = NULL;
+ }
+ }
+ } else {
+ a->tree[h]= NULL;
+ }
+ }
+ return a;
+}
+
+
diff --git a/Build/source/texk/web2c/luatexdir/managed-sa.h b/Build/source/texk/web2c/luatexdir/managed-sa.h
new file mode 100644
index 00000000000..b73aece81b1
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/managed-sa.h
@@ -0,0 +1,74 @@
+/*
+ Copyright (c) 2007 Taco Hoekwater <taco@luatex.org>
+
+ This file is part of LuaTeX.
+
+ LuaTeX is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with LuaTeX; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ $Id$ */
+
+#ifndef MANAGED_SA_H
+#define MANAGED_SA_H 1
+
+/* the next two sets of three had better match up exactly, but using bare numbers
+ is easier on the C compiler */
+
+#define HIGHPART 128
+#define MIDPART 128
+#define LOWPART 128
+
+#define HIGHPART_PART(a) ((a>>14)&127)
+#define MIDPART_PART(a) ((a>>7)&127)
+#define LOWPART_PART(a) (a&127)
+
+#define Mxmalloc_array(a,b) xmalloc(b*sizeof(a))
+#define Mxrealloc_array(a,b,c) xrealloc(a,c*sizeof(b))
+#define Mxfree(a) free(a); a=NULL
+
+typedef unsigned int sa_tree_item;
+
+typedef struct {
+ int code;
+ int level;
+ sa_tree_item value;
+} sa_stack_item;
+
+
+typedef struct {
+ int stack_size; /* initial stack size */
+ int stack_step; /* increment stack step */
+ int stack_ptr; /* current stack point */
+ int dflt; /* default item value */
+ sa_tree_item *** tree; /* item tree head */
+ sa_stack_item * stack; /* stack tree head */
+} sa_tree_head;
+
+typedef sa_tree_head *sa_tree;
+
+extern sa_tree_item get_sa_item (const sa_tree head, const integer n) ;
+extern void set_sa_item (sa_tree head, integer n, sa_tree_item v, integer gl) ;
+
+extern sa_tree new_sa_tree (integer size, sa_tree_item dflt);
+
+extern sa_tree copy_sa_tree (sa_tree head);
+extern void destroy_sa_tree (sa_tree head);
+
+extern void dump_sa_tree (sa_tree a);
+extern sa_tree undump_sa_tree (void) ;
+
+extern void restore_sa_stack (sa_tree a, integer gl);
+extern void clear_sa_stack (sa_tree a);
+
+#endif
diff --git a/Build/source/texk/web2c/luatexdir/mathcodes.c b/Build/source/texk/web2c/luatexdir/mathcodes.c
new file mode 100644
index 00000000000..77e15e7c66c
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/mathcodes.c
@@ -0,0 +1,191 @@
+
+/*
+Copyright (c) 2006 Taco Hoekwater, <taco@elvenkind.com>
+
+This file is part of LuaTeX.
+
+LuaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+LuaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with LuaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id $
+*/
+
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include "managed-sa.h"
+
+/* the 0xFFFFFFFF is a flag value */
+
+#define MATHCODESTACK 8
+#define MATHCODEDEFAULT 0xFFFFFFFF
+
+static sa_tree mathcode_head = NULL;
+
+typedef struct delcodeval {
+ integer valuea;
+ integer valueb;
+} delcodeval;
+
+/* delcodes are a bit more work */
+
+#define DELCODESTACK 4
+#define DELCODEDEFAULT 0xFFFFFFFF
+
+static sa_tree delcode_head = NULL;
+
+#define DELCODEHEAP 8
+
+static delcodeval * delcode_heap = NULL;
+static int delcode_heapsize = DELCODEHEAP;
+static int delcode_heapptr = 0;
+
+void
+unsavemathcode (quarterword gl) {
+ restore_sa_stack(mathcode_head,gl);
+}
+
+void
+set_math_code (integer n, halfword v, quarterword gl) {
+ set_sa_item(mathcode_head,n,v,gl);
+}
+
+halfword
+get_math_code (integer n) {
+ unsigned int ret;
+ ret = get_sa_item(mathcode_head,n);
+ if (ret==MATHCODEDEFAULT) {
+ return (halfword)n;
+ } else {
+ return (halfword)ret;
+ }
+}
+
+void
+initializemathcode (void) {
+ mathcode_head = new_sa_tree(MATHCODESTACK,MATHCODEDEFAULT);
+}
+
+void
+dumpmathcode (void) {
+ dump_sa_tree(mathcode_head);
+}
+
+void
+undumpmathcode (void) {
+ mathcode_head = undump_sa_tree();
+}
+
+/* TODO: clean up the heap */
+
+void
+unsavedelcode (quarterword gl) {
+ restore_sa_stack(delcode_head,gl);
+}
+
+void
+set_del_code (integer n, halfword v, halfword w, quarterword gl) {
+ delcodeval d;
+ d.valuea = v; d.valueb = w;
+ if (delcode_heapptr==delcode_heapsize) {
+ delcode_heapsize += DELCODEHEAP;
+ delcode_heap = Mxrealloc_array(delcode_heap,delcodeval,delcode_heapsize);
+ }
+ delcode_heap[delcode_heapptr] = d;
+ set_sa_item(delcode_head,n,delcode_heapptr,gl);
+ delcode_heapptr++;
+}
+
+halfword
+get_del_code_a (integer n) {
+ int ret;
+ ret = get_sa_item(delcode_head,n);
+ if (ret==DELCODEDEFAULT) {
+ return (halfword)-1;
+ } else {
+ return (halfword)delcode_heap[ret].valuea;
+ }
+}
+
+halfword
+get_del_code_b (integer n) {
+ unsigned int ret;
+ ret = get_sa_item(delcode_head,n);
+ if (ret==DELCODEDEFAULT) {
+ return (halfword)-1;
+ } else {
+ return (halfword)delcode_heap[ret].valueb;
+ }
+}
+
+void
+initializedelcode (void) {
+ delcode_head = new_sa_tree(DELCODESTACK,DELCODEDEFAULT);
+ delcode_heap = Mxmalloc_array(delcodeval,DELCODEHEAP);
+}
+
+void
+dumpdelcode (void) {
+ int k;
+ delcodeval d;
+ dump_sa_tree(delcode_head);
+ dump_int(delcode_heapsize);
+ dump_int(delcode_heapptr);
+ for (k=0;k<delcode_heapptr;k++) {
+ d = delcode_heap[k];
+ dump_int(d.valuea);
+ dump_int(d.valueb);
+ }
+}
+
+void
+undumpdelcode (void) {
+ int k;
+ delcodeval d;
+ delcode_head = undump_sa_tree();
+ undump_int(delcode_heapsize);
+ undump_int(delcode_heapptr);
+ delcode_heap = Mxmalloc_array(delcodeval,delcode_heapsize);
+ for (k=0;k<delcode_heapptr;k++) {
+ undump_int(d.valuea);
+ undump_int(d.valueb);
+ delcode_heap[k] = d;
+ }
+ d.valuea=0; d.valueb=0;
+ for (k=delcode_heapptr;k<delcode_heapsize;k++) {
+ delcode_heap[k] = d;
+ }
+}
+
+void
+unsave_math_codes (quarterword grouplevel) {
+ unsavemathcode(grouplevel);
+ unsavedelcode(grouplevel);
+}
+
+void initialize_math_codes (void) {
+ initializemathcode();
+ initializedelcode();
+}
+
+void dump_math_codes(void) {
+ dumpmathcode();
+ dumpdelcode();
+}
+
+void undump_math_codes(void) {
+ undumpmathcode();
+ undumpdelcode();
+}
diff --git a/Build/source/texk/web2c/luatexdir/nodes.h b/Build/source/texk/web2c/luatexdir/nodes.h
new file mode 100644
index 00000000000..ba2c09ecc78
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/nodes.h
@@ -0,0 +1,648 @@
+
+#include <stdarg.h>
+
+#ifndef __NODES_H__
+#define __NODES_H__
+
+/* these don't really belong here */
+
+#define token_ref_count(a) info((a)) /* reference count preceding a token list */
+#define add_token_ref(a) token_ref_count(a)++ /* new reference to a token list */
+
+
+/* these are in texlang.c */
+
+#define set_vlink(a,b) vlink(a)=b
+#define get_vlink(a) vlink(a)
+#define get_character(a) character(a)
+
+extern halfword insert_discretionary ( halfword t, halfword pre, halfword post, halfword replace);
+extern halfword insert_syllable_discretionary ( halfword t, lang_variables *lan);
+extern halfword insert_word_discretionary ( halfword t, lang_variables *lan);
+extern halfword insert_complex_discretionary ( halfword t, lang_variables *lan,
+ halfword pre, halfword post, halfword replace);
+extern halfword insert_character ( halfword t, int n);
+extern void set_disc_field (halfword f, halfword t);
+
+
+#define max_halfword 0x3FFFFFFF
+#ifndef null
+#define null 0
+#endif
+#define null_flag -0x40000000
+#define zero_glue 0
+#define normal 0
+
+#define vinfo(a) varmem[(a)].hh.v.LH
+#define vlink(a) varmem[(a)].hh.v.RH
+#define type(a) varmem[(a)].hh.u.B0
+#define subtype(a) varmem[(a)].hh.u.B1
+#define node_attr(a) vinfo((a)+1)
+#define alink(a) vlink((a)+1)
+
+#define node_size(a) varmem[(a)].hh.v.LH
+
+#define rlink(a) vlink((a)+1) /* aka alink() */
+#define llink(a) vinfo((a)+1) /* overlaps with node_attr() */
+
+#define add_glue_ref(a) glue_ref_count(a)++ /* new reference to a glue spec */
+
+/* really special head node pointers that only need links */
+
+#define temp_node_size 2
+
+/* attribute lists */
+
+/* it is convenient to have attribute list nodes and attribute node
+ * be the same size
+ */
+
+#define attribute_node_size 2
+
+#define attr_list_ref(a) vinfo((a)+1) /* the reference count */
+#define attribute_id(a) vinfo((a)+1)
+#define attribute_value(a) vlink((a)+1)
+
+#define cache_disabled max_halfword
+#define add_node_attr_ref(a) { if (a!=null) attr_list_ref((a))++; }
+
+#define replace_attribute_list(a,b) do { \
+ delete_attribute_ref(node_attr(a)); \
+ node_attr(a)=b; \
+ } while (0)
+
+extern void update_attribute_cache (void) ;
+extern halfword copy_attribute_list(halfword n) ;
+extern halfword do_set_attribute(halfword p, int i, int val);
+
+
+/* a glue spec */
+#define glue_spec_size 4
+#define stretch(a) vlink((a)+1)
+/* width == a+2 */
+#define shrink(a) vinfo((a)+1)
+#define stretch_order(a) type((a)+3)
+#define shrink_order(a) subtype((a)+3)
+#define glue_ref_count(a) vlink((a)+3)
+
+/* pdf action spec */
+
+#define pdf_action_size 4
+
+typedef enum {
+ pdf_action_page = 0,
+ pdf_action_goto,
+ pdf_action_thread,
+ pdf_action_user } pdf_action_types;
+
+#define pdf_action_type(a) type((a) + 1)
+#define pdf_action_named_id(a) subtype((a) + 1)
+#define pdf_action_id(a) vlink((a) + 1)
+#define pdf_action_file(a) vinfo((a) + 2)
+#define pdf_action_new_window(a) vlink((a) + 2)
+#define pdf_action_tokens(a) vinfo((a) + 3)
+#define pdf_action_refcount(a) vlink((a) + 3)
+
+/*increase count of references to this action*/
+#define add_action_ref(a) pdf_action_refcount((a))++
+
+/* decrease count of references to this
+ action; free it if there is no reference to this action*/
+
+#define delete_action_ref(a) { \
+ if (pdf_action_refcount(a) == null) { \
+ if (pdf_action_type(a) == pdf_action_user) { \
+ delete_token_ref(pdf_action_tokens(a)); \
+ } else { \
+ if (pdf_action_file(a) != null) \
+ delete_token_ref(pdf_action_file(a)); \
+ if (pdf_action_type(a) == pdf_action_page) \
+ delete_token_ref(pdf_action_tokens(a)); \
+ else if (pdf_action_named_id(a) > 0) \
+ delete_token_ref(pdf_action_id(a)); \
+ } \
+ free_node(a, pdf_action_size); \
+ } else { \
+ decr(pdf_action_refcount(a)); \
+ } \
+ }
+
+
+
+/* normal nodes */
+
+#define inf_bad 10000 /* infinitely bad value */
+#define inf_penalty inf_bad /*``infinite'' penalty value*/
+#define eject_penalty -(inf_penalty) /*``negatively infinite'' penalty value */
+
+#define penalty_node_size 3
+#define penalty(a) vlink((a)+2)
+
+#define glue_node_size 3
+#define glue_ptr(a) vinfo((a)+2)
+#define leader_ptr(a) vlink((a)+2)
+
+/* disc nodes could eventually be smaller, because the indirect
+ pointers are not really needed (8 instead of 10).
+ */
+
+#define disc_node_size 10
+
+typedef enum {
+ discretionary_disc=0,
+ explicit_disc,
+ automatic_disc,
+ syllable_disc } discretionary_types;
+
+#define pre_break_head(a) ((a)+4)
+#define post_break_head(a) ((a)+6)
+#define no_break_head(a) ((a)+8)
+
+#define pre_break(a) vinfo((a)+2)
+#define post_break(a) vlink((a)+2)
+#define no_break(a) vlink((a)+3)
+#define tlink llink
+
+#define vlink_pre_break(a) vlink(pre_break_head(a))
+#define vlink_post_break(a) vlink(post_break_head(a))
+#define vlink_no_break(a) vlink(no_break_head(a))
+
+#define tlink_pre_break(a) tlink(pre_break_head(a))
+#define tlink_post_break(a) tlink(post_break_head(a))
+#define tlink_no_break(a) tlink(no_break_head(a))
+
+#define kern_node_size 3
+#define explicit 1 /*|subtype| of kern nodes from \.{\\kern} and \.{\\/}*/
+#define acc_kern 2 /*|subtype| of kern nodes from accents */
+
+#define box_node_size 8
+#define width(a) varmem[(a+2)].cint
+#define depth(a) varmem[(a+3)].cint
+#define height(a) varmem[(a+4)].cint
+#define shift_amount(a) vlink((a)+5)
+#define box_dir(a) vinfo((a)+5)
+#define list_ptr(a) vlink((a)+6)
+#define glue_order(a) subtype((a)+6)
+#define glue_sign(a) type((a)+6)
+#define glue_set(a) varmem[(a+7)].gr
+
+/* unset nodes */
+#define glue_stretch(a) varmem[(a)+7].cint
+#define glue_shrink shift_amount
+#define span_count subtype
+
+#define rule_node_size 6
+#define rule_dir(a) vlink((a)+5)
+
+#define mark_node_size 3
+#define mark_ptr(a) vlink((a)+2)
+#define mark_class(a) vinfo((a)+2)
+
+#define adjust_node_size 3
+#define adjust_ptr(a) vlink(a+2)
+
+#define glyph_node_size 5
+
+#define character(a) vinfo((a)+2)
+#define font(a) vlink((a)+2)
+#define lang_data(a) vinfo((a)+3)
+#define lig_ptr(a) vlink((a)+3)
+#define x_displace(a) vinfo((a)+4)
+#define y_displace(a) vlink((a)+4)
+#define is_char_node(a) (a!=null && type(a)==glyph_node)
+
+#define char_lang(a) ((const int)(((unsigned)lang_data(a) & 0x7FFF0000)>>16))
+#define char_lhmin(a) ((const int)(((unsigned)lang_data(a) & 0x0000FF00)>>8))
+#define char_rhmin(a) ((const int)(((unsigned)lang_data(a) & 0x000000FF)))
+#define char_uchyph(a) ((const int)(((unsigned)lang_data(a) & 0x80000000)>>31))
+
+#define make_lang_data(a,b,c,d) (a>0 ? (1<<31): 0)+ \
+ (b<<16)+ (((c>0 && c<256) ? c : 1)<<8)+(((d>0 && d<256) ? d : 1))
+
+#define init_lang_data(a) lang_data(a)=256+1
+
+#define set_char_lang(a,b) lang_data(a)=make_lang_data(char_uchyph(a),b,char_lhmin(a),char_rhmin(a))
+#define set_char_lhmin(a,b) lang_data(a)=make_lang_data(char_uchyph(a),char_lang(a),b,char_rhmin(a))
+#define set_char_rhmin(a,b) lang_data(a)=make_lang_data(char_uchyph(a),char_lang(a),char_lhmin(a),b)
+#define set_char_uchyph(a,b) lang_data(a)=make_lang_data(b,char_lang(a),char_lhmin(a),char_rhmin(a))
+
+#define margin_kern_node_size 4
+#define margin_char(a) vlink((a)+3)
+
+/*@# {|subtype| of marginal kerns}*/
+#define left_side 0
+#define right_side 1
+
+#define math_node_size 3
+#define surround(a) vlink((a)+2)
+#define before 0 /*|subtype| for math node that introduces a formula*/
+#define after 1 /*|subtype| for math node that winds up a formula*/
+
+
+
+#define ins_node_size 6
+#define float_cost(a) varmem[(a)+2].cint
+#define ins_ptr(a) vinfo((a)+5)
+#define split_top_ptr(a) vlink((a)+5)
+
+
+#define page_ins_node_size 5
+
+#define broken_ptr(a) vlink((a)+2) /* an insertion for this class will break here if anywhere */
+#define broken_ins(a) vinfo((a)+2) /* this insertion might break at |broken_ptr| */
+#define last_ins_ptr(a) vlink((a)+3) /*the most recent insertion for this |subtype|*/
+#define best_ins_ptr(a) vinfo((a)+3) /*the optimum most recent insertion*/
+/* height = 4 */
+
+typedef enum {
+ hlist_node = 0,
+ vlist_node = 1,
+ rule_node,
+ ins_node,
+ mark_node,
+ adjust_node,
+ /* 6 used to be ligatures */
+ disc_node=7,
+ whatsit_node,
+ math_node,
+ glue_node,
+ kern_node,
+ penalty_node,
+ unset_node, /* 13 */
+ style_node,
+ choice_node,
+ ord_noad,
+ op_noad,
+ bin_noad,
+ rel_noad,
+ open_noad,
+ close_noad,
+ punct_noad,
+ inner_noad,
+ radical_noad,
+ fraction_noad,
+ under_noad,
+ over_noad,
+ accent_noad,
+ vcenter_noad,
+ left_noad,
+ right_noad,
+ margin_kern_node = 32,
+ glyph_node = 33,
+ align_record_node = 34,
+ pseudo_file_node = 35,
+ pseudo_line_node = 36,
+ inserting_node = 37,
+ split_up_node = 38,
+ expr_node = 39,
+ nesting_node = 40,
+ span_node = 41,
+ attribute_node = 42,
+ glue_spec_node = 43,
+ attribute_list_node = 44,
+ action_node = 45,
+ temp_node = 46,
+ align_stack_node = 47,
+ movement_node = 48,
+ if_node = 49,
+ unhyphenated_node = 50,
+ hyphenated_node = 51,
+ delta_node = 52,
+ passive_node = 53,
+ shape_node = 54 } node_types ;
+
+#define last_known_node temp_node /* used by \lastnodetype */
+
+#define movement_node_size 3
+#define expr_node_size 3
+#define if_node_size 2
+#define align_stack_node_size 6
+#define nesting_node_size 2
+
+#define span_node_size 3
+#define span_span(a) vlink((a)+1)
+#define span_link(a) vinfo((a)+1)
+
+#define pseudo_file_node_size 2
+#define pseudo_lines(a) vlink((a)+1)
+
+#define nodetype_has_attributes(t) (((t)<=glyph_node) && ((t)!=unset_node))
+
+#define style_node_size 4 /* number of words in a style node*/
+#define radical_noad_size 6 /*number of |mem| words in a radical noad*/
+#define accent_noad_size 6 /*number of |mem| words in an accent noad*/
+
+
+#define display_mlist(a) vinfo((a)+2) /* mlist to be used in display style*/
+#define text_mlist(a) vlink((a)+2) /* mlist to be used in text style */
+#define script_mlist(a) vinfo((a)+3) /* mlist to be used in script style */
+#define script_script_mlist(a) vlink((a)+3) /* mlist to be used in scriptscript style */
+
+#define noad_size 5 /*number of words in a normal noad*/
+#define nucleus(a) (a)+2 /* the |nucleus| field of a noad */
+#define supscr(a) (a)+3 /* the |supscr| field of a noad */
+#define subscr(a) (a)+4 /* the |subscr| field of a noad */
+#define math_type vlink /* a |quarterword| in |mem| */
+#define fam(a) type((a)) /* a |quarterword| in |mem| */
+
+#define fraction_noad_size 7 /*number of |mem| words in a fraction noad*/
+#define numerator supscr /*|numerator| field in a fraction noad*/
+#define denominator subscr /*|denominator| field in a fraction noad*/
+
+typedef enum {
+ math_char=1, /* |math_type| when the attribute is simple */
+ sub_box, /* |math_type| when the attribute is a box */
+ sub_mlist, /* |math_type| when the attribute is a formula */
+ math_text_char /* |math_type| when italic correction is dubious */
+} math_types;
+
+
+typedef enum {
+ open_node = 0,
+ write_node,
+ close_node,
+ special_node,
+ language_node,
+ set_language_code,
+ local_par_node,
+ dir_node,
+ pdf_literal_node,
+ pdf_obj_code,
+ pdf_refobj_node, /* 10 */
+ pdf_xform_code,
+ pdf_refxform_node,
+ pdf_ximage_code,
+ pdf_refximage_node,
+ pdf_annot_node,
+ pdf_start_link_node,
+ pdf_end_link_node,
+ pdf_outline_code,
+ pdf_dest_node,
+ pdf_thread_node, /* 20 */
+ pdf_start_thread_node,
+ pdf_end_thread_node,
+ pdf_save_pos_node,
+ pdf_thread_data_node,
+ pdf_link_data_node,
+ pdf_names_code,
+ pdf_font_attr_code,
+ pdf_include_chars_code,
+ pdf_map_file_code,
+ pdf_map_line_code, /* 30 */
+ pdf_trailer_code,
+ pdf_font_expand_code,
+ set_random_seed_code,
+ pdf_glyph_to_unicode_code,
+ late_lua_node, /* 35 */
+ close_lua_node,
+ save_cat_code_table_code,
+ init_cat_code_table_code,
+ pdf_colorstack_node,
+ pdf_setmatrix_node, /* 40 */
+ pdf_save_node,
+ pdf_restore_node,
+ cancel_boundary_node,
+ user_defined_node /* 44 */ } whatsit_types ;
+
+#define pdf_info_code pdf_thread_data_node
+#define pdf_catalog_code pdf_link_data_node
+
+
+#define GLYPH_CHARACTER (1 << 0)
+#define GLYPH_LIGATURE (1 << 1)
+#define GLYPH_GHOST (1 << 2)
+#define GLYPH_LEFT (1 << 3)
+#define GLYPH_RIGHT (1 << 4)
+
+#define is_character(p) ((subtype(p)) & GLYPH_CHARACTER)
+#define is_ligature(p) ((subtype(p)) & GLYPH_LIGATURE )
+#define is_ghost(p) ((subtype(p)) & GLYPH_GHOST )
+
+#define is_simple_character(p) (is_character(p) && !is_ligature(p) && !is_ghost(p))
+
+#define is_leftboundary(p) (is_ligature(p) && ((subtype(p)) & GLYPH_LEFT ))
+#define is_rightboundary(p) (is_ligature(p) && ((subtype(p)) & GLYPH_RIGHT ))
+#define is_leftghost(p) (is_ghost(p) && ((subtype(p)) & GLYPH_LEFT ))
+#define is_rightghost(p) (is_ghost(p) && ((subtype(p)) & GLYPH_RIGHT ))
+
+#define set_is_glyph(p) subtype(p) &= ~GLYPH_CHARACTER
+#define set_is_character(p) subtype(p) |= GLYPH_CHARACTER
+#define set_is_ligature(p) subtype(p) |= GLYPH_LIGATURE
+#define set_is_ghost(p) subtype(p) |= GLYPH_GHOST
+
+#define set_to_glyph(p) subtype(p) = (subtype(p) & 0xFF00)
+#define set_to_character(p) subtype(p) = (subtype(p) & 0xFF00) | GLYPH_CHARACTER
+#define set_to_ligature(p) subtype(p) = (subtype(p) & 0xFF00) | GLYPH_LIGATURE
+#define set_to_ghost(p) subtype(p) = (subtype(p) & 0xFF00) | GLYPH_GHOST
+
+#define set_is_leftboundary(p) { set_to_ligature(p); subtype(p) |= GLYPH_LEFT; }
+#define set_is_rightboundary(p) { set_to_ligature(p); subtype(p) |= GLYPH_RIGHT; }
+#define set_is_leftghost(p) { set_to_ghost(p); subtype(p) |= GLYPH_LEFT; }
+#define set_is_rightghost(p) { set_to_ghost(p); subtype(p) |= GLYPH_RIGHT; }
+
+
+#define special_node_size 3
+
+#define dir_node_size 4
+#define dir_dir(a) vinfo((a)+2)
+#define dir_level(a) vlink((a)+2)
+#define dir_dvi_ptr(a) vinfo((a)+3)
+#define dir_dvi_h(a) vlink((a)+3)
+
+#define write_node_size 3
+#define close_node_size 3
+#define write_tokens(a) vlink(a+2)
+#define write_stream(a) vinfo(a+2)
+
+#define open_node_size 4
+#define open_name(a) vlink((a)+2)
+#define open_area(a) vinfo((a)+3)
+#define open_ext(a) vlink((a)+3)
+
+#define late_lua_data(a) vlink((a)+2)
+#define late_lua_reg(a) vinfo((a)+2)
+
+#define local_par_size 6
+
+#define local_pen_inter(a) vinfo((a)+2)
+#define local_pen_broken(a) vlink((a)+2)
+#define local_box_left(a) vlink((a)+3)
+#define local_box_left_width(a) vinfo((a)+3)
+#define local_box_right(a) vlink((a)+4)
+#define local_box_right_width(a) vinfo((a)+4)
+#define local_par_dir(a) vinfo((a)+5)
+
+
+#define pdf_literal_data(a) vlink(a+2)
+#define pdf_literal_mode(a) vinfo(a+2)
+
+#define pdf_refobj_node_size 3
+
+#define pdf_obj_objnum(a) vinfo((a) + 2)
+
+#define pdf_refxform_node_size 6
+#define pdf_refximage_node_size 6
+#define pdf_annot_node_size 8
+#define pdf_dest_node_size 8
+#define pdf_thread_node_size 8
+
+#define pdf_width(a) varmem[(a) + 2].cint
+#define pdf_height(a) varmem[(a) + 3].cint
+#define pdf_depth(a) varmem[(a) + 4].cint
+
+#define pdf_ximage_objnum(a) vinfo((a) + 5) /* this will be removed soon */
+#define pdf_ximage_ref(a) vinfo((a) + 5)
+#define pdf_xform_objnum(a) vinfo((a) + 5)
+
+#define pdf_annot_data(a) vinfo((a) + 6)
+#define pdf_link_attr(a) vinfo((a) + 6)
+#define pdf_link_action(a) vlink((a) + 6)
+#define pdf_annot_objnum(a) varmem[(a) + 7].cint
+#define pdf_link_objnum(a) varmem[(a) + 7].cint
+
+#define pdf_dest_type(a) type((a) + 6)
+#define pdf_dest_named_id(a) subtype((a) + 6)
+#define pdf_dest_id(a) vlink((a) + 6)
+#define pdf_dest_xyz_zoom(a) vinfo((a) + 7)
+#define pdf_dest_objnum(a) vlink((a) + 7)
+
+#define pdf_thread_named_id(a) subtype((a) + 6)
+#define pdf_thread_id(a) vlink((a) + 6)
+#define pdf_thread_attr(a) vinfo((a) + 7)
+
+#define pdf_end_link_node_size 3
+#define pdf_end_thread_node_size 3
+#define pdf_save_pos_node_size 3
+
+#define pdf_colorstack_node_size 4
+#define pdf_setmatrix_node_size 3
+
+#define pdf_colorstack_stack(a) vlink((a)+2)
+#define pdf_colorstack_cmd(a) vinfo((a)+2)
+#define pdf_colorstack_data(a) vlink((a)+3)
+#define pdf_setmatrix_data(a) vlink((a)+2)
+
+#define pdf_save_node_size 3
+#define pdf_restore_node_size 3
+
+typedef enum {
+ colorstack_set=0,
+ colorstack_push,
+ colorstack_pop,
+ colorstack_current } colorstack_commands;
+
+#define colorstack_data colorstack_push /* last value where data field is set */
+
+#define user_defined_node_size 4
+#define user_node_type(a) vinfo((a)+2)
+#define user_node_id(a) vlink((a)+2)
+#define user_node_value(a) vinfo((a)+3)
+
+#define cancel_boundary_size 3
+
+typedef enum {
+ exactly=0, /*a box dimension is pre-specified*/
+ additional, /*a box dimension is increased from the natural one*/
+ cal_expand_ratio, /* calculate amount for font expansion after breaking
+ paragraph into lines*/
+ subst_ex_font /* substitute fonts */
+} hpack_subtypes;
+
+#define active_node_size 4 /*number of words in extended active nodes*/
+#define fitness subtype /*|very_loose_fit..tight_fit| on final line for this break*/
+#define break_node(a) vlink((a)+1) /*pointer to the corresponding passive node */
+#define line_number(a) vinfo((a)+1) /*line that begins at this breakpoint*/
+#define total_demerits(a) varmem[(a)+2].cint /* the quantity that \TeX\ minimizes*/
+#define active_short(a) vinfo(a+3) /* |shortfall| of this line */
+#define active_glue(a) vlink(a+3) /*corresponding glue stretch or shrink*/
+
+#define passive_node_size 7
+#define cur_break(a) vlink((a)+1) /*in passive node, points to position of this breakpoint*/
+#define prev_break(a) vinfo((a)+1) /*points to passive node that should precede this one */
+#define passive_pen_inter(a) vinfo((a)+2)
+#define passive_pen_broken(a) vlink((a)+2)
+#define passive_left_box(a) vlink((a)+3)
+#define passive_left_box_width(a) vinfo((a)+3)
+#define passive_last_left_box(a) vlink((a)+4)
+#define passive_last_left_box_width(a) vinfo((a)+4)
+#define passive_right_box(a) vlink((a)+5)
+#define passive_right_box_width(a) vinfo((a)+5)
+#define serial(a) vlink((a)+6) /* serial number for symbolic identification*/
+
+#define delta_node_size 10 /* 8 fields, stored in a+1..9 */
+
+#define couple_nodes(a,b) {assert(b!=null);vlink(a)=b;alink(b)=a;}
+#define try_couple_nodes(a,b) if (b==null) vlink(a)=b; else {couple_nodes(a,b);}
+#define uncouple_node(a) {assert(a!=null);vlink(a)=null;alink(a)=null;}
+
+#define cache_disabled max_halfword
+
+extern void delete_attribute_ref(halfword b) ;
+extern void build_attribute_list(halfword b) ;
+
+extern int unset_attribute(halfword n, int c, int w);
+extern void set_attribute(halfword n, int c, int w);
+extern int has_attribute(halfword n, int c, int w);
+
+extern halfword new_span_node (halfword n, int c, scaled w);
+extern halfword string_to_pseudo(integer l,integer pool_ptr, integer nl);
+
+/* TH: these two defines still need checking. The node ordering in luatex is not
+ quite the same as in tex82 */
+
+#define precedes_break(a) (type((a))<math_node && (type(a)!=whatsit_node || subtype(a)!=dir_node))
+#define non_discardable(a) (type((a))<math_node)
+
+/* from luanode.c */
+
+typedef struct _node_info {
+ int id;
+ int size;
+ char **fields;
+ char *name;
+} node_info;
+
+extern node_info node_data[];
+extern node_info whatsit_node_data[];
+extern halfword new_node(int i, int j);
+extern void flush_node_list(halfword);
+extern void flush_node(halfword);
+extern halfword copy_node_list(halfword);
+extern halfword copy_node(halfword);
+extern void check_node(halfword);
+extern void check_node_mem (void);
+extern void fix_node_list (halfword);
+extern int fix_node_lists;
+extern char *sprint_node_mem_usage (void) ;
+extern halfword raw_glyph_node(void) ;
+extern halfword new_glyph_node(void);
+extern int valid_node(halfword);
+
+#define unity 0x10000
+typedef enum {
+ normal_g=0,
+ sfi,
+ fil,
+ fill,
+ filll } glue_orders;
+
+#define zero_glue 0
+#define sfi_glue zero_glue+glue_spec_size
+#define fil_glue sfi_glue+glue_spec_size
+#define fill_glue fil_glue+glue_spec_size
+#define ss_glue fill_glue+glue_spec_size
+#define fil_neg_glue ss_glue+glue_spec_size
+#define page_ins_head fil_neg_glue+glue_spec_size
+#define contrib_head page_ins_head+temp_node_size
+#define page_head contrib_head+temp_node_size
+#define temp_head page_head+temp_node_size
+#define hold_head temp_head+temp_node_size
+#define adjust_head hold_head+temp_node_size
+#define pre_adjust_head adjust_head+temp_node_size
+#define active pre_adjust_head+temp_node_size
+#define align_head active+active_node_size
+#define end_span align_head+temp_node_size
+#define begin_point end_span+glyph_node_size
+#define end_point begin_point+glyph_node_size
+
+#endif
diff --git a/Build/source/texk/web2c/luatexdir/pdftosrc.1 b/Build/source/texk/web2c/luatexdir/pdftosrc.1
new file mode 100644
index 00000000000..3ee4b680d6f
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/pdftosrc.1
@@ -0,0 +1,219 @@
+.\" Process this file with
+.\" groff -man -Tascii pdftosrc.1
+.\"
+.\" $Id$
+.\"
+.TH pdftosrc 1 "3 November 2005" "User Manuals"
+.SH NAME
+pdftosrc \- extract source file or stream from PDF file
+.SH SYNOPSIS
+.B pdftosrc
+.I PDF-file
+.R [
+.I stream-object-number
+.R ]
+.SH DESCRIPTION
+If only
+.I PDF-file
+is given as argument,
+.B pdftosrc
+extracts the embedded source file
+from the first found stream object
+with /Type /SourceFile within the
+.I PDF-file
+and writes it to a file with the name /SourceName
+as defined in that PDF stream object
+(see application example below).
+
+If both
+.I PDF-file
+and
+.I stream-object-number
+are given as arguments,
+.B pdftosrc
+extracts and uncompresses the PDF stream of the object
+given by its
+.I stream-object-number
+from the
+.I PDF-file
+and writes it to a file named
+.IR PDF-file . stream-object-number
+with the ending
+.I .pdf
+or
+.I .PDF
+stripped from the original
+.I PDF-file
+name.
+
+In either case
+an existing file with the output file name will be overwritten.
+.SH OPTIONS
+None.
+.SH FILES
+Just the executable
+.BR pdftosrc .
+.SH ENVIRONMENT
+None.
+.SH DIAGNOSTICS
+At success the exit code of
+.B pdftosrc
+is 0, else 1.
+
+All messages go to stderr.
+At program invocation,
+.B pdftosrc
+issues the current version number of the program
+.BR xpdf ,
+on which
+.B pdftosrc
+is based:
+
+.RS
+pdftosrc version 3.00
+
+.RE
+When
+.B pdftosrc
+was successful with the output file writing,
+one of the following messages will be issued:
+
+.RS
+Source file extracted to
+.I source-file-name
+
+.RE
+or
+
+.RS
+Stream object extracted to
+.IR PDF-file . stream-object-number
+
+.RE
+
+.RE
+When the object given by the
+.I stream-object-number
+does not contain a stream,
+.B pdftosrc
+issues the following error message:
+
+.RS
+Not a Stream object
+
+.RE
+When the
+.I PDF-file
+can't be opened, the error message is:
+
+.RS
+Error: Couldn't open file
+.RI ' PDF-file '.
+
+.RE
+When
+.B pdftosrc
+encounters an invalid PDF file,
+the error message (several lines) is:
+
+.RS
+Error: May not be a PDF file (continuing anyway)
+.RE
+.RS
+(more lines)
+.RE
+.RS
+Invalid PDF file
+
+.RE
+There are also more error messages from
+.B pdftosrc
+for various kinds of broken PDF files.
+.SH NOTES
+An embedded source file will be written out unchanged,
+i. e. it will not be uncompressed in this process.
+
+Only the stream of the object will be written,
+i. e. not the dictionary of that object.
+
+Knowing which
+.I stream-object-number
+to query requires information about the PDF file
+that has to be gained elsewhere,
+e. g. by looking into the PDF file with an editor.
+
+The stream extraction capabilities of
+.B pdftosrc
+(e. g. regarding understood PDF versions and filter types)
+follow the capabilities of the underlying
+.B xpdf
+program version.
+
+Currently the generation number of the stream object
+is not supported.
+The default value 0 (zero) is taken.
+
+The wording
+.I stream-object-number
+has nothing to do with the `object streams' introduced
+by the Adobe PDF Reference,
+5th edition, version 1.6.
+.SH EXAMPLES
+When using pdftex or pdfetex,
+a source file can be embedded into some
+.I PDF-file
+by using pdftex primitives,
+as illustrated by the following example:
+
+\\immediate\\pdfobj
+.RE
+ stream attr {/Type /SourceFile /SourceName (myfile.zip)}
+.RS
+.RE
+ file{myfile.zip}
+.RS
+.RE
+\\pdfcatalog{/SourceObject \\the\\pdflastobj\\space 0 R}
+
+Then this zip file can be extracted from the
+.I PDF-file
+by calling
+.B pdftosrc
+.IR PDF-file .
+.SH BUGS
+Not all embedded source files will be extracted,
+only the first found one.
+
+Email bug reports to
+.B pdftex@tug.org.
+.SH SEE ALSO
+.BR xpdf (1),
+.BR pdfimages (1),
+.BR pdftotext (1),
+.BR pdftex (1),
+.BR pdfetex (1).
+.SH AUTHORS
+.B pdftosrc
+written by Han The Thanh, using
+.B xpdf
+functionality from Derek Noonburg.
+
+Man page written by Hartmut Henkel.
+.SH COPYRIGHT
+Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
diff --git a/Build/source/texk/web2c/luatexdir/pdftosrc.cc b/Build/source/texk/web2c/luatexdir/pdftosrc.cc
new file mode 100644
index 00000000000..64f1a3174bc
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/pdftosrc.cc
@@ -0,0 +1,178 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+#include <stdlib.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <aconf.h>
+#include <assert.h>
+#include <GString.h>
+#include <gmem.h>
+#include <gfile.h>
+#include "Object.h"
+#include "Stream.h"
+#include "Array.h"
+#include "Dict.h"
+#include "XRef.h"
+#include "Catalog.h"
+#include "Page.h"
+#include "GfxFont.h"
+#include "PDFDoc.h"
+#include "GlobalParams.h"
+#include "Error.h"
+
+static XRef *xref = 0;
+
+int main(int argc, char *argv[])
+{
+ char *p, buf[1024];
+ PDFDoc *doc;
+ GString *fileName;
+ Stream *s;
+ Object srcStream, srcName, catalogDict;
+ FILE *outfile;
+ char *outname;
+ int objnum = 0, objgen = 0;
+ bool extract_xref_table = false;
+ int c;
+ fprintf(stderr, "pdftosrc version %s\n", xpdfVersion);
+ if (argc < 2) {
+ fprintf(stderr,
+ "Usage: pdftosrc <PDF-file> [<stream-object-number>]\n");
+ exit(1);
+ }
+ fileName = new GString(argv[1]);
+ globalParams = new GlobalParams();
+ doc = new PDFDoc(fileName);
+ if (!doc->isOk()) {
+ fprintf(stderr, "Invalid PDF file\n");
+ exit(1);
+ }
+ if (argc >= 3) {
+ objnum = atoi(argv[2]);
+ if (argc >= 4)
+ objgen = atoi(argv[3]);
+ }
+ xref = doc->getXRef();
+ catalogDict.initNull();
+ xref->getCatalog(&catalogDict);
+ if (!catalogDict.isDict("Catalog")) {
+ fprintf(stderr, "No Catalog found\n");
+ exit(1);
+ }
+ srcStream.initNull();
+ if (objnum == 0) {
+ catalogDict.dictLookup("SourceObject", &srcStream);
+ if (!srcStream.isStream("SourceFile")) {
+ fprintf(stderr, "No SourceObject found\n");
+ exit(1);
+ }
+ srcName.initNull();
+ srcStream.getStream()->getDict()->lookup("SourceName", &srcName);
+ if (!srcName.isString()) {
+ fprintf(stderr, "No SourceName found\n");
+ exit(1);
+ }
+ outname = srcName.getString()->getCString();
+ // We cannot free srcName, as objname shares its string.
+ // srcName.free();
+ } else if (objnum > 0) {
+ xref->fetch(objnum, objgen, &srcStream);
+ if (!srcStream.isStream()) {
+ fprintf(stderr, "Not a Stream object\n");
+ exit(1);
+ }
+ sprintf(buf, "%s", fileName->getCString());
+ if ((p = strrchr(buf, '.')) == 0)
+ p = strchr(buf, 0);
+ if (objgen == 0)
+ sprintf(p, ".%i", objnum);
+ else
+ sprintf(p, ".%i+%i", objnum, objgen);
+ outname = buf;
+ } else { // objnum < 0 means we are extracting the XRef table
+ extract_xref_table = true;
+ sprintf(buf, "%s", fileName->getCString());
+ if ((p = strrchr(buf, '.')) == 0)
+ p = strchr(buf, 0);
+ sprintf(p, ".xref");
+ outname = buf;
+ }
+ if (!(outfile = fopen(outname, "wb"))) {
+ fprintf(stderr, "Cannot open file \"%s\" for writing\n", outname);
+ exit(1);
+ }
+ if (extract_xref_table) {
+ int size = xref->getSize();
+ int i;
+ for (i = 0; i < size; i++) {
+ if (xref->getEntry(i)->offset == 0xffffffff)
+ break;
+ }
+ size = i;
+ fprintf(outfile, "xref\n");
+ fprintf(outfile, "0 %i\n", size);
+ for (i = 0; i < size; i++) {
+ XRefEntry *e = xref->getEntry(i);
+ if (e->type != xrefEntryCompressed)
+ fprintf(outfile, "%.10lu %.5i %s\n",
+ (long unsigned) e->offset, e->gen,
+ (e->type == xrefEntryFree ? "f" : "n"));
+ else { // e->offset is the object number of the object stream
+ // e->gen is the local index inside that object stream
+ //int objStrOffset = xref->getEntry(e->offset)->offset;
+ Object tmpObj;
+
+ xref->fetch(i, e->gen, &tmpObj); // to ensure xref->objStr is set
+ ObjectStream *objStr = xref->getObjStr();
+ assert(objStr != NULL);
+ int *localOffsets = objStr->getOffsets();
+ assert(localOffsets != NULL);
+// fprintf(outfile, "%0.10lu %i n\n",
+// (long unsigned) (objStrOffset), e->gen);
+ fprintf(outfile, "%.10lu 00000 n\n",
+ (long unsigned) (objStr->getFirstOffset() +
+ localOffsets[e->gen]));
+// (long unsigned) (objStrOffset + objStr->getStart() + localOffsets[e->gen]));
+ tmpObj.free();
+ }
+ }
+ } else {
+ s = srcStream.getStream();
+ s->reset();
+ while ((c = s->getChar()) != EOF)
+ fputc(c, outfile);
+ srcStream.free();
+ }
+ if (objnum == 0)
+ fprintf(stderr, "Source file extracted to %s\n", outname);
+ else if (objnum > 0)
+ fprintf(stderr, "Stream object extracted to %s\n", outname);
+ else
+ fprintf(stderr, "Cross-reference table extracted to %s\n", outname);
+ fclose(outfile);
+ catalogDict.free();
+ delete doc;
+ delete globalParams;
+}
diff --git a/Build/source/texk/web2c/luatexdir/pdftosrc.rc b/Build/source/texk/web2c/luatexdir/pdftosrc.rc
new file mode 100644
index 00000000000..6929fbade24
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/pdftosrc.rc
@@ -0,0 +1,35 @@
+/* pdftosrc.rc: pdftosrc resources -*- C++ -*-
+
+ Copyright (C) 1996-2003 Fabrice Popineau <fabrice.popineau@supelec.fr>
+
+ This file is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published
+ by the Free Software Foundation; either version 2, or (at your
+ option) any later version.
+
+ This file is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this file; if not, write to the Free Software
+ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+ USA. */
+
+#include <texlive-version.h>
+
+#define VER_FILEVERSION TEXLIVE_MAJOR_VERSION,TEXLIVE_MINOR_VERSION,TEXLIVE_BETA_NUMBER,TEXLIVE_ALPHA_NUMBER
+#define VER_FILEVERSION_STR TEXLIVE_PRODUCTVERSION_STR " pdftosrc 2.01"
+
+#define VER_INTERNALNAME_STR "pdftosrc"
+#define VER_ORIGINALFILENAME_STR "pdftosrc.exe"
+
+#define VER_FILEDESCRIPTION_STR "PDF Source Extractor"
+
+#define VER_COMPANYNAME_STR ""
+#define VER_LEGALCOPYRIGHT_STR ""
+
+#include <texlive.version>
+
+/* pdftosrc.rc ends here */
diff --git a/Build/source/texk/web2c/luatexdir/ptexlib.h b/Build/source/texk/web2c/luatexdir/ptexlib.h
new file mode 100644
index 00000000000..aad25eb4ab2
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/ptexlib.h
@@ -0,0 +1,615 @@
+/*
+ Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of luatex.
+
+luatex is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+luatex is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with luatex; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+#ifndef LUATEXLIB
+# define LUATEXLIB
+
+/* WEB2C macros and prototypes */
+# if !defined(LUATEXCOERCE)
+# ifdef luatex
+# undef luatex /* to avoid warning about redefining luatex in luatexd.h */
+# endif /* luatex */
+# define EXTERN extern
+# include "luatexd.h"
+# endif
+
+/* pdftexlib macros */
+# include "ptexmac.h"
+
+# include "avlstuff.h"
+# include "image/image.h"
+
+# include "openbsd-compat.h"
+
+/* pdftexlib type declarations */
+typedef struct {
+ const char *pdfname;
+ const char *t1name;
+ boolean valid;
+} key_entry;
+
+struct _subfont_entry;
+typedef struct _subfont_entry subfont_entry;
+
+struct _subfont_entry {
+ char *infix; /* infix for this subfont, eg "01" */
+ long charcodes[256]; /* the mapping for this subfont as read from sfd */
+ subfont_entry *next;
+};
+
+typedef struct {
+ char *name; /* sfd name, eg "Unicode" */
+ subfont_entry *subfont; /* linked list of subfonts */
+} sfd_entry;
+
+typedef struct {
+ integer fe_objnum; /* object number */
+ char *name; /* encoding file name */
+ char **glyph_names; /* array of glyph names */
+ struct avl_table *tx_tree; /* tree of encoding positions marked as used by TeX */
+} fe_entry;
+
+typedef struct {
+ char *name; /* glyph name */
+ long code; /* -1 = undefined; -2 = multiple codes, stored
+ as string in unicode_seq; otherwise unicode value */
+ char *unicode_seq; /* multiple unicode sequence */
+} glyph_unicode_entry;
+
+typedef struct {
+ /* parameters scanned from the map file: */
+ char *tfm_name; /* TFM file name (1st field in map line) */
+ char *sfd_name; /* subfont directory name, like @sfd_name@ */
+ char *ps_name; /* PostScript name (optional 2nd field in map line) */
+ integer fd_flags; /* font descriptor /Flags (PDF Ref. section 5.7.1) */
+ integer slant; /* SlantFont */
+ integer extend; /* ExtendFont */
+ char *encname; /* encoding file name */
+ char *ff_name; /* font file name */
+ unsigned short type; /* various flags */
+ short pid; /* Pid for truetype fonts */
+ short eid; /* Eid for truetype fonts */
+ /* parameters NOT scanned from the map file: */
+ subfont_entry *subfont; /* subfont mapping */
+ unsigned short links; /* link flags from tfm_tree and ps_tree */
+ boolean in_use; /* true if this structure has been referenced already */
+} fm_entry;
+
+typedef struct glw_entry_ { /* subset glyphs for inclusion in CID-based fonts */
+ unsigned short id; /* glyph CID */
+ unsigned short wd; /* glyph width in 1/1000 em parts */
+} glw_entry;
+
+
+/**********************************************************************/
+
+typedef struct {
+ int val; /* value */
+ boolean set; /* true if parameter has been set */
+} intparm;
+
+typedef struct fd_entry_ {
+ integer fd_objnum; /* object number of the font descriptor object */
+ char *fontname; /* /FontName (without subset tag) */
+ char *subset_tag; /* 6-character subset tag */
+ boolean ff_found;
+ integer ff_objnum; /* object number of the font program stream */
+ integer fn_objnum; /* font name object number (embedded PDF) */
+ boolean all_glyphs; /* embed all glyphs? */
+ boolean write_ttf_glyph_names;
+ intparm font_dim[FONT_KEYS_NUM];
+ fe_entry *fe; /* pointer to encoding structure */
+ char **builtin_glyph_names; /* builtin encoding as read from the Type1 font file */
+ fm_entry *fm; /* pointer to font map structure */
+ struct avl_table *tx_tree; /* tree of non-reencoded TeX characters marked as used */
+ struct avl_table *gl_tree; /* tree of all marked glyphs */
+} fd_entry;
+
+typedef struct fo_entry_ {
+ integer fo_objnum; /* object number of the font dictionary */
+ internalfontnumber tex_font; /* needed only for \pdffontattr{} */
+ fm_entry *fm; /* pointer to font map structure for this font dictionary */
+ fd_entry *fd; /* pointer to /FontDescriptor object structure */
+ fe_entry *fe; /* pointer to encoding structure */
+ integer cw_objnum; /* object number of the font program object */
+ integer first_char; /* first character used in this font */
+ integer last_char; /* last character used in this font */
+ struct avl_table *tx_tree; /* tree of non-reencoded TeX characters marked as used */
+ integer tounicode_objnum; /* object number of ToUnicode */
+} fo_entry;
+
+/**********************************************************************/
+
+typedef struct {
+ char *ff_name; /* base name of font file */
+ char *ff_path; /* full path to font file */
+} ff_entry;
+
+typedef short shalfword;
+typedef struct {
+ integer charcode, cwidth, cheight, xoff, yoff, xescape, rastersize;
+ halfword *raster;
+} chardesc;
+
+/* pdftexlib variable declarations */
+extern boolean true_dimen;
+extern char **t1_glyph_names, *t1_builtin_glyph_names[];
+extern char *cur_file_name;
+extern const char notdef[];
+extern integer t1_length1, t1_length2, t1_length3;
+extern integer ttf_length;
+extern strnumber last_tex_string;
+extern size_t last_ptr_index;
+
+/* loadpool.c */
+
+int loadpoolstrings(integer spare_size);
+
+/* pdftexlib function prototypes */
+
+/* epdf.c */
+extern integer get_fontfile_num(int);
+extern integer get_fontname_num(int);
+extern void epdf_free(void);
+
+/* mapfile.c */
+extern fm_entry *lookup_fontmap(char *);
+extern boolean hasfmentry(internalfontnumber);
+extern void fm_free(void);
+extern void fm_read_info(void);
+extern ff_entry *check_ff_exist(char *, boolean);
+extern void pdfmapfile(integer);
+extern void pdfmapline(integer);
+extern void pdf_init_map_file(string map_name);
+extern fm_entry *new_fm_entry(void);
+extern void delete_fm_entry(fm_entry *);
+extern int avl_do_entry(fm_entry *, int);
+
+/* papersiz.c */
+extern integer myatodim(char **);
+extern integer myatol(char **);
+
+/* pkin.c */
+extern int readchar(boolean, chardesc *);
+
+/* subfont.c */
+extern void sfd_free(void);
+extern boolean handle_subfont_fm(fm_entry *, int);
+
+/* tounicode.c */
+extern void glyph_unicode_free(void);
+extern void def_tounicode(strnumber, strnumber);
+extern integer write_tounicode(char **, char *);
+
+/* utils.c */
+extern boolean str_eq_cstr(strnumber, char *);
+extern char *makecstring(integer);
+extern char *makeclstring(integer, int *);
+extern void print_string(char *j);
+extern void append_string(char *s);
+extern void getcreationdate(void);
+extern void tconfusion(char *s);
+extern void tprint(char *s);
+extern void tprint_nl(char *s);
+extern void tprint_esc(char *s);
+
+# define overflow_string(a,b) { overflow(maketexstring(a),b); flush_str(last_tex_string); }
+
+extern int xfflush(FILE *);
+extern int xgetc(FILE *);
+extern int xputc(int, FILE *);
+extern scaled ext_xn_over_d(scaled, scaled, scaled);
+extern size_t xfwrite(void *, size_t size, size_t nmemb, FILE *);
+extern strnumber get_resname_prefix(void);
+extern strnumber maketexstring(const char *);
+extern strnumber maketexlstring(const char *, size_t);
+extern integer fb_offset(void);
+extern void fb_flush(void);
+extern void fb_putchar(eight_bits b);
+extern void fb_seek(integer);
+extern void libpdffinish(void);
+extern char *makecfilename(strnumber s);
+extern void make_subset_tag(fd_entry *);
+__attribute__ ((format(printf, 1, 2)))
+extern void pdf_printf(const char *, ...);
+extern void pdf_puts(const char *);
+__attribute__ ((noreturn, format(printf, 1, 2)))
+extern void pdftex_fail(const char *, ...);
+__attribute__ ((format(printf, 1, 2)))
+extern void pdftex_warn(const char *, ...);
+extern void set_job_id(int, int, int, int);
+__attribute__ ((format(printf, 1, 2)))
+extern void tex_printf(const char *, ...);
+extern void write_stream_length(integer, integer);
+extern char *convertStringToPDFString(const char *in, int len);
+extern void print_ID(strnumber);
+extern void print_creation_date();
+extern void print_mod_date();
+extern void escapename(poolpointer in);
+extern void escapestring(poolpointer in);
+extern void escapehex(poolpointer in);
+extern void unescapehex(poolpointer in);
+extern void make_pdftex_banner(void);
+extern void init_start_time();
+extern void remove_pdffile(void);
+extern void garbage_warning(void);
+extern void initversionstring(char **versions);
+extern int newcolorstack(integer s, integer literal_mode, boolean pagestart);
+extern int colorstackused();
+extern integer colorstackset(int colstack_no, integer s);
+extern integer colorstackpush(int colstack_no, integer s);
+extern integer colorstackpop(int colstack_no);
+extern integer colorstackcurrent(int colstack_no);
+extern integer colorstackskippagestart(int colstack_no);
+extern void checkpdfsave(int cur_h, int cur_v);
+extern void checkpdfrestore(int cur_h, int cur_v);
+extern void pdfshipoutbegin(boolean shipping_page);
+extern void pdfshipoutend(boolean shipping_page);
+extern void pdfsetmatrix(poolpointer in, scaled cur_h, scaled cur_v);
+extern void matrixtransformpoint(scaled x, scaled y);
+extern void matrixtransformrect(scaled llx, scaled lly, scaled urx, scaled ury);
+extern boolean matrixused();
+extern void matrixrecalculate(scaled urx);
+extern scaled getllx();
+extern scaled getlly();
+extern scaled geturx();
+extern scaled getury();
+
+/* writeenc.c */
+extern fe_entry *get_fe_entry(char *);
+extern void enc_free(void);
+extern void write_fontencodings(void);
+
+/* writefont.c */
+extern void do_pdf_font(integer, internalfontnumber);
+extern fd_entry *lookup_fd_entry(char *, integer, integer);
+extern fd_entry *new_fd_entry(void);
+extern void write_fontstuff();
+
+/* writeimg.c */
+extern boolean check_image_b(integer);
+extern boolean check_image_c(integer);
+extern boolean check_image_i(integer);
+extern boolean is_pdf_image(integer);
+extern integer epdforigx(integer);
+extern integer epdforigy(integer);
+extern integer image_pages(integer);
+extern integer image_index(integer);
+extern integer image_width(integer);
+extern integer image_height(integer);
+extern integer image_depth(integer);
+extern integer image_objnum(integer);
+extern integer image_imgnum(integer);
+extern integer new_image_entry(void);
+extern integer read_image(integer, integer, strnumber, integer, strnumber,
+ strnumber, integer, integer, integer, integer);
+extern void img_free(void);
+extern void update_image_procset(integer);
+extern void write_image(integer);
+extern integer image_colordepth(integer img);
+extern void scale_image(integer);
+extern void set_image_dimensions(integer, integer, integer, integer);
+extern void set_image_index(integer, integer);
+extern void out_image(integer, scaled, scaled);
+
+/* writejbig2.c */
+extern void flush_jbig2_page0_objects();
+
+/* writet1.c */
+extern boolean t1_subset(char *, char *, unsigned char *);
+extern char **load_enc_file(char *);
+extern void writet1(fd_entry *);
+extern void t1_free(void);
+
+/* writet3.c */
+extern void writet3(int, internalfontnumber);
+extern scaled get_pk_char_width(internalfontnumber, scaled);
+
+/* writettf.c */
+extern void writettf(fd_entry *);
+extern void writeotf(fd_entry *);
+extern void ttf_free(void);
+
+/* writezip.c */
+extern void write_zip(boolean);
+extern void zip_free(void);
+
+/* avlstuff.c */
+extern int comp_int_entry(const void *, const void *, void *);
+extern int comp_string_entry(const void *, const void *, void *);
+extern void avl_put_obj(integer, integer);
+extern integer avl_find_obj(integer, integer, integer);
+
+/**********************************************************************/
+static const key_entry font_key[FONT_KEYS_NUM] = {
+ {"Ascent", "Ascender", 1}
+ , {"CapHeight", "CapHeight", 1}
+ , {"Descent", "Descender", 1}
+ , {"ItalicAngle", "ItalicAngle", 1}
+ , {"StemV", "StdVW", 1}
+ , {"XHeight", "XHeight", 1}
+ , {"FontBBox", "FontBBox", 1}
+ , {"", "", 0}
+ , {"", "", 0}
+ , {"", "", 0}
+ , {"FontName", "FontName", 1}
+};
+
+/**********************************************************************/
+
+typedef enum {
+ no_print = 16,
+ term_only = 17,
+ log_only = 18,
+ term_and_log = 19,
+ pseudo = 20,
+ new_string = 21
+} selector_settings;
+
+
+# include "font/texfont.h"
+
+/* language stuff */
+
+typedef struct _lang_variables {
+ int pre_hyphen_char;
+ int post_hyphen_char;
+} lang_variables;
+
+
+# include "hyphen.h"
+
+struct tex_language {
+ HyphenDict *patterns;
+ int exceptions; /* lua registry pointer, should be replaced */
+ int id;
+ int pre_hyphen_char;
+ int post_hyphen_char;
+};
+
+# define MAX_WORD_LEN 256 /* in chars */
+
+extern struct tex_language *new_language(void);
+extern struct tex_language *get_language(int n);
+extern void load_patterns(struct tex_language *lang, unsigned char *buf);
+extern void load_hyphenation(struct tex_language *lang, unsigned char *buf);
+extern int hyphenate_string(struct tex_language *lang, char *w, char **ret);
+
+extern void new_hyphenation(halfword h, halfword t);
+extern void clear_patterns(struct tex_language *lang);
+extern void clear_hyphenation(struct tex_language *lang);
+extern char *clean_hyphenation(char *buffer, char **cleaned);
+extern void hnj_hyphenation(halfword head, halfword tail);
+
+extern void set_pre_hyphen_char(integer lan, integer val);
+extern void set_post_hyphen_char(integer lan, integer val);
+extern integer get_pre_hyphen_char(integer lan);
+extern integer get_post_hyphen_char(integer lan);
+
+extern halfword new_ligkern(halfword head, halfword tail);
+extern halfword handle_ligaturing(halfword head, halfword tail);
+extern halfword handle_kerning(halfword head, halfword tail);
+
+# define push_dir(a) \
+ { dir_tmp=new_dir((a)); \
+ vlink(dir_tmp)=dir_ptr; dir_ptr=dir_tmp; \
+ dir_ptr=dir_tmp; \
+ }
+
+# define push_dir_node(a) \
+ { dir_tmp=new_node(whatsit_node,dir_node); \
+ dir_dir(dir_tmp)=dir_dir((a)); \
+ dir_level(dir_tmp)=dir_level((a)); \
+ dir_dvi_h(dir_tmp)=dir_dvi_h((a)); \
+ dir_dvi_ptr(dir_tmp)=dir_dvi_ptr((a)); \
+ vlink(dir_tmp)=dir_ptr; dir_ptr=dir_tmp; \
+ }
+
+# define pop_dir_node() \
+ { dir_tmp=dir_ptr; \
+ dir_ptr=vlink(dir_tmp); \
+ flush_node(dir_tmp); \
+ }
+
+
+
+# define dir_parallel(a,b) (((a) % 2)==((b) % 2))
+# define dir_orthogonal(a,b) (((a) % 2)!=((b) % 2))
+
+# define is_rotated(a) dir_parallel(dir_secondary[(a)],dir_tertiary[(a)])
+
+void initialize_active(void);
+
+halfword find_protchar_left(halfword l, boolean d);
+halfword find_protchar_right(halfword l, halfword r);
+
+void ext_do_line_break(boolean d,
+ int pretolerance,
+ int tracing_paragraphs,
+ int tolerance,
+ scaled emergency_stretch,
+ int looseness,
+ int hyphen_penalty,
+ int ex_hyphen_penalty,
+ int pdf_adjust_spacing,
+ halfword par_shape_ptr,
+ int adj_demerits,
+ int pdf_protrude_chars,
+ int line_penalty,
+ int last_line_fit,
+ int double_hyphen_demerits,
+ int final_hyphen_demerits,
+ int hang_indent,
+ int hsize,
+ int hang_after,
+ halfword left_skip,
+ halfword right_skip,
+ int pdf_each_line_height,
+ int pdf_each_line_depth,
+ int pdf_first_line_height,
+ int pdf_last_line_depth,
+ halfword inter_line_penalties_ptr,
+ int inter_line_penalty,
+ int club_penalty,
+ halfword club_penalties_ptr,
+ halfword display_widow_penalties_ptr,
+ halfword widow_penalties_ptr,
+ int display_widow_penalty,
+ int widow_penalty,
+ int broken_penalty, halfword final_par_glue);
+
+void ext_post_line_break(boolean d,
+ int right_skip,
+ int left_skip,
+ int pdf_protrude_chars,
+ halfword par_shape_ptr,
+ int pdf_adjust_spacing,
+ int pdf_each_line_height,
+ int pdf_each_line_depth,
+ int pdf_first_line_height,
+ int pdf_last_line_depth,
+ halfword inter_line_penalties_ptr,
+ int inter_line_penalty,
+ int club_penalty,
+ halfword club_penalties_ptr,
+ halfword display_widow_penalties_ptr,
+ halfword widow_penalties_ptr,
+ int display_widow_penalty,
+ int widow_penalty,
+ int broken_penalty,
+ halfword final_par_glue,
+ halfword best_bet,
+ halfword last_special_line,
+ scaled second_width,
+ scaled second_indent,
+ scaled first_width,
+ scaled first_indent, halfword best_line);
+
+halfword lua_hpack_filter(halfword head_node, scaled size, int pack_type,
+ int extrainfo);
+void lua_node_filter(int filterid, int extrainfo, halfword head_node,
+ halfword * tail_node);
+halfword lua_vpack_filter(halfword head_node, scaled size, int pack_type,
+ scaled maxd, int extrainfo);
+void lua_node_filter_s(int filterid, char *extrainfo, halfword head_node,
+ halfword * tail_node);
+
+void load_tex_patterns(int curlang, halfword head);
+void load_tex_hyphenation(int curlang, halfword head);
+
+/* textcodes.c */
+void set_lc_code(integer n, halfword v, quarterword gl);
+halfword get_lc_code(integer n);
+void set_uc_code(integer n, halfword v, quarterword gl);
+halfword get_uc_code(integer n);
+void set_sf_code(integer n, halfword v, quarterword gl);
+halfword get_sf_code(integer n);
+void set_cat_code(integer h, integer n, halfword v, quarterword gl);
+halfword get_cat_code(integer h, integer n);
+void unsave_cat_codes(integer h, quarterword gl);
+int valid_catcode_table(int h);
+void unsave_text_codes(quarterword grouplevel);
+void initialize_text_codes(void);
+void dump_text_codes(void);
+void undump_text_codes(void);
+
+/* mathcodes.c */
+
+void set_math_code(integer n, halfword v, quarterword gl);
+halfword get_math_code(integer n);
+void set_del_code(integer n, halfword v, halfword w, quarterword gl);
+halfword get_del_code_a(integer n);
+halfword get_del_code_b(integer n);
+void unsave_math_codes(quarterword grouplevel);
+void initialize_math_codes(void);
+void dump_math_codes(void);
+void undump_math_codes(void);
+
+/* texlang.c */
+
+void dump_language_data(void);
+void undump_language_data(void);
+char *exception_strings(struct tex_language *lang);
+
+/* llualib.c */
+
+void dump_luac_registers(void);
+void undump_luac_registers(void);
+
+/* ltexlib.c */
+void luacstring_start(int n);
+void luacstring_close(int n);
+int luacstring_detokenized(void);
+int luacstring_defaultcattable(void);
+integer luacstring_cattable(void);
+int luacstring_simple(void);
+int luacstring_penultimate(void);
+int luacstring_input(void);
+
+
+/* luatoken.c */
+void do_get_token_lua(integer callback_id);
+
+/* luanode.c */
+int visible_last_node_type(int n);
+void print_node_mem_stats(int n, int o);
+
+/* writeimg.c */
+integer epdf_orig_y(integer i);
+integer epdf_orig_x(integer i);
+
+/* limglib.c */
+void lua_setximage(integer i);
+
+/* vfovf.c */
+void vf_expand_local_fonts(internal_font_number f);
+internal_font_number letter_space_font(halfword u, internal_font_number f,
+ integer e);
+internal_font_number auto_expand_font(internal_font_number f, integer e);
+str_number expand_font_name(internal_font_number f, integer e);
+void pdf_check_vf_cur_val(void);
+
+/* ltexiolib.c */
+void flush_loggable_info(void);
+
+/* luastuff.c */
+void closelua(int n);
+void luacall(int n, int s);
+void luatokencall(int n, int p);
+
+void tex_error(char *msg, char **hlp);
+
+scaled divide_scaled(scaled s, scaled m, integer dd);
+scaled divide_scaled_n(double s, double m, double d);
+
+/* texpdf.c */
+void pdf_print_char(internal_font_number f, integer c);
+void pdf_print(str_number n);
+void pdf_print_str(str_number n);
+void pdf_print_int(integer n);
+
+/* textoken.c */
+
+void get_next(void);
+void get_token_lua(void);
+
+#endif /* PDFTEXLIB */
diff --git a/Build/source/texk/web2c/luatexdir/ptexmac.h b/Build/source/texk/web2c/luatexdir/ptexmac.h
new file mode 100644
index 00000000000..2f795ce3e71
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/ptexmac.h
@@ -0,0 +1,236 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+#ifndef PDFTEXMAC
+# define PDFTEXMAC
+
+/* Not all systems define it. */
+# ifndef M_PI
+# define M_PI 3.14159265358979323846
+ /* pi */
+# define M_PI_2 1.5707963267948966192E0
+ /*Hex 2^ 0 * 1.921FB54442D18 */
+# define M_PI_4 7.8539816339744830962E-1
+ /*Hex 2^-1 * 1.921FB54442D18 */
+# endif
+
+# ifdef WIN32
+/* Why relying on gmalloc() ???*/
+# define gmalloc(n) xmalloc(n)
+# define gfree(p) free(p)
+# define inline __inline
+# define srandom(n) srand(n)
+# define random() rand()
+# endif
+
+/* Pascal WEB macros */
+# define maxinteger 0x7FFFFFFF
+# define maxdimen 0x3FFFFFFF
+
+# define objinfo(n) objtab[n].int0
+
+# define pdfroom(n) do { \
+ if ((unsigned)(n + pdf_ptr) > (unsigned)pdf_buf_size) { \
+ if (pdf_os_mode) \
+ zpdf_os_get_os_buf(n); \
+ else { \
+ if ((unsigned)(n) > (unsigned)pdf_buf_size) \
+ pdftex_fail("PDF output buffer overflowed"); \
+ else \
+ pdf_flush(); \
+ } \
+ } \
+} while (0)
+
+# define pdfout(c) do { \
+ pdfroom(1); \
+ pdf_buf[pdf_ptr++] = c; \
+} while (0)
+
+# define pdfoffset() (pdf_gone + pdf_ptr)
+
+# define MAX_CHAR_CODE 255
+# define PRINTF_BUF_SIZE 1024
+# define MAX_CSTRING_LEN 1024 * 1024
+# define MAX_PSTRING_LEN 1024
+# define SMALL_BUF_SIZE 256
+# define SMALL_ARRAY_SIZE 256
+# define FONTNAME_BUF_SIZE 128
+ /* a PDF name can be maximum 127 chars long */
+
+# define pdftex_debug tex_printf
+
+extern void check_buffer_overflow(int wsize);
+extern void check_pool_overflow (int wsize);
+
+# define check_buf(size, buf_size) \
+ if ((unsigned)(size) > (unsigned)(buf_size)) \
+ pdftex_fail("buffer overflow: %d > %d at file %s, line %d", \
+ (int)(size), (int)(buf_size), __FILE__, __LINE__ )
+
+# define append_char_to_buf(c, p, buf, buf_size) do { \
+ if (c == 9) \
+ c = 32; \
+ if (c == 13 || c == EOF) \
+ c = 10; \
+ if (c != ' ' || (p > buf && p[-1] != 32)) { \
+ check_buf(p - buf + 1, (buf_size)); \
+ *p++ = c; \
+ } \
+} while (0)
+
+# define append_eol(p, buf, buf_size) do { \
+ check_buf(p - buf + 2, (buf_size)); \
+ if (p - buf > 1 && p[-1] != 10) \
+ *p++ = 10; \
+ if (p - buf > 2 && p[-2] == 32) { \
+ p[-2] = 10; \
+ p--; \
+ } \
+ *p = 0; \
+} while (0)
+
+# define remove_eol(p, buf) do { \
+ p = strend(buf) - 1; \
+ if (*p == 10) \
+ *p = 0; \
+} while (0)
+
+# define skip(p, c) if (*p == c) p++
+
+# define alloc_array(T, n, s) do { \
+ if (T##_array == NULL) { \
+ T##_limit = (s); \
+ if ((unsigned)(n) > T##_limit) \
+ T##_limit = (n); \
+ T##_array = xtalloc(T##_limit, T##_entry); \
+ T##_ptr = T##_array; \
+ } \
+ else if ((unsigned)(T##_ptr - T##_array + (n)) > T##_limit) { \
+ last_ptr_index = T##_ptr - T##_array; \
+ T##_limit *= 2; \
+ if ((unsigned)(T##_ptr - T##_array + (n)) > T##_limit) \
+ T##_limit = T##_ptr - T##_array + (n); \
+ xretalloc(T##_array, T##_limit, T##_entry); \
+ T##_ptr = T##_array + last_ptr_index; \
+ } \
+} while (0)
+
+# define is_cfg_comment(c) \
+ (c == 10 || c == '*' || c == '#' || c == ';' || c == '%')
+
+# define define_array(T) \
+T##_entry *T##_ptr, *T##_array = NULL; \
+size_t T##_limit
+
+# define xfree(p) do { if (p != NULL) free(p); p = NULL; } while (0)
+# define strend(s) strchr(s, 0)
+# define xtalloc XTALLOC
+# define xretalloc XRETALLOC
+
+# define ASCENT_CODE 0
+# define CAPHEIGHT_CODE 1
+# define DESCENT_CODE 2
+# define ITALIC_ANGLE_CODE 3
+# define STEMV_CODE 4
+# define XHEIGHT_CODE 5
+# define FONTBBOX1_CODE 6
+# define FONTBBOX2_CODE 7
+# define FONTBBOX3_CODE 8
+# define FONTBBOX4_CODE 9
+# define FONTNAME_CODE 10
+# define GEN_KEY_NUM (XHEIGHT_CODE + 1)
+# define MAX_KEY_CODE (FONTBBOX1_CODE + 1)
+# define INT_KEYS_NUM (FONTBBOX4_CODE + 1)
+# define FONT_KEYS_NUM (FONTNAME_CODE + 1)
+
+# define F_INCLUDED 0x01
+# define F_SUBSETTED 0x02
+# define F_STDT1FONT 0x04
+# define F_SUBFONT 0x08
+# define F_TYPE1 0x10
+# define F_TRUETYPE 0x20
+# define F_OTF 0x40
+# define F_CIDKEYED 0x80
+
+# define set_included(fm) ((fm)->type |= F_INCLUDED)
+# define set_subsetted(fm) ((fm)->type |= F_SUBSETTED)
+# define set_std_t1font(fm) ((fm)->type |= F_STDT1FONT)
+# define set_subfont(fm) ((fm)->type |= F_SUBFONT)
+# define set_type1(fm) ((fm)->type |= F_TYPE1)
+# define set_truetype(fm) ((fm)->type |= F_TRUETYPE)
+# define set_opentype(fm) ((fm)->type |= F_OTF)
+# define set_subfont(fm) ((fm)->type |= F_SUBFONT)
+# define set_cidkeyed(fm) ((fm)->type |= F_CIDKEYED)
+
+# define unset_included(fm) ((fm)->type &= ~F_INCLUDED)
+# define unset_subsetted(fm) ((fm)->type &= ~F_SUBSETTED)
+# define unset_std_t1font(fm)((fm)->type &= ~F_STDT1FONT)
+# define unset_subfont(fm) ((fm)->type &= ~F_SUBFONT)
+# define unset_type1(fm) ((fm)->type &= ~F_TYPE1)
+# define unset_truetype(fm) ((fm)->type &= ~F_TRUETYPE)
+# define unset_opentype(fm) ((fm)->type &= ~F_OTF)
+# define unset_subfont(fm) ((fm)->type &= ~F_SUBFONT)
+# define unset_cidkeyed(fm) ((fm)->type &= ~F_CIDKEYED)
+
+# define is_included(fm) (((fm)->type & F_INCLUDED) != 0)
+# define is_subsetted(fm) (((fm)->type & F_SUBSETTED) != 0)
+# define is_std_t1font(fm) (((fm)->type & F_STDT1FONT) != 0)
+# define is_subfont(fm) (((fm)->type & F_SUBFONT) != 0)
+# define is_type1(fm) (((fm)->type & F_TYPE1) != 0)
+# define is_truetype(fm) (((fm)->type & F_TRUETYPE) != 0)
+# define is_opentype(fm) (((fm)->type & F_OTF) != 0)
+# define is_subfont(fm) (((fm)->type & F_SUBFONT) != 0)
+# define is_cidkeyed(fm) (((fm)->type & F_CIDKEYED) != 0)
+
+# define fm_slant(fm) (fm)->slant
+# define fm_extend(fm) (fm)->extend
+# define fm_fontfile(fm) (fm)->ff_name
+
+# define is_reencoded(fm) ((fm)->encname != NULL)
+# define is_fontfile(fm) (fm_fontfile(fm) != NULL)
+# define is_t1fontfile(fm) (is_fontfile(fm) && is_type1(fm))
+# define is_builtin(fm) (!is_fontfile(fm))
+
+# define LINK_TFM 0x01
+# define LINK_PS 0x02
+# define set_tfmlink(fm) ((fm)->links |= LINK_TFM)
+# define set_pslink(fm) ((fm)->links |= LINK_PS)
+# define unset_tfmlink(fm) ((fm)->links &= ~LINK_TFM)
+# define unset_pslink(fm) ((fm)->links &= ~LINK_PS)
+# define has_tfmlink(fm) ((fm)->links & LINK_TFM)
+# define has_pslink(fm) ((fm)->links & LINK_PS)
+
+
+# define set_cur_file_name(s) \
+ cur_file_name = s; \
+ pack_file_name(maketexstring(cur_file_name), get_nullstr(), get_nullstr())
+
+# define cmp_return(a, b) \
+ if ((a) > (b)) \
+ return 1; \
+ if ((a) < (b)) \
+ return -1
+
+# define str_prefix(s1, s2) (strncmp((s1), (s2), strlen(s2)) == 0)
+
+#endif /* PDFTEXMAC */
diff --git a/Build/source/texk/web2c/luatexdir/svnversion.h b/Build/source/texk/web2c/luatexdir/svnversion.h
new file mode 100644
index 00000000000..9a139c2d294
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/svnversion.h
@@ -0,0 +1,3 @@
+#define BUILD_REVISION "$Revision: 915 $"
+#define BUILD_DATE 20071128
+#define BUILD_TIME 1092554
diff --git a/Build/source/texk/web2c/luatexdir/tex/linebreak.c b/Build/source/texk/web2c/luatexdir/tex/linebreak.c
new file mode 100644
index 00000000000..910d26b9f27
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/tex/linebreak.c
@@ -0,0 +1,2095 @@
+/* $Id: linebreak.c 1102 2008-03-11 09:52:54Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "nodes.h"
+
+/* Glue nodes in a horizontal list that is being paragraphed are not supposed to
+ include ``infinite'' shrinkability; that is why the algorithm maintains
+ four registers for stretching but only one for shrinking. If the user tries to
+ introduce infinite shrinkability, the shrinkability will be reset to finite
+ and an error message will be issued. A boolean variable |no_shrink_error_yet|
+ prevents this error message from appearing more than once per paragraph.
+*/
+
+#define check_shrinkage(a) \
+ if ((shrink_order((a))!=normal)&&(shrink((a))!=0)) \
+ a=finite_shrink((a))
+
+static boolean no_shrink_error_yet; /*have we complained about infinite shrinkage?*/
+
+halfword
+finite_shrink(halfword p) { /* recovers from infinite shrinkage */
+ halfword q; /*new glue specification*/
+ char *hlp[] = {
+ "The paragraph just ended includes some glue that has",
+ "infinite shrinkability, e.g., `\\hskip 0pt minus 1fil'.",
+ "Such glue doesn't belong there---it allows a paragraph",
+ "of any length to fit on one line. But it's safe to proceed,",
+ "since the offensive shrinkability has been made finite.",
+ NULL };
+ if (no_shrink_error_yet) {
+ no_shrink_error_yet=false;
+ tex_error("Infinite glue shrinkage found in a paragraph",hlp);
+ }
+ q=new_spec(p); shrink_order(q)=normal;
+ delete_glue_ref(p);
+ return q;
+}
+
+/* A pointer variable |cur_p| runs through the given horizontal list as we look
+ for breakpoints. This variable is global, since it is used both by |line_break|
+ and by its subprocedure |try_break|.
+
+ Another global variable called |threshold| is used to determine the feasibility
+ of individual lines: breakpoints are feasible if there is a way to reach
+ them without creating lines whose badness exceeds |threshold|. (The
+ badness is compared to |threshold| before penalties are added, so that
+ penalty values do not affect the feasibility of breakpoints, except that
+ no break is allowed when the penalty is 10000 or more.) If |threshold|
+ is 10000 or more, all legal breaks are considered feasible, since the
+ |badness| function specified above never returns a value greater than~10000.
+
+ Up to three passes might be made through the paragraph in an attempt to find at
+ least one set of feasible breakpoints. On the first pass, we have
+ |threshold=pretolerance| and |second_pass=final_pass=false|.
+ If this pass fails to find a
+ feasible solution, |threshold| is set to |tolerance|, |second_pass| is set
+ |true|, and an attempt is made to hyphenate as many words as possible.
+ If that fails too, we add |emergency_stretch| to the background
+ stretchability and set |final_pass=true|.
+*/
+
+static boolean second_pass; /* is this our second attempt to break this paragraph? */
+static boolean final_pass; /*is this our final attempt to break this paragraph? */
+static integer threshold; /* maximum badness on feasible lines */
+
+/* skipable nodes at the margins during character protrusion */
+
+#define cp_skipable(a) ((! is_char_node((a))) && \
+ ((type((a)) == ins_node) \
+ || (type((a)) == mark_node) \
+ || (type((a)) == adjust_node) \
+ || (type((a)) == penalty_node) \
+ || ((type((a)) == whatsit_node) && \
+ (subtype((a)) != pdf_refximage_node) && \
+ (subtype((a)) != pdf_refxform_node)) \
+ /* reference to an image or XObject form */ \
+ || ((type((a)) == disc_node) && \
+ (vlink_pre_break(a) == null) && \
+ (vlink_post_break(a) == null) && \
+ (vlink_no_break(a) == null)) \
+ /* an empty |disc_node| */ \
+ || ((type((a)) == math_node) && \
+ (surround((a)) == 0)) \
+ || ((type((a)) == kern_node) && \
+ ((width((a)) == 0) || \
+ (subtype((a)) == normal))) \
+ || ((type((a)) == glue_node) && \
+ (glue_ptr((a)) == zero_glue)) \
+ || ((type((a)) == hlist_node) && \
+ (width((a)) == 0) && \
+ (height((a)) == 0) && \
+ (depth((a)) == 0) && \
+ (list_ptr((a)) == null)) \
+ ))
+
+/* maximum fill level for |hlist_stack|*/
+#define max_hlist_stack 512 /* maybe good if larger than |2 *
+ max_quarterword|, so that box nesting
+ level would overflow first */
+
+/* stack for |find_protchar_left()| and |find_protchar_right()| */
+static halfword hlist_stack[max_hlist_stack];
+
+/* fill level for |hlist_stack| */
+static short hlist_stack_level = 0;
+
+void push_node(halfword p) {
+ if (hlist_stack_level >= max_hlist_stack)
+ pdf_error("push_node", "stack overflow");
+ hlist_stack[hlist_stack_level++] = p;
+}
+
+halfword pop_node (void) {
+ if (hlist_stack_level <= 0) /* would point to some bug */
+ pdf_error("pop_node", "stack underflow (internal error)");
+ return hlist_stack[--hlist_stack_level];
+}
+
+#define null_font 0
+
+static integer max_stretch_ratio=0; /*maximal stretch ratio of expanded fonts*/
+static integer max_shrink_ratio=0; /*maximal shrink ratio of expanded fonts*/
+static integer cur_font_step=0; /*the current step of expanded fonts*/
+
+
+boolean check_expand_pars(internal_font_number f) {
+ internal_font_number k;
+
+ if ((pdf_font_step(f) == 0) || ((pdf_font_stretch(f) == null_font) &&
+ (pdf_font_shrink(f) == null_font)))
+ return false;
+ if (cur_font_step < 0)
+ cur_font_step = pdf_font_step(f);
+ else if (cur_font_step != pdf_font_step(f))
+ pdf_error("font expansion",
+ "using fonts with different step of expansion in one paragraph is not allowed");
+ k = pdf_font_stretch(f);
+ if( k != null_font) {
+ if (max_stretch_ratio < 0)
+ max_stretch_ratio = pdf_font_expand_ratio(k);
+ else if (max_stretch_ratio != pdf_font_expand_ratio(k))
+ pdf_error("font expansion",
+ "using fonts with different limit of expansion in one paragraph is not allowed");
+ }
+ k = pdf_font_shrink(f);
+ if( k != null_font) {
+ if (max_shrink_ratio < 0)
+ max_shrink_ratio = -pdf_font_expand_ratio(k);
+ else if (max_shrink_ratio != -pdf_font_expand_ratio(k))
+ pdf_error("font expansion",
+ "using fonts with different limit of expansion in one paragraph is not allowed");
+ }
+ return true;
+}
+
+/* searches left to right from list head |l|, returns 1st non-skipable item*/
+/*public*/ halfword find_protchar_left(halfword l, boolean d) {
+ halfword t;
+ boolean run;
+ if ((vlink(l) != null) && (type(l) == hlist_node) && (width(l) == 0)
+ && (height(l) == 0) && (depth(l) == 0) && (list_ptr(l) == null)) {
+ l = vlink(l); /*for paragraph start with \.{\\parindent = 0pt*/
+ } else if (d) {
+ while ((vlink(l) != null) && (!(is_char_node(l) || non_discardable(l)))) {
+ l = vlink(l); /* std.\ discardables at line break, \TeX book, p 95 */
+ }
+ }
+ hlist_stack_level = 0;
+ run = true;
+ do {
+ t = l;
+ while (run && (type(l) == hlist_node) && (list_ptr(l) != null)) {
+ push_node(l);
+ l = list_ptr(l);
+ }
+ while (run && cp_skipable(l)) {
+ while ((vlink(l) == null) && (hlist_stack_level > 0)) {
+ l = pop_node(); /* don't visit this node again */
+ }
+ if (vlink(l) != null)
+ l = vlink(l);
+ else if (hlist_stack_level == 0)
+ run = false;
+ }
+ } while (t != l);
+ return l;
+}
+
+
+/* searches right to left from list tail |r| to head |l|, returns 1st non-skipable item */
+/*public*/ halfword find_protchar_right(halfword l, halfword r) {
+ halfword t;
+ boolean run;
+ if (r == null)
+ return null;
+ hlist_stack_level = 0;
+ run = true;
+ do {
+ t = r;
+ while (run && (type(r) == hlist_node) && (list_ptr(r) != null)) {
+ push_node(l);
+ push_node(r);
+ l = list_ptr(r);
+ r = l;
+ while (vlink(r) != null) {
+ halfword s = r;
+ r = vlink(r);
+ alink(r) = s;
+ }
+ }
+ while (run && cp_skipable(r)) {
+ while ((r == l) && (hlist_stack_level > 0)) {
+ r = pop_node(); /* don't visit this node again */
+ l = pop_node();
+ }
+ if ((r != l) && (r != null) ) {
+ assert(vlink(alink(r))==r);
+ r = alink(r);
+ } else if ((r == l) && (hlist_stack_level == 0))
+ run = false;
+ }
+ } while (t != r);
+ return r;
+}
+
+#define left_pw(a) char_pw((a), left_side)
+#define right_pw(a) char_pw((a), right_side)
+
+#if 0
+/* returns the total width of character protrusion of a line;
+ |cur_break(break_node(q))| and |p| is the leftmost resp. rightmost
+ node in the horizontal list representing the actual line */
+
+scaled total_pw (halfword first_p, halfword q, halfword p) {
+ halfword l, r;
+ l = (break_node(q) == null) ? first_p : cur_break(break_node(q));
+ assert(vlink(alink(p))==p);
+ r = alink(r);
+ /* let's look at the right margin first */
+ if ((p != null) && (type(p) == disc_node) && (vlink(pre_break(p)) != null)) {
+ /* a |disc_node| with non-empty |pre_break|, protrude the last char of |pre_break| */
+ r = vlink(pre_break(p));
+ while (vlink(r) != null)
+ r = vlink(r);
+ } else {
+ r = find_protchar_right(l, r);
+ }
+ /* now the left margin */
+ if ((l != null) && (type(l) == disc_node)) {
+ if (vlink(post_break(l)) != null) {
+ l = vlink(post_break(l)); /* protrude the first char */
+ goto DONE;
+ }
+ }
+ l = find_protchar_left(l, true);
+DONE:
+ return (left_pw(l) + right_pw(r));
+}
+#endif
+
+
+/* When looking for optimal line breaks, \TeX\ creates a ``break node'' for
+ each break that is {\sl feasible}, in the sense that there is a way to end
+ a line at the given place without requiring any line to stretch more than
+ a given tolerance. A break node is characterized by three things: the position
+ of the break (which is a pointer to a |glue_node|, |math_node|, |penalty_node|,
+ or |disc_node|); the ordinal number of the line that will follow this
+ breakpoint; and the fitness classification of the line that has just
+ ended, i.e., |tight_fit|, |decent_fit|, |loose_fit|, or |very_loose_fit|.
+*/
+
+typedef enum {
+ very_loose_fit = 0, /* fitness classification for lines stretching more than
+ their stretchability */
+ loose_fit, /* fitness classification for lines stretching 0.5 to 1.0 of their
+ stretchability */
+ decent_fit, /* fitness classification for all other lines*/
+ tight_fit /* fitness classification for lines shrinking 0.5 to 1.0 of their
+ shrinkability */
+} fitness_value ;
+
+
+/* The algorithm essentially determines the best possible way to achieve
+ each feasible combination of position, line, and fitness. Thus, it answers
+ questions like, ``What is the best way to break the opening part of the
+ paragraph so that the fourth line is a tight line ending at such-and-such
+ a place?'' However, the fact that all lines are to be the same length
+ after a certain point makes it possible to regard all sufficiently large
+ line numbers as equivalent, when the looseness parameter is zero, and this
+ makes it possible for the algorithm to save space and time.
+
+ An ``active node'' and a ``passive node'' are created in |mem| for each
+ feasible breakpoint that needs to be considered. Active nodes are three
+ words long and passive nodes are two words long. We need active nodes only
+ for breakpoints near the place in the paragraph that is currently being
+ examined, so they are recycled within a comparatively short time after
+ they are created.
+*/
+
+/* An active node for a given breakpoint contains six fields:
+
+|vlink| points to the next node in the list of active nodes; the
+last active node has |vlink=active|.
+
+|break_node| points to the passive node associated with this
+breakpoint.
+
+|line_number| is the number of the line that follows this
+breakpoint.
+
+|fitness| is the fitness classification of the line ending at this
+breakpoint.
+
+|type| is either |hyphenated_node| or |unhyphenated_node|, depending on
+whether this breakpoint is a |disc_node|.
+
+|total_demerits| is the minimum possible sum of demerits over all
+lines leading from the beginning of the paragraph to this breakpoint.
+
+The value of |vlink(active)| points to the first active node on a vlinked list
+of all currently active nodes. This list is in order by |line_number|,
+except that nodes with |line_number>easy_line| may be in any order relative
+to each other.
+*/
+
+void
+initialize_active (void) {
+ type(active)=hyphenated_node;
+ line_number(active)=max_halfword;
+ subtype(active)=0; /* the |subtype| is never examined */
+}
+
+/* The passive node for a given breakpoint contains EIGHT fields:
+
+|vlink| points to the passive node created just before this one,
+if any, otherwise it is |null|.
+
+|cur_break| points to the position of this breakpoint in the
+horizontal list for the paragraph being broken.
+
+|prev_break| points to the passive node that should precede this
+one in an optimal path to this breakpoint.
+
+|serial| is equal to |n| if this passive node is the |n|th
+one created during the current pass. (This field is used only when
+printing out detailed statistics about the line-breaking calculations.)
+
+|passive_pen_inter| holds the current \.{\\localinterlinepenalty}
+
+|passive_pen_broken| holds the current \.{\\localbrokenpenalty}
+
+There is a global variable called |passive| that points to the most
+recently created passive node. Another global variable, |printed_node|,
+is used to help print out the paragraph when detailed information about
+the line-breaking computation is being displayed.
+*/
+
+static halfword passive; /* most recent node on passive list */
+static halfword printed_node; /*most recent node that has been printed*/
+static halfword pass_number; /*the number of passive nodes allocated on this pass*/
+
+/*
+@ The active list also contains ``delta'' nodes that help the algorithm
+compute the badness of individual lines. Such nodes appear only between two
+active nodes, and they have |type=delta_node|. If |p| and |r| are active nodes
+and if |q| is a delta node between them, so that |vlink(p)=q| and |vlink(q)=r|,
+then |q| tells the space difference between lines in the horizontal list that
+start after breakpoint |p| and lines that start after breakpoint |r|. In
+other words, if we know the length of the line that starts after |p| and
+ends at our current position, then the corresponding length of the line that
+starts after |r| is obtained by adding the amounts in node~|q|. A delta node
+contains seven scaled numbers, since it must record the net change in glue
+stretchability with respect to all orders of infinity. The natural width
+difference appears in |mem[q+1].sc|; the stretch differences in units of
+pt, sfi, fil, fill, and filll appear in |mem[q+2..q+6].sc|; and the shrink
+difference appears in |mem[q+7].sc|. The |subtype| field of a delta node
+is not used.
+
+Actually, we have two more fields that are used by |pdftex|.
+*/
+
+/* As the algorithm runs, it maintains a set of seven delta-like registers
+for the length of the line following the first active breakpoint to the
+current position in the given hlist. When it makes a pass through the
+active list, it also maintains a similar set of seven registers for the
+length following the active breakpoint of current interest. A third set
+holds the length of an empty line (namely, the sum of \.{\\leftskip} and
+\.{\\rightskip}); and a fourth set is used to create new delta nodes.
+
+When we pass a delta node we want to do operations like
+$$\hbox{\ignorespaces|for
+k:=1 to 7 do cur_active_width[k]:=cur_active_width[k]+mem[q+k].sc|};$$ and we
+want to do this without the overhead of |for| loops. The |do_all_six|
+macro makes such six-tuples convenient.
+*/
+
+#define save_active_width(a) prev_active_width[(a)] = active_width[(a)]
+#define restore_active_width(a) active_width[(a)] = prev_active_width[(a)]
+
+static scaled active_width[10] = {0}; /*distance from first active node to~|cur_p|*/
+static scaled background[10] = {0}; /*length of an ``empty'' line*/
+static scaled break_width[10] = {0}; /*length being computed after current break*/
+
+static boolean auto_breaking; /*make |auto_breaking| accessible out of |line_break|*/
+static boolean try_prev_break; /*force break at the previous legal breakpoint?*/
+static halfword prev_legal; /*the previous legal breakpoint*/
+static halfword rejected_cur_p; /*the last |cur_p| that has been rejected*/
+static boolean before_rejected_cur_p; /*|cur_p| is still before |rejected_cur_p|?*/
+
+/* Let's state the principles of the delta nodes more precisely and concisely,
+ so that the following programs will be less obscure. For each legal
+ breakpoint~|p| in the paragraph, we define two quantities $\alpha(p)$ and
+ $\beta(p)$ such that the length of material in a line from breakpoint~|p|
+ to breakpoint~|q| is $\gamma+\beta(q)-\alpha(p)$, for some fixed $\gamma$.
+ Intuitively, $\alpha(p)$ and $\beta(q)$ are the total length of material from
+ the beginning of the paragraph to a point ``after'' a break at |p| and to a
+ point ``before'' a break at |q|; and $\gamma$ is the width of an empty line,
+ namely the length contributed by \.{\\leftskip} and \.{\\rightskip}.
+
+ Suppose, for example, that the paragraph consists entirely of alternating
+ boxes and glue skips; let the boxes have widths $x_1\ldots x_n$ and
+ let the skips have widths $y_1\ldots y_n$, so that the paragraph can be
+ represented by $x_1y_1\ldots x_ny_n$. Let $p_i$ be the legal breakpoint
+ at $y_i$; then $\alpha(p_i)=x_1+y_1+\cdots+x_i+y_i$, and $\beta(p_i)=
+ x_1+y_1+\cdots+x_i$. To check this, note that the length of material from
+ $p_2$ to $p_5$, say, is $\gamma+x_3+y_3+x_4+y_4+x_5=\gamma+\beta(p_5)
+ -\alpha(p_2)$.
+
+ The quantities $\alpha$, $\beta$, $\gamma$ involve glue stretchability and
+ shrinkability as well as a natural width. If we were to compute $\alpha(p)$
+ and $\beta(p)$ for each |p|, we would need multiple precision arithmetic, and
+ the multiprecise numbers would have to be kept in the active nodes.
+ \TeX\ avoids this problem by working entirely with relative differences
+ or ``deltas.'' Suppose, for example, that the active list contains
+ $a_1\,\delta_1\,a_2\,\delta_2\,a_3$, where the |a|'s are active breakpoints
+ and the $\delta$'s are delta nodes. Then $\delta_1=\alpha(a_1)-\alpha(a_2)$
+ and $\delta_2=\alpha(a_2)-\alpha(a_3)$. If the line breaking algorithm is
+ currently positioned at some other breakpoint |p|, the |active_width| array
+ contains the value $\gamma+\beta(p)-\alpha(a_1)$. If we are scanning through
+ the list of active nodes and considering a tentative line that runs from
+ $a_2$ to~|p|, say, the |cur_active_width| array will contain the value
+ $\gamma+\beta(p)-\alpha(a_2)$. Thus, when we move from $a_2$ to $a_3$,
+ we want to add $\alpha(a_2)-\alpha(a_3)$ to |cur_active_width|; and this
+ is just $\delta_2$, which appears in the active list between $a_2$ and
+ $a_3$. The |background| array contains $\gamma$. The |break_width| array
+ will be used to calculate values of new delta nodes when the active
+ list is being updated.
+*/
+
+/* The heart of the line-breaking procedure is `|try_break|', a subroutine
+ that tests if the current breakpoint |cur_p| is feasible, by running
+ through the active list to see what lines of text can be made from active
+ nodes to~|cur_p|. If feasible breaks are possible, new break nodes are
+ created. If |cur_p| is too far from an active node, that node is
+ deactivated.
+
+ The parameter |pi| to |try_break| is the penalty associated
+ with a break at |cur_p|; we have |pi=eject_penalty| if the break is forced,
+ and |pi=inf_penalty| if the break is illegal.
+
+ The other parameter, |break_type|, is set to |hyphenated_node| or |unhyphenated_node|,
+ depending on whether or not the current break is at a |disc_node|. The
+ end of a paragraph is also regarded as `|hyphenated_node|'; this case is
+ distinguishable by the condition |cur_p=null|.
+*/
+
+
+
+static integer internal_pen_inter; /* running \.{\\localinterlinepenalty} */
+static integer internal_pen_broken; /* running \.{\\localbrokenpenalty} */
+static halfword internal_left_box; /* running \.{\\localleftbox} */
+static integer internal_left_box_width; /* running \.{\\localleftbox} width */
+static halfword init_internal_left_box; /* running \.{\\localleftbox} */
+static integer init_internal_left_box_width; /* running \.{\\localleftbox} width */
+static halfword internal_right_box; /* running \.{\\localrightbox} */
+static integer internal_right_box_width; /* running \.{\\localrightbox} width */
+
+static scaled disc_width [10] = {0}; /* the length of discretionary material preceding a break*/
+
+/* As we consider various ways to end a line at |cur_p|, in a given line number
+ class, we keep track of the best total demerits known, in an array with
+ one entry for each of the fitness classifications. For example,
+ |minimal_demerits[tight_fit]| contains the fewest total demerits of feasible
+ line breaks ending at |cur_p| with a |tight_fit| line; |best_place[tight_fit]|
+ points to the passive node for the break before~|cur_p| that achieves such
+ an optimum; and |best_pl_line[tight_fit]| is the |line_number| field in the
+ active node corresponding to |best_place[tight_fit]|. When no feasible break
+ sequence is known, the |minimal_demerits| entries will be equal to
+ |awful_bad|, which is $2^{30}-1$. Another variable, |minimum_demerits|,
+ keeps track of the smallest value in the |minimal_demerits| array.
+*/
+
+
+static integer minimal_demerits[4]; /* best total demerits known for current
+ line class and position, given the fitness */
+static integer minimum_demerits; /* best total demerits known for current line class
+ and position */
+static halfword best_place[4]; /* how to achieve |minimal_demerits| */
+static halfword best_pl_line[4]; /*corresponding line number*/
+
+
+/*
+ The length of lines depends on whether the user has specified
+\.{\\parshape} or \.{\\hangindent}. If |par_shape_ptr| is not null, it
+points to a $(2n+1)$-word record in |mem|, where the |vinfo| in the first
+word contains the value of |n|, and the other $2n$ words contain the left
+margins and line lengths for the first |n| lines of the paragraph; the
+specifications for line |n| apply to all subsequent lines. If
+|par_shape_ptr=null|, the shape of the paragraph depends on the value of
+|n=hang_after|; if |n>=0|, hanging indentation takes place on lines |n+1|,
+|n+2|, \dots, otherwise it takes place on lines 1, \dots, $\vert
+n\vert$. When hanging indentation is active, the left margin is
+|hang_indent|, if |hang_indent>=0|, else it is 0; the line length is
+$|hsize|-\vert|hang_indent|\vert$. The normal setting is
+|par_shape_ptr=null|, |hang_after=1|, and |hang_indent=0|.
+Note that if |hang_indent=0|, the value of |hang_after| is irrelevant.
+@^length of lines@> @^hanging indentation@>
+*/
+
+static halfword easy_line; /*line numbers |>easy_line| are equivalent in break nodes*/
+static halfword last_special_line; /*line numbers |>last_special_line| all have the same width */
+static scaled first_width; /*the width of all lines |<=last_special_line|, if
+ no \.{\\parshape} has been specified*/
+static scaled second_width; /*the width of all lines |>last_special_line|*/
+static scaled first_indent; /*left margin to go with |first_width|*/
+static scaled second_indent; /*left margin to go with |second_width|*/
+
+static halfword best_bet; /*use this passive node and its predecessors */
+static integer fewest_demerits; /*the demerits associated with |best_bet|*/
+static halfword best_line; /*line number following the last line of the new paragraph*/
+static integer actual_looseness; /*the difference between |line_number(best_bet)|
+ and the optimum |best_line|*/
+static integer line_diff; /*the difference between the current line number and
+ the optimum |best_line|*/
+
+
+
+/* \TeX\ makes use of the fact that |hlist_node|, |vlist_node|,
+ |rule_node|, |ins_node|, |mark_node|, |adjust_node|,
+ |disc_node|, |whatsit_node|, and |math_node| are at the low end of the
+ type codes, by permitting a break at glue in a list if and only if the
+ |type| of the previous node is less than |math_node|. Furthermore, a
+ node is discarded after a break if its type is |math_node| or~more.
+*/
+
+#define do_all_six(a) a(1);a(2);a(3);a(4);a(5);a(6);a(7)
+#define do_seven_eight(a) if (pdf_adjust_spacing > 1) { a(8);a(9); }
+#define do_all_eight(a) do_all_six(a); do_seven_eight(a)
+#define do_one_seven_eight(a) a(1); do_seven_eight(a)
+
+#define store_background(a) {active_width[a]=background[a];}
+
+#define act_width active_width[1] /*length from first active node to current node*/
+
+#define kern_break() { \
+ if ((!is_char_node(vlink(cur_p))) && auto_breaking) \
+ if (type(vlink(cur_p))==glue_node) \
+ ext_try_break(0,unhyphenated_node, pdf_adjust_spacing, \
+ par_shape_ptr, adj_demerits, \
+ tracing_paragraphs, pdf_protrude_chars, \
+ line_penalty, last_line_fit, \
+ double_hyphen_demerits, final_hyphen_demerits,first_p,cur_p); \
+ if (type(cur_p)!=math_node) act_width+=width(cur_p); \
+ else act_width+=surround(cur_p); \
+ }
+
+#define clean_up_the_memory() { \
+ q=vlink(active); \
+ while (q!=active) { \
+ cur_p=vlink(q); \
+ if (type(q)==delta_node) flush_node(q); \
+ else flush_node(q); \
+ q=cur_p; \
+ } \
+ q=passive; \
+ while (q!=null) { \
+ cur_p=vlink(q); \
+ flush_node(q); \
+ q=cur_p; \
+ } \
+ }
+
+#define inf_bad 10000 /* infinitely bad value */
+
+static boolean do_last_line_fit; /* special algorithm for last line of paragraph? */
+static scaled fill_width[4]; /* infinite stretch components of |par_fill_skip| */
+static scaled best_pl_short[4]; /* |shortfall| corresponding to |minimal_demerits| */
+static scaled best_pl_glue[4]; /*corresponding glue stretch or shrink */
+
+#define awful_bad 07777777777 /* more than a billion demerits */
+
+#define before 0 /* |subtype| for math node that introduces a formula */
+#define after 1 /* |subtype| for math node that winds up a formula */
+
+#define reset_disc_width(a) disc_width[(a)] = 0
+
+#define add_disc_width_to_break_width(a) break_width[(a)] += disc_width[(a)]
+#define sub_disc_width_from_active_width(a) active_width[(a)] -= disc_width[(a)]
+
+#define add_char_shrink(a,b) a += char_shrink((b))
+#define add_char_stretch(a,b) a += char_stretch((b))
+#define sub_char_shrink(a,b) a -= char_shrink((b))
+#define sub_char_stretch(a,b) a -= char_stretch((b))
+
+#define add_kern_shrink(a,b) a += kern_shrink((b))
+#define add_kern_stretch(a,b) a += kern_stretch((b))
+#define sub_kern_shrink(a,b) a -= kern_shrink((b))
+#define sub_kern_stretch(a,b) a -= kern_stretch((b))
+
+
+/* When we insert a new active node for a break at |cur_p|, suppose this
+ new node is to be placed just before active node |a|; then we essentially
+ want to insert `$\delta\,|cur_p|\,\delta^\prime$' before |a|, where
+ $\delta=\alpha(a)-\alpha(|cur_p|)$ and $\delta^\prime=\alpha(|cur_p|)-\alpha(a)$
+ in the notation explained above. The |cur_active_width| array now holds
+ $\gamma+\beta(|cur_p|)-\alpha(a)$; so $\delta$ can be obtained by
+ subtracting |cur_active_width| from the quantity $\gamma+\beta(|cur_p|)-
+ \alpha(|cur_p|)$. The latter quantity can be regarded as the length of a
+ line ``from |cur_p| to |cur_p|''; we call it the |break_width| at |cur_p|.
+
+ The |break_width| is usually negative, since it consists of the background
+ (which is normally zero) minus the width of nodes following~|cur_p| that are
+ eliminated after a break. If, for example, node |cur_p| is a glue node, the
+ width of this glue is subtracted from the background; and we also look
+ ahead to eliminate all subsequent glue and penalty and kern and math
+ nodes, subtracting their widths as well.
+
+ Kern nodes do not disappear at a line break unless they are |explicit|.
+*/
+
+/* assigned-to globals:
+ break_width[]
+*/
+/* used globals:
+ disc_width[]
+ line_break_dir
+*/
+static void
+compute_break_width (int break_type, int pdf_adjust_spacing, halfword p
+ /*, halfword s*/) {
+ halfword s; /* glue and other 'whitespace' to be skipped after a break
+ * used if unhyphenated, or post_break==empty */
+ s=p;
+ if (break_type>unhyphenated_node && p!=null) {
+ /*@<Compute the discretionary |break_width| values@>;*/
+ /* When |p| is a discretionary break, the length of a line
+ ``from |p| to |p|'' has to be defined properly so
+ that the other calculations work out. Suppose that the
+ pre-break text at |p| has length $l_0$, the post-break
+ text has length $l_1$, and the replacement text has length
+ |l|. Suppose also that |q| is the node following the
+ replacement text. Then length of a line from |p| to |q|
+ will be computed as $\gamma+\beta(q)-\alpha(|p|)$, where
+ $\beta(q)=\beta(|p|)-l_0+l$. The actual length will be
+ the background plus $l_1$, so the length from |p| to
+ |p| should be $\gamma+l_0+l_1-l$. If the post-break text
+ of the discretionary is empty, a break may also discard~|q|;
+ in that unusual case we subtract the length of~|q| and any
+ other nodes that will be discarded after the discretionary
+ break.
+
+ TH: I don't quite understand the above remarks.
+
+ The value of $l_0$ need not be computed, since |line_break|
+ will put it into the global variable |disc_width| before
+ calling |try_break|.
+ */
+ /* In case of nested discretionaries, we always follow the no_break
+ path, as we are talking about the breaking on _this_ position.
+ */
+
+ halfword v;
+ for (v=vlink_no_break(p); v!=null; v=vlink(v)) {
+ /* @<Subtract the width of node |v| from |break_width|@>; */
+ /* Replacement texts and discretionary texts are supposed to contain
+ only character nodes, kern nodes, and box or rule nodes.*/
+ if (is_char_node(v)) {
+ if (is_rotated(line_break_dir)) {
+ break_width[1] -= (glyph_height(v)+glyph_depth(v));
+ } else {
+ break_width[1] -= glyph_width(v);
+ }
+ if ((pdf_adjust_spacing > 1) && check_expand_pars(font(v))) {
+ set_prev_char_p(v);
+ sub_char_stretch(break_width[8],v);
+ sub_char_shrink(break_width[9],v);
+ }
+ } else {
+ switch (type(v)) {
+ case hlist_node:
+ case vlist_node:
+ if (!(dir_orthogonal(dir_primary[box_dir(v)],
+ dir_primary[line_break_dir])))
+ break_width[1] -= width(v);
+ else
+ break_width[1] -= (depth(v)+height(v));
+ break;
+ case kern_node:
+ if ((pdf_adjust_spacing > 1) && (subtype(v) == normal)) {
+ sub_kern_stretch(break_width[8],v);
+ sub_kern_shrink(break_width[9],v);
+ }
+ /* fall through */
+ case rule_node:
+ break_width[1] -= width(v);
+ break;
+ case disc_node:
+ assert(vlink(v)==null); /* discs are _always_ last */
+ v = no_break(v);
+ break;
+ default:
+ tconfusion("disc1");
+ break;
+ }
+ }
+ }
+
+ for (v=vlink_post_break(p); v!=null; v=vlink(v)) {
+ /* @<Add the width of node |v| to |break_width|@>; */
+ if (is_char_node(v)) {
+ if (is_rotated(line_break_dir))
+ break_width[1] += (glyph_height(v)+glyph_depth(v));
+ else
+ break_width[1] += glyph_width(v);
+ if ((pdf_adjust_spacing > 1) && check_expand_pars(font(v))) {
+ set_prev_char_p(v);
+ add_char_stretch(break_width[8],v);
+ add_char_shrink(break_width[9],v);
+ }
+ } else {
+ switch (type(v)) {
+ case hlist_node:
+ case vlist_node:
+ if (!(dir_orthogonal(dir_primary[box_dir(v)],
+ dir_primary[line_break_dir])))
+ break_width[1] += width(v);
+ else
+ break_width[1] += (depth(v)+height(v));
+ break;
+ case kern_node:
+ if ((pdf_adjust_spacing > 1) && (subtype(v) == normal)) {
+ add_kern_stretch(break_width[8],v);
+ add_kern_shrink(break_width[9],v);
+ }
+ /* fall through */
+ case rule_node:
+ break_width[1] += width(v);
+ break;
+ case disc_node:
+ assert(vlink(v)==null);
+ v = no_break(v);
+ break;
+ default:
+ tconfusion("disc2");
+ }
+ }
+ }
+
+ do_one_seven_eight(add_disc_width_to_break_width);
+ if (vlink_post_break(p)==null) {
+ s=vlink(p); /* no post_break: 'skip' any 'whitespace' following */
+ } else {
+ s=null;
+ }
+ } else {
+ s = p; /* unhyphenated: we need to 'skip' any 'whitespace' following */
+ }
+ while (s!=null) {
+ switch (type(s)) {
+ case glue_node:
+ /*@<Subtract glue from |break_width|@>;*/
+ {halfword v=glue_ptr(s);
+ break_width[1] -= width(v);
+ break_width[2+stretch_order(v)] -= stretch(v);
+ break_width[7] -= shrink(v);
+ }break;
+ case penalty_node:
+ break;
+ case math_node:
+ break_width[1] -= surround(s);
+ break;
+ case kern_node:
+ if (subtype(s)!=explicit)
+ return;
+ else
+ break_width[1] -= width(s);
+ break;
+ default:
+ return;
+ };
+ s=vlink(s);
+ }
+}
+
+
+static void
+print_break_node(halfword q, fitness_value fit_class,
+ quarterword break_type, halfword cur_p) {
+ /* @<Print a symbolic description of the new break node@> */
+ tprint_nl("@@");
+ print_int(serial(passive));
+ tprint(": line ");
+ print_int(line_number(q)-1);
+ print_char('.');
+ print_int(fit_class);
+ if (break_type==hyphenated_node)
+ print_char('-');
+ tprint(" t=");
+ print_int(total_demerits(q));
+ if (do_last_line_fit) {
+ /*@<Print additional data in the new active node@>; */
+ tprint(" s=");
+ print_scaled(active_short(q));
+ if (cur_p==null)
+ tprint(" a=");
+ else
+ tprint(" g=");
+ print_scaled(active_glue(q));
+ }
+ tprint(" -> @@");
+ if (prev_break(passive)==null)
+ print_char('0');
+ else
+ print_int(serial(prev_break(passive)));
+}
+
+
+static void
+print_feasible_break(halfword cur_p, pointer r, halfword b, integer pi,
+ integer d, boolean artificial_demerits) {
+ /* @<Print a symbolic description of this feasible break@>;*/
+ if (printed_node!=cur_p) {
+ /* @<Print the list between |printed_node| and |cur_p|, then
+ set |printed_node:=cur_p|@>;*/
+ tprint_nl("");
+ if (cur_p==null) {
+ short_display(vlink(printed_node));
+ } else {
+ halfword save_link=vlink(cur_p);
+ vlink(cur_p)=null;
+ tprint_nl("");
+ short_display(vlink(printed_node));
+ vlink(cur_p)=save_link;
+ }
+ printed_node=cur_p;
+ }
+ tprint_nl("@");
+ if (cur_p==null) {
+ tprint_esc("par");
+ } else if (type(cur_p)!=glue_node) {
+ if (type(cur_p)==penalty_node) tprint_esc("penalty");
+ else if (type(cur_p)==disc_node) tprint_esc("discretionary");
+ else if (type(cur_p)==kern_node) tprint_esc("kern");
+ else tprint_esc("math");
+ }
+ tprint(" via @@");
+ if (break_node(r)==null)
+ print_char('0');
+ else
+ print_int(serial(break_node(r)));
+ tprint(" b=");
+ if (b>inf_bad)
+ print_char('*');
+ else
+ print_int(b);
+ tprint(" p=");
+ print_int(pi);
+ tprint(" d=");
+ if (artificial_demerits)
+ print_char('*');
+ else
+ print_int(d);
+}
+
+#define add_disc_width_to_active_width(a) active_width[a] += disc_width[a]
+#define update_width(a) cur_active_width[a] += varmem[(r+(a))].cint
+
+#define set_break_width_to_background(a) break_width[a]=background[(a)]
+
+#define convert_to_break_width(a) \
+ varmem[(prev_r+(a))].cint -= (cur_active_width[(a)]+break_width[(a)])
+
+#define store_break_width(a) active_width[(a)]=break_width[(a)]
+
+#define new_delta_to_break_width(a) \
+ varmem[(q+(a))].cint=break_width[(a)]-cur_active_width[(a)]
+
+#define new_delta_from_break_width(a) \
+ varmem[(q+(a))].cint=cur_active_width[(a)]-break_width[(a)]
+
+#define copy_to_cur_active(a) cur_active_width[(a)]=active_width[(a)]
+
+#define combine_two_deltas(a) varmem[(prev_r+(a))].cint += varmem[(r+(a))].cint
+#define downdate_width(a) cur_active_width[(a)] -= varmem[(prev_r+(a))].cint
+#define update_active(a) active_width[(a)]+=varmem[(r+(a))].cint
+
+#define total_font_stretch cur_active_width[8]
+#define total_font_shrink cur_active_width[9]
+
+#define max_dimen 07777777777 /* $2^{30}-1$ */
+
+#define left_side 0
+#define right_side 1
+
+
+#define cal_margin_kern_var(a) { \
+ character(cp) = character((a)); \
+ font(cp) = font((a)); \
+ do_subst_font(cp, 1000); \
+ if (font(cp) != font((a))) \
+ margin_kern_stretch += (left_pw((a)) - left_pw(cp)); \
+ font(cp) = font((a)); \
+ do_subst_font(cp, -1000); \
+ if (font(cp) != font((a))) \
+ margin_kern_shrink += (left_pw(cp) - left_pw((a))); \
+ }
+
+static void
+ext_try_break(integer pi,
+ quarterword break_type,
+ int pdf_adjust_spacing,
+ int par_shape_ptr,
+ int adj_demerits,
+ int tracing_paragraphs,
+ int pdf_protrude_chars,
+ int line_penalty,
+ int last_line_fit,
+ int double_hyphen_demerits,
+ int final_hyphen_demerits,
+ halfword first_p,
+ halfword cur_p) {
+ /* CONTINUE,DEACTIVATE,FOUND,NOT_FOUND; */
+ pointer r; /* runs through the active list */
+ scaled margin_kern_stretch;
+ scaled margin_kern_shrink;
+ halfword lp, rp, cp;
+ halfword prev_r; /* stays a step behind |r| */
+ halfword prev_prev_r; /*a step behind |prev_r|, if |type(prev_r)=delta_node|*/
+ halfword old_l; /* maximum line number in current equivalence class of lines */
+ boolean no_break_yet; /* have we found a feasible break at |cur_p|? */
+ halfword q; /*points to a new node being created*/
+ halfword l; /*line number of current active node*/
+ boolean node_r_stays_active; /*should node |r| remain in the active list?*/
+ scaled line_width; /*the current line will be justified to this width*/
+ fitness_value fit_class; /*possible fitness class of test line*/
+ halfword b; /*badness of test line*/
+ integer d; /*demerits of test line*/
+ boolean artificial_demerits; /*has |d| been forced to zero?*/
+
+ scaled shortfall; /*used in badness calculations*/
+ scaled g; /*glue stretch or shrink of test line, adjustment for last line*/
+ scaled cur_active_width[10] = {0}; /*distance from current active node*/
+
+ line_width=0; g=0; prev_prev_r=null;
+ /*@<Make sure that |pi| is in the proper range@>;*/
+ if (pi>=inf_penalty) {
+ return; /* this breakpoint is inhibited by infinite penalty */
+ } else if (pi<=-inf_penalty) {
+ pi=eject_penalty; /*this breakpoint will be forced*/
+ }
+
+ no_break_yet=true;
+ prev_r=active;
+ old_l=0;
+ do_all_eight(copy_to_cur_active);
+
+ while (1) {
+ r=vlink(prev_r);
+ /* @<If node |r| is of type |delta_node|, update |cur_active_width|,
+ set |prev_r| and |prev_prev_r|, then |goto continue|@>; */
+ /* The following code uses the fact that |type(active)<>delta_node| */
+ if (type(r)==delta_node) {
+ do_all_eight(update_width); /* IMPLICIT ,r */
+ prev_prev_r=prev_r;
+ prev_r=r;
+ continue;
+ }
+ /* @<If a line number class has ended, create new active nodes for
+ the best feasible breaks in that class; then |return|
+ if |r=active|, otherwise compute the new |line_width|@>; */
+ /* The first part of the following code is part of \TeX's inner loop, so
+ we don't want to waste any time. The current active node, namely node |r|,
+ contains the line number that will be considered next. At the end of the
+ list we have arranged the data structure so that |r=active| and
+ |line_number(active)>old_l|.
+ */
+ l=line_number(r);
+ if (l>old_l) { /* now we are no longer in the inner loop */
+ if ((minimum_demerits<awful_bad)&&((old_l!=easy_line)||(r==active))) {
+ /*@<Create new active nodes for the best feasible breaks just found@>*/
+ /* It is not necessary to create new active nodes having |minimal_demerits|
+ greater than
+ |minimum_demerits+abs(adj_demerits)|, since such active nodes will never
+ be chosen in the final paragraph breaks. This observation allows us to
+ omit a substantial number of feasible breakpoints from further consideration.
+ */
+ if (no_break_yet) {
+ no_break_yet=false;
+ do_all_eight(set_break_width_to_background);
+ compute_break_width(break_type, pdf_adjust_spacing, cur_p);
+ }
+ /* @<Insert a delta node to prepare for breaks at |cur_p|@>;*/
+ /* We use the fact that |type(active)<>delta_node|.*/
+ if (type(prev_r)==delta_node) {/* modify an existing delta node */
+ do_all_eight(convert_to_break_width); /* IMPLICIT prev_r */
+ } else if (prev_r==active) { /* no delta node needed at the beginning */
+ do_all_eight(store_break_width);
+ } else {
+ q=new_node(delta_node,0);
+ vlink(q)=r;
+ do_all_eight(new_delta_to_break_width); /* IMPLICIT q */
+ vlink(prev_r)=q;
+ prev_prev_r=prev_r;
+ prev_r=q;
+ }
+
+ if (abs(adj_demerits)>=awful_bad-minimum_demerits)
+ minimum_demerits=awful_bad-1;
+ else
+ minimum_demerits += abs(adj_demerits);
+ for (fit_class=very_loose_fit;fit_class<=tight_fit;fit_class++) {
+ if (minimal_demerits[fit_class]<=minimum_demerits) {
+ /* @<Insert a new active node from |best_place[fit_class]|
+ to |cur_p|@>; */
+ /* When we create an active node, we also create the corresponding
+ passive node.
+ */
+ q=new_node(passive_node,0);
+ vlink(q)=passive;
+ passive=q;
+ cur_break(q)=cur_p;
+ incr(pass_number);
+ serial(q)=pass_number;
+ prev_break(q)=best_place[fit_class];
+ /*Here we keep track of the subparagraph penalties in the break nodes*/
+ passive_pen_inter(q)=internal_pen_inter;
+ passive_pen_broken(q)=internal_pen_broken;
+ passive_last_left_box(q)=internal_left_box;
+ passive_last_left_box_width(q)=internal_left_box_width;
+ if (prev_break(q)!=null) {
+ passive_left_box(q)=passive_last_left_box(prev_break(q));
+ passive_left_box_width(q)=passive_last_left_box_width(prev_break(q));
+ } else {
+ passive_left_box(q)=init_internal_left_box;
+ passive_left_box_width(q)=init_internal_left_box_width;
+ }
+ passive_right_box(q)=internal_right_box;
+ passive_right_box_width(q)=internal_right_box_width;
+ q=new_node(break_type,fit_class);
+ break_node(q)=passive;
+ line_number(q)=best_pl_line[fit_class]+1;
+ total_demerits(q)=minimal_demerits[fit_class];
+ if (do_last_line_fit) {
+ /*@<Store \(a)additional data in the new active node@>*/
+ /* Here we save these data in the active node
+ representing a potential line break.*/
+ active_short(q)=best_pl_short[fit_class];
+ active_glue(q)=best_pl_glue[fit_class];
+ }
+ vlink(q)=r;
+ vlink(prev_r)=q;
+ prev_r=q;
+ if (tracing_paragraphs>0)
+ print_break_node(q,fit_class,break_type,cur_p);
+ }
+ minimal_demerits[fit_class]=awful_bad;
+ }
+ minimum_demerits=awful_bad;
+ /* @<Insert a delta node to prepare for the next active node@>;*/
+ /* When the following code is performed, we will have just inserted at
+ least one active node before |r|, so |type(prev_r)<>delta_node|.
+ */
+ if (r!=active) {
+ q=new_node(delta_node,0);
+ vlink(q)=r;
+ do_all_eight(new_delta_from_break_width); /* IMPLICIT q */
+ vlink(prev_r)=q;
+ prev_prev_r=prev_r;
+ prev_r=q;
+ }
+ }
+ if (r==active)
+ return;
+ /*@<Compute the new line width@>;*/
+ /* When we come to the following code, we have just encountered
+ the first active node~|r| whose |line_number| field contains
+ |l|. Thus we want to compute the length of the $l\mskip1mu$th
+ line of the current paragraph. Furthermore, we want to set
+ |old_l| to the last number in the class of line numbers
+ equivalent to~|l|.
+ */
+ if (l>easy_line) {
+ old_l=max_halfword-1;
+ line_width=second_width;
+ } else {
+ old_l=l;
+ if (l>last_special_line) {
+ line_width=second_width;
+ } else if (par_shape_ptr==null) {
+ line_width=first_width;
+ } else {
+ line_width=varmem[(par_shape_ptr+2*l+1)].cint;
+ }
+ }
+ }
+ /* /If a line number class has ended, create new active nodes for
+ the best feasible breaks in that class; then |return|
+ if |r=active|, otherwise compute the new |line_width|@>; */
+
+ /* @<Consider the demerits for a line from |r| to |cur_p|;
+ deactivate node |r| if it should no longer be active;
+ then |goto continue| if a line from |r| to |cur_p| is infeasible,
+ otherwise record a new feasible break@>; */
+ artificial_demerits=false;
+ shortfall = line_width
+ - cur_active_width[1]
+ -(( break_node(r)==null)
+ ? init_internal_left_box_width
+ : passive_last_left_box_width(break_node(r)))
+ - internal_right_box_width;
+ if (pdf_protrude_chars > 1) {
+ halfword l, o;
+ l = (break_node(r) == null) ? first_p : cur_break(break_node(r));
+ if (cur_p==null) {
+ o = null;
+ } else { /* TODO if (is_character_node(alink(cur_p))) */
+ o = alink(cur_p);
+ assert(vlink(o)==cur_p);
+ }
+ /* let's look at the right margin first */
+ if ((cur_p != null) && (type(cur_p) == disc_node) && (vlink_pre_break(cur_p) != null)) {
+ /* a |disc_node| with non-empty |pre_break|, protrude the last char of |pre_break| */
+ o = tlink_pre_break(cur_p);
+ } else {
+ o = find_protchar_right(l, o);
+ }
+ /* now the left margin */
+ if ((l != null) && (type(l) == disc_node) && (vlink_post_break(l) != null)) {
+ /* FIXME: first 'char' could be a disc! */
+ l = vlink_post_break(l); /* protrude the first char */
+ } else {
+ l = find_protchar_left(l, true);
+ }
+ shortfall += (left_pw(l) + right_pw(o));
+ }
+ if ((shortfall != 0) && (pdf_adjust_spacing > 1)) {
+ margin_kern_stretch = 0;
+ margin_kern_shrink = 0;
+ if (pdf_protrude_chars > 1) {
+ /* @<Calculate variations of marginal kerns@>;*/
+ lp = last_leftmost_char;
+ rp = last_rightmost_char;
+ cp = raw_glyph_node();
+ if (lp != null) {
+ cal_margin_kern_var(lp);
+ }
+ if (rp != null) {
+ cal_margin_kern_var(rp);
+ }
+ flush_node(cp);
+ }
+ if ((shortfall > 0) && ((total_font_stretch + margin_kern_stretch) > 0)) {
+ if ((total_font_stretch + margin_kern_stretch) > shortfall)
+ shortfall = ((total_font_stretch + margin_kern_stretch) /
+ (max_stretch_ratio / cur_font_step)) / 2;
+ else
+ shortfall -= (total_font_stretch + margin_kern_stretch);
+ } else if ((shortfall < 0) && ((total_font_shrink + margin_kern_shrink) > 0)) {
+ if ((total_font_shrink + margin_kern_shrink) > -shortfall)
+ shortfall = -((total_font_shrink + margin_kern_shrink) /
+ (max_shrink_ratio / cur_font_step)) / 2;
+ else
+ shortfall += (total_font_shrink + margin_kern_shrink);
+ }
+ }
+ if (shortfall>0) {
+ /* @<Set the value of |b| to the badness for stretching the line,
+ and compute the corresponding |fit_class|@> */
+
+ /* When a line must stretch, the available stretchability can be
+ found in the subarray |cur_active_width[2..6]|, in units of
+ points, sfi, fil, fill and filll.
+
+ The present section is part of \TeX's inner loop, and it is
+ most often performed when the badness is infinite; therefore
+ it is worth while to make a quick test for large width excess
+ and small stretchability, before calling the |badness|
+ subroutine. @^inner loop@> */
+
+ if ((cur_active_width[3]!=0)||(cur_active_width[4]!=0)||
+ (cur_active_width[5]!=0)||(cur_active_width[6]!=0)) {
+ if (do_last_line_fit) {
+ if (cur_p==null) { /* the last line of a paragraph */
+ /* @<Perform computations for last line and |goto found|@>;*/
+
+ /* Here we compute the adjustment |g| and badness |b| for
+ a line from |r| to the end of the paragraph. When any
+ of the criteria for adjustment is violated we fall
+ through to the normal algorithm.
+
+ The last line must be too short, and have infinite
+ stretch entirely due to |par_fill_skip|.*/
+ if ((active_short(r)==0)||(active_glue(r)<=0))
+ /* previous line was neither stretched nor shrunk, or
+ was infinitely bad*/
+ goto NOT_FOUND;
+ if ((cur_active_width[3]!=fill_width[0])||
+ (cur_active_width[4]!=fill_width[1])||
+ (cur_active_width[5]!=fill_width[2])||
+ (cur_active_width[6]!=fill_width[3]))
+ /* infinite stretch of this line not entirely due to
+ |par_fill_skip| */
+ goto NOT_FOUND;
+ if (active_short(r)>0)
+ g=cur_active_width[2];
+ else
+ g=cur_active_width[7];
+ if (g<=0)
+ /*no finite stretch resp.\ no shrink*/
+ goto NOT_FOUND;
+ arith_error=false;
+ g=fract(g,active_short(r),active_glue(r),max_dimen);
+ if (last_line_fit<1000)
+ g=fract(g,last_line_fit,1000,max_dimen);
+ if (arith_error) {
+ if (active_short(r)>0)
+ g=max_dimen;
+ else
+ g=-max_dimen;
+ }
+ if (g>0) {
+ /*@<Set the value of |b| to the badness of the last line
+ for stretching, compute the corresponding |fit_class,
+ and |goto found||@>*/
+ /* These badness computations are rather similar to
+ those of the standard algorithm, with the adjustment
+ amount |g| replacing the |shortfall|.*/
+ if (g>shortfall)
+ g=shortfall;
+ if (g>7230584) {
+ if (cur_active_width[2]<1663497) {
+ b=inf_bad;
+ fit_class=very_loose_fit;
+ goto FOUND;
+ }
+ }
+ b=badness(g,cur_active_width[2]);
+ if (b>99) { fit_class=very_loose_fit; }
+ else if (b>12) { fit_class=loose_fit; }
+ else { fit_class=decent_fit; }
+ goto FOUND;
+ } else if (g<0) {
+ /*@<Set the value of |b| to the badness of the last line
+ for shrinking, compute the corresponding |fit_class,
+ and |goto found||@>;*/
+ if (-g>cur_active_width[7])
+ g=-cur_active_width[7];
+ b=badness(-g,cur_active_width[7]);
+ if (b>12) fit_class=tight_fit;
+ else fit_class=decent_fit;
+ goto FOUND;
+ }
+ }
+ NOT_FOUND:
+ shortfall=0;
+ }
+ b=0;
+ fit_class=decent_fit; /* infinite stretch */
+ } else {
+ if (shortfall>7230584 && cur_active_width[2]<1663497) {
+ b=inf_bad;
+ fit_class=very_loose_fit;
+ } else {
+ b=badness(shortfall,cur_active_width[2]);
+ if (b>99) { fit_class=very_loose_fit; }
+ else if (b>12) { fit_class=loose_fit; }
+ else { fit_class=decent_fit; }
+ }
+ }
+ } else {
+ /* Set the value of |b| to the badness for shrinking the line,
+ and compute the corresponding |fit_class|@>; */
+ /* Shrinkability is never infinite in a paragraph; we can shrink
+ the line from |r| to |cur_p| by at most
+ |cur_active_width[7]|.*/
+ if (-shortfall>cur_active_width[7])
+ b=inf_bad+1;
+ else
+ b=badness(-shortfall,cur_active_width[7]);
+ if (b>12)
+ fit_class=tight_fit;
+ else
+ fit_class=decent_fit;
+ }
+ if (do_last_line_fit) {
+ /* @<Adjust \(t)the additional data for last line@>; */
+ if (cur_p==null) shortfall=0;
+ if (shortfall>0) { g=cur_active_width[2]; }
+ else if (shortfall<0) { g=cur_active_width[7]; }
+ else { g=0;}
+ }
+ FOUND:
+ if ((b>inf_bad)||(pi==eject_penalty)) {
+ /* @<Prepare to deactivate node~|r|, and |goto deactivate| unless
+ there is a reason to consider lines of text from |r| to |cur_p|@> */
+ /* During the final pass, we dare not lose all active nodes, lest we lose
+ touch with the line breaks already found. The code shown here makes
+ sure that such a catastrophe does not happen, by permitting overfull
+ boxes as a last resort. This particular part of \TeX\ was a source of
+ several subtle bugs before the correct program logic was finally
+ discovered; readers who seek to ``improve'' \TeX\ should therefore
+ think thrice before daring to make any changes here.
+ @^overfull boxes@>
+ */
+ if (final_pass && (minimum_demerits==awful_bad) &&
+ (vlink(r)==active) && (prev_r==active)) {
+ artificial_demerits=true; /* set demerits zero, this break is forced */
+ } else if (b>threshold) {
+ goto DEACTIVATE;
+ }
+ node_r_stays_active=false;
+ } else {
+ prev_r=r;
+ if (b>threshold)
+ continue;
+ node_r_stays_active=true;
+ }
+ /* @<Record a new feasible break@>;*/
+ /* When we get to this part of the code, the line from |r| to |cur_p| is
+ feasible, its badness is~|b|, and its fitness classification is
+ |fit_class|. We don't want to make an active node for this break yet,
+ but we will compute the total demerits and record them in the
+ |minimal_demerits| array, if such a break is the current champion among
+ all ways to get to |cur_p| in a given line-number class and fitness
+ class.
+ */
+ if (artificial_demerits) {
+ d=0;
+ } else {
+ /* @<Compute the demerits, |d|, from |r| to |cur_p|@>;*/
+ d=line_penalty+b;
+ if (abs(d)>=10000) d=100000000; else d=d*d;
+ if (pi!=0) {
+ if (pi>0) {
+ d += (pi*pi);
+ } else if (pi>eject_penalty) {
+ d -= (pi*pi);
+ }
+ }
+ if ((break_type==hyphenated_node)&&(type(r)==hyphenated_node)) {
+ if (cur_p!=null)
+ d += double_hyphen_demerits;
+ else
+ d += final_hyphen_demerits;
+ }
+ if (abs(fit_class-fitness(r))>1) d=d+adj_demerits;
+ }
+ if (tracing_paragraphs>0)
+ print_feasible_break(cur_p, r, b, pi, d, artificial_demerits);
+ d += total_demerits(r); /*this is the minimum total demerits
+ from the beginning to |cur_p| via |r| */
+ if (d<=minimal_demerits[fit_class]) {
+ minimal_demerits[fit_class]=d;
+ best_place[fit_class]=break_node(r);
+ best_pl_line[fit_class]=l;
+ if (do_last_line_fit) {
+ /* Store \(a)additional data for this feasible break@>; */
+ /* For each feasible break we record the shortfall and glue stretch or
+ shrink (or adjustment).*/
+ best_pl_short[fit_class]=shortfall;
+ best_pl_glue[fit_class]=g;
+ }
+ if (d<minimum_demerits)
+ minimum_demerits=d;
+ }
+ /* /Record a new feasible break */
+ if (node_r_stays_active)
+ continue; /*|prev_r| has been set to |r| */
+ DEACTIVATE:
+ /* @<Deactivate node |r|@>; */
+ /* When an active node disappears, we must delete an adjacent delta node if
+ the active node was at the beginning or the end of the active list, or
+ if it was surrounded by delta nodes. We also must preserve the property
+ that |cur_active_width| represents the length of material from
+ |vlink(prev_r)| to~|cur_p|.*/
+
+ vlink(prev_r)=vlink(r);
+ flush_node(r);
+ if (prev_r==active) {
+ /*@<Update the active widths, since the first active node has been
+ deleted@>*/
+ /* The following code uses the fact that |type(active)<>delta_node|.
+ If the active list has just become empty, we do not need to update the
+ |active_width| array, since it will be initialized when an active
+ node is next inserted.
+ */
+ r=vlink(active);
+ if (type(r)==delta_node) {
+ do_all_eight(update_active); /* IMPLICIT r */
+ do_all_eight(copy_to_cur_active);
+ vlink(active)=vlink(r);
+ flush_node(r);
+ }
+ } else if (type(prev_r)==delta_node){
+ r=vlink(prev_r);
+ if (r==active) {
+ do_all_eight(downdate_width); /* IMPLICIT prev_r */
+ vlink(prev_prev_r)=active;
+ flush_node(prev_r);
+ prev_r=prev_prev_r;
+ } else if (type(r)==delta_node) {
+ do_all_eight(update_width); /* IMPLICIT ,r */
+ do_all_eight(combine_two_deltas); /* IMPLICIT r prev_r */
+ vlink(prev_r)=vlink(r);
+ flush_node(r);
+ }
+ }
+ }
+}
+
+
+void
+ext_do_line_break (boolean d,
+ int pretolerance,
+ int tracing_paragraphs,
+ int tolerance,
+ scaled emergency_stretch,
+ int looseness,
+ int hyphen_penalty,
+ int ex_hyphen_penalty,
+ int pdf_adjust_spacing,
+ halfword par_shape_ptr,
+ int adj_demerits,
+ int pdf_protrude_chars,
+ int line_penalty,
+ int last_line_fit,
+ int double_hyphen_demerits,
+ int final_hyphen_demerits,
+ int hang_indent,
+ int hsize,
+ int hang_after,
+ halfword left_skip,
+ halfword right_skip,
+ int pdf_each_line_height,
+ int pdf_each_line_depth,
+ int pdf_first_line_height,
+ int pdf_last_line_depth,
+ halfword inter_line_penalties_ptr,
+ int inter_line_penalty,
+ int club_penalty,
+ halfword club_penalties_ptr,
+ halfword display_widow_penalties_ptr,
+ halfword widow_penalties_ptr,
+ int display_widow_penalty,
+ int widow_penalty,
+ int broken_penalty,
+ halfword final_par_glue) {
+ /* DONE,DONE1,DONE2,DONE3,DONE4,DONE5,CONTINUE;*/
+ halfword cur_p,q,r,s; /* miscellaneous nodes of temporary interest */
+
+ /* Get ready to start ... */
+ minimum_demerits=awful_bad;
+ minimal_demerits[tight_fit]=awful_bad;
+ minimal_demerits[decent_fit]=awful_bad;
+ minimal_demerits[loose_fit]=awful_bad;
+ minimal_demerits[very_loose_fit]=awful_bad;
+
+ /* We compute the values of |easy_line| and the other local variables relating
+ to line length when the |line_break| procedure is initializing itself. */
+ if (par_shape_ptr==null) {
+ if (hang_indent==0) {
+ last_special_line=0;
+ second_width=hsize;
+ second_indent=0;
+ } else {
+ /* @<Set line length parameters in preparation for hanging indentation@>*/
+ /* We compute the values of |easy_line| and the other local variables relating
+ to line length when the |line_break| procedure is initializing itself. */
+ last_special_line=abs(hang_after);
+ if (hang_after<0) {
+ first_width=hsize-abs(hang_indent);
+ if (hang_indent>=0)
+ first_indent=hang_indent;
+ else
+ first_indent=0;
+ second_width=hsize;
+ second_indent=0;
+ } else {
+ first_width=hsize;
+ first_indent=0;
+ second_width=hsize-abs(hang_indent);
+ if (hang_indent>=0)
+ second_indent=hang_indent;
+ else
+ second_indent=0;
+ }
+ }
+ } else {
+ last_special_line=vinfo(par_shape_ptr+1)-1;
+ second_indent=varmem[(par_shape_ptr+(2*last_special_line))].cint;
+ second_width=varmem[(par_shape_ptr+2*(last_special_line+1)+1)].cint;
+ }
+ if (looseness==0)
+ easy_line=last_special_line;
+ else
+ easy_line=max_halfword;
+
+ no_shrink_error_yet=true;
+ check_shrinkage(left_skip);
+ check_shrinkage(right_skip);
+ q=left_skip;
+ r=right_skip;
+ background[1]=width(q)+width(r);
+ background[2]=0;
+ background[3]=0;
+ background[4]=0;
+ background[5]=0;
+ background[6]=0;
+ background[2+stretch_order(q)] = stretch(q);
+ background[2+stretch_order(r)] += stretch(r);
+ background[7]=shrink(q)+shrink(r);
+ if (pdf_adjust_spacing > 1) {
+ background[8] = 0;
+ background[9] = 0;
+ max_stretch_ratio = -1;
+ max_shrink_ratio = -1;
+ cur_font_step = -1;
+ set_prev_char_p(null);
+ }
+ /* @<Check for special treatment of last line of paragraph@>;*/
+ /* The new algorithm for the last line requires that the stretchability
+ |par_fill_skip| is infinite and the stretchability of |left_skip| plus
+ |right_skip| is finite.
+ */
+ do_last_line_fit=false;
+ if (last_line_fit>0) {
+ q=glue_ptr(last_line_fill);
+ if ((stretch(q)>0)&&(stretch_order(q)>normal)) {
+ if ((background[3]==0)&&(background[4]==0)&&
+ (background[5]==0)&&(background[6]==0)) {
+ do_last_line_fit=true;
+ fill_width[0]=0;
+ fill_width[1]=0;
+ fill_width[2]=0;
+ fill_width[3]=0;
+ fill_width[stretch_order(q)-1]=stretch(q);
+ }
+ }
+ }
+ /* @<DIR: Initialize |dir_ptr| for |line_break|@> */
+ if (dir_ptr!=null) {
+ fprintf(stdout,"-dir_node s %d\n",dir_ptr);
+ flush_node_list(dir_ptr);
+ dir_ptr=null;
+ }
+ /*push_dir(paragraph_dir);*/ /* TODO what was the point of this? */
+
+ /* @<Find optimal breakpoints@>;*/
+ threshold=pretolerance;
+ if (threshold>=0) {
+ if (tracing_paragraphs>0) {
+ begin_diagnostic();
+ tprint_nl("@firstpass");
+ }
+ second_pass=false;
+ final_pass=false;
+ } else {
+ threshold=tolerance;
+ second_pass=true;
+ final_pass=(emergency_stretch<=0);
+ if (tracing_paragraphs>0)
+ begin_diagnostic();
+ }
+
+ while (1) {
+ halfword first_p;
+ halfword nest_stack[10];
+ int nest_index = 0;
+ if (threshold>inf_bad)
+ threshold=inf_bad;
+ /* Create an active breakpoint representing the beginning of the paragraph */
+ q=new_node(unhyphenated_node,decent_fit);
+ vlink(q)=active;
+ break_node(q)=null;
+ line_number(q)=cur_list.pg_field+1;
+ total_demerits(q)=0;
+ active_short(q)=0;
+ active_glue(q)=0;
+ vlink(active)=q;
+ do_all_eight(store_background);
+ passive=null;
+ printed_node=temp_head;
+ pass_number=0;
+ font_in_short_display=null_font;
+ /* /Create an active breakpoint representing the beginning of the paragraph */
+ auto_breaking=true;
+ cur_p=vlink(temp_head);
+ assert(alink(cur_p)==temp_head);
+ /* LOCAL: Initialize with first |local_paragraph| node */
+ if ((type(cur_p)==whatsit_node)&&(subtype(cur_p)==local_par_node)) {
+ internal_pen_inter=local_pen_inter(cur_p);
+ internal_pen_broken=local_pen_broken(cur_p);
+ init_internal_left_box=local_box_left(cur_p);
+ init_internal_left_box_width=local_box_left_width(cur_p);
+ internal_left_box=init_internal_left_box;
+ internal_left_box_width=init_internal_left_box_width;
+ internal_right_box=local_box_right(cur_p);
+ internal_right_box_width=local_box_right_width(cur_p);
+ } else {
+ internal_pen_inter=0;
+ internal_pen_broken=0;
+ init_internal_left_box=null;
+ init_internal_left_box_width=0;
+ internal_left_box=init_internal_left_box;
+ internal_left_box_width=init_internal_left_box_width;
+ internal_right_box=null;
+ internal_right_box_width=0;
+ }
+ /* /LOCAL: Initialize with first |local_paragraph| node */
+ set_prev_char_p (null);
+ prev_legal = null;
+ rejected_cur_p = null;
+ try_prev_break = false;
+ before_rejected_cur_p = false;
+ first_p = cur_p;
+ /* to access the first node of paragraph as the first active node
+ has |break_node=null| */
+ while ((cur_p!=null)&&(vlink(active)!=active)) {
+ /* |try_break| if |cur_p| is a legal breakpoint; on the 2nd pass, also look at disc_nodes. */
+
+ while (is_char_node(cur_p)) {
+ /* Advance \(c)|cur_p| to the node following the present string of characters ;*/
+ /* The code that passes over the characters of words in a paragraph is part of
+ \TeX's inner loop, so it has been streamlined for speed. We use the fact that
+ `\.{\\parfillskip}' glue appears at the end of each paragraph; it is therefore
+ unnecessary to check if |vlink(cur_p)=null| when |cur_p| is a character node.
+ */
+ act_width += (is_rotated(line_break_dir))
+ ? (glyph_height(cur_p)+glyph_depth(cur_p))
+ : glyph_width(cur_p);
+ if ((pdf_adjust_spacing > 1) && check_expand_pars(font(cur_p))) {
+ set_prev_char_p (cur_p);
+ add_char_stretch(active_width[8],cur_p);
+ add_char_shrink(active_width[9],cur_p);
+ }
+ cur_p=vlink(cur_p);
+ while (cur_p==null && nest_index>0) {
+ cur_p = nest_stack[--nest_index];
+ /* fprintf(stderr,"Node Pop %d [%d]\n",nest_index,(int)cur_p); */
+ }
+ }
+ if (cur_p==null) { /* TODO */
+ tconfusion("linebreak_tail");
+ }
+ /* Determine legal breaks: As we move through the hlist, we need to keep
+ the |active_width| array up to date, so that the badness of individual
+ lines is readily calculated by |try_break|. It is convenient to use the
+ short name |act_width| for the component of active width that represents
+ real width as opposed to glue. */
+
+ switch (type(cur_p)) {
+
+ case hlist_node:
+ case vlist_node:
+ act_width += (dir_orthogonal(dir_primary[box_dir(cur_p)], dir_primary[line_break_dir]))
+ ? (depth(cur_p)+height(cur_p))
+ : width(cur_p);
+ break;
+ case rule_node:
+ act_width += width(cur_p);
+ break;
+ case whatsit_node:
+ /* @<Advance \(p)past a whatsit node in the \(l)|line_break| loop@>;*/
+ switch (subtype(cur_p)) {
+ case local_par_node: /* @<LOCAL: Advance past a |local_paragraph| node@>;*/
+ internal_pen_inter=local_pen_inter(cur_p);
+ internal_pen_broken=local_pen_broken(cur_p);
+ internal_left_box=local_box_left(cur_p);
+ internal_left_box_width=local_box_left_width(cur_p);
+ internal_right_box=local_box_right(cur_p);
+ internal_right_box_width=local_box_right_width(cur_p);
+ break;
+ case dir_node: /* @<DIR: Adjust the dir stack for the |line_break| routine@>;*/
+ if (dir_dir(cur_p)>=0) {
+ line_break_dir=dir_dir(cur_p);
+ push_dir_node(cur_p);
+ } else {
+ pop_dir_node();
+ if (dir_ptr!=null)
+ line_break_dir=dir_dir(dir_ptr);
+ }
+ break;
+ case pdf_refxform_node:
+ case pdf_refximage_node:
+ act_width += pdf_width(cur_p);
+ }
+ /* / Advance \(p)past a whatsit node in the \(l)|line_break| loop/; */
+ break;
+ case glue_node:
+ /* @<If node |cur_p| is a legal breakpoint, call |try_break|;
+ then update the active widths by including the glue in
+ |glue_ptr(cur_p)|@>; */
+ /* When node |cur_p| is a glue node, we look at the previous to
+ see whether or not a breakpoint is legal at |cur_p|, as
+ explained above. */
+ if (auto_breaking) {
+ halfword prev_p = alink(cur_p);
+ if (prev_p!=temp_head &&
+ (is_char_node(prev_p) ||
+ precedes_break(prev_p)||
+ ((type(prev_p)==kern_node)&&(subtype(prev_p)!=explicit)))) {
+ ext_try_break(0,unhyphenated_node, pdf_adjust_spacing, par_shape_ptr,
+ adj_demerits, tracing_paragraphs, pdf_protrude_chars,
+ line_penalty, last_line_fit, double_hyphen_demerits,
+ final_hyphen_demerits,first_p,cur_p);
+ }
+ }
+ check_shrinkage(glue_ptr(cur_p));
+ q=glue_ptr(cur_p);
+ act_width += width(q);
+ active_width[2+stretch_order(q)] += stretch(q);
+ active_width[7] += shrink(q);
+ break;
+ case kern_node:
+ if (subtype(cur_p)==explicit) {
+ kern_break();
+ } else {
+ act_width += width(cur_p);
+ if ((pdf_adjust_spacing > 1) && (subtype(cur_p) == normal)) {
+ add_kern_stretch(active_width[8],cur_p);
+ add_kern_shrink(active_width[9],cur_p);
+ }
+ }
+ break;
+ case disc_node:
+ /* @<Try to break after a discretionary fragment, then |goto done5|@>;*/
+ /* The following code knows that discretionary texts contain
+ only character nodes, kern nodes, box nodes, and rule
+ nodes. */
+ if (second_pass) {
+ int actual_penalty = hyphen_penalty;
+ if (subtype(cur_p)==automatic_disc)
+ actual_penalty = ex_hyphen_penalty;
+ s=vlink_pre_break(cur_p);
+ do_one_seven_eight(reset_disc_width);
+ if (s==null) { /* trivial pre-break */
+ ext_try_break(actual_penalty,hyphenated_node, pdf_adjust_spacing,
+ par_shape_ptr, adj_demerits, tracing_paragraphs,
+ pdf_protrude_chars, line_penalty, last_line_fit,
+ double_hyphen_demerits, final_hyphen_demerits,first_p,cur_p);
+ } else {
+ do {
+ /* @<Add the width of node |s| to |disc_width|@>;*/
+ if (is_char_node(s)) {
+ if (is_rotated(line_break_dir)) {
+ disc_width[1] += (glyph_height(s)+glyph_depth(s));
+ } else {
+ disc_width[1] += glyph_width(s);
+ }
+ if ((pdf_adjust_spacing > 1) && check_expand_pars(font(s))) {
+ set_prev_char_p (s);
+ add_char_stretch(disc_width[8],s);
+ add_char_shrink(disc_width[9],s);
+ }
+ } else {
+ switch (type(s)) {
+ case hlist_node:
+ case vlist_node:
+ if (!(dir_orthogonal(dir_primary[box_dir(s)],
+ dir_primary[line_break_dir]))) {
+ disc_width[1] += width(s);
+ } else {
+ disc_width[1] += (depth(s)+height(s));
+ }
+ break;
+ case kern_node:
+ if ((pdf_adjust_spacing > 1) && (subtype(s) == normal)) {
+ add_kern_stretch(disc_width[8],s);
+ add_kern_shrink(disc_width[9],s);
+ }
+ /* fall through */
+ case rule_node:
+ disc_width[1] += width(s);
+ break;
+ case disc_node:
+ tconfusion("pre_break_disc");
+ break;
+ default:
+ tconfusion("disc3");
+ }
+ }
+ /* /Add the width of node |s| to |disc_width| */
+ s=vlink(s);
+ } while (s!=null);
+ do_one_seven_eight(add_disc_width_to_active_width);
+ ext_try_break(actual_penalty,hyphenated_node, pdf_adjust_spacing,
+ par_shape_ptr, adj_demerits, tracing_paragraphs,
+ pdf_protrude_chars, line_penalty, last_line_fit,
+ double_hyphen_demerits, final_hyphen_demerits,
+ first_p,cur_p);
+ do_one_seven_eight(sub_disc_width_from_active_width);
+ }
+#define FOO 1
+#if FOO
+#if 0
+ if (vlink(cur_p)!=null) nest_stack[nest_index++] = vlink(cur_p);
+ cur_p = no_break(cur_p);
+#else
+ s=vlink_no_break(cur_p);
+ while (s!=null) {
+ /* @<Add the width of node |s| to |act_width|@>;*/
+ if (is_char_node(s)) {
+ if (is_rotated(line_break_dir)) {
+ act_width += glyph_height(s)+glyph_depth(s);
+ } else {
+ act_width += glyph_width(s);
+ }
+ if ((pdf_adjust_spacing > 1) && check_expand_pars(font(s))) {
+ set_prev_char_p (s);
+ add_char_stretch(active_width[8],s);
+ add_char_shrink(active_width[9],s);
+ };
+ } else {
+ switch (type(s)) {
+ case hlist_node:
+ case vlist_node:
+ if (!(dir_orthogonal(dir_primary[box_dir(s)],
+ dir_primary[line_break_dir])))
+ act_width += width(s);
+ else
+ act_width += (depth(s)+height(s));
+ break;
+ case kern_node:
+ if ((pdf_adjust_spacing > 1) && (subtype(s) == normal)) {
+ add_kern_stretch(active_width[8],s);
+ add_kern_shrink(active_width[9],s);
+ }
+ /* fall through */
+ case rule_node:
+ act_width += width(s);
+ break;
+ case disc_node:
+ /* what now */
+ assert(vlink(s)==null); /* discs are _always_ last */
+ /* NB: temporary solution: not good, but not bad either */
+ s = no_break(s);
+ break;
+ default:
+ tconfusion("disc5");
+ }
+ }
+ /* /Add the width of node |s| to |act_width|;*/
+ s=vlink(s);
+ }
+#endif
+ } else { /* first pass, just take the no_break path */
+#else /* FOO */
+ }
+#endif /* FOO */
+#if 0
+ if (vlink_no_break(cur_p)!=null) {
+ if (vlink(cur_p)!=null) nest_stack[nest_index++] = vlink(cur_p);
+ /* fprintf(stderr,"Node Push %d [%d]->[%d] / [%d]\n",(nest_index-1),(int)cur_p,(int)vlink(cur_p),(int)vlink_no_break(cur_p));*/
+ cur_p = no_break(cur_p);
+ }
+#else
+ s=vlink_no_break(cur_p);
+ while (s!=null) {
+ /* @<Add the width of node |s| to |act_width|@>;*/
+ if (is_char_node(s)) {
+ if (is_rotated(line_break_dir)) {
+ act_width += glyph_height(s)+glyph_depth(s);
+ } else {
+ act_width += glyph_width(s);
+ }
+ if ((pdf_adjust_spacing > 1) && check_expand_pars(font(s))) {
+ set_prev_char_p (s);
+ add_char_stretch(active_width[8],s);
+ add_char_shrink(active_width[9],s);
+ };
+ } else {
+ switch (type(s)) {
+ case hlist_node:
+ case vlist_node:
+ if (!(dir_orthogonal(dir_primary[box_dir(s)],
+ dir_primary[line_break_dir])))
+ act_width += width(s);
+ else
+ act_width += (depth(s)+height(s));
+ break;
+ case kern_node:
+ if ((pdf_adjust_spacing > 1) && (subtype(s) == normal)) {
+ add_kern_stretch(active_width[8],s);
+ add_kern_shrink(active_width[9],s);
+ }
+ /* fall through */
+ case rule_node:
+ act_width += width(s);
+ break;
+ case disc_node:
+ assert(vlink(s)==null); /* discs are _always_ last */
+ s = no_break(s);
+ break;
+ default:
+ tconfusion("disc4");
+ }
+ }
+ /* /Add the width of node |s| to |act_width|;*/
+ s=vlink(s);
+ }
+#endif
+#if FOO
+ }
+#endif /* FOO */
+ break;
+ case math_node:
+ auto_breaking=(subtype(cur_p)==after);
+ kern_break();
+ break;
+ case penalty_node:
+ ext_try_break(penalty(cur_p),unhyphenated_node, pdf_adjust_spacing,
+ par_shape_ptr, adj_demerits, tracing_paragraphs,
+ pdf_protrude_chars, line_penalty, last_line_fit,
+ double_hyphen_demerits, final_hyphen_demerits,first_p,cur_p);
+ break;
+ case mark_node:
+ case ins_node:
+ case adjust_node:
+ break;
+ case glue_spec_node:
+ fprintf(stdout, "\nfound a glue_spec in a paragraph!");
+ break;
+ default:
+ fprintf(stdout, "\ntype=%d",type(cur_p));
+ tconfusion("paragraph") ;
+ }
+ cur_p=vlink(cur_p);
+ while (cur_p==null && nest_index>0) {
+ cur_p = nest_stack[--nest_index];
+ /* fprintf(stderr,"Node Pop %d [%d]\n",nest_index,(int)cur_p);*/
+ }
+ }
+ if (cur_p==null) {
+ /* Try the final line break at the end of the paragraph,
+ and |goto done| if the desired breakpoints have been found */
+
+ /* The forced line break at the paragraph's end will reduce the list of
+ breakpoints so that all active nodes represent breaks at |cur_p=null|.
+ On the first pass, we insist on finding an active node that has the
+ correct ``looseness.'' On the final pass, there will be at least one active
+ node, and we will match the desired looseness as well as we can.
+
+ The global variable |best_bet| will be set to the active node for the best
+ way to break the paragraph, and a few other variables are used to
+ help determine what is best.
+ */
+
+ ext_try_break(eject_penalty,hyphenated_node, pdf_adjust_spacing,
+ par_shape_ptr, adj_demerits, tracing_paragraphs,
+ pdf_protrude_chars,line_penalty, last_line_fit,
+ double_hyphen_demerits, final_hyphen_demerits,first_p,cur_p);
+ if (vlink(active)!=active) {
+ /* @<Find an active node with fewest demerits@>;*/
+ r=vlink(active);
+ fewest_demerits=awful_bad;
+ do {
+ if (type(r)!=delta_node) {
+ if (total_demerits(r)<fewest_demerits) {
+ fewest_demerits=total_demerits(r);
+ best_bet=r;
+ }
+ }
+ r=vlink(r);
+ } while (r!=active);
+ best_line=line_number(best_bet);
+
+ /* /Find an active node with fewest demerits;*/
+ if (looseness==0)
+ goto DONE;
+ /*@<Find the best active node for the desired looseness@>;*/
+
+ /* The adjustment for a desired looseness is a slightly more complicated
+ version of the loop just considered. Note that if a paragraph is broken
+ into segments by displayed equations, each segment will be subject to the
+ looseness calculation, independently of the other segments.
+ */
+ r=vlink(active);
+ actual_looseness=0;
+ do {
+ if (type(r)!=delta_node) {
+ line_diff=line_number(r)-best_line;
+ if (((line_diff<actual_looseness)&&(looseness<=line_diff))||
+ ((line_diff>actual_looseness)&&(looseness>=line_diff))) {
+ best_bet=r;
+ actual_looseness=line_diff;
+ fewest_demerits=total_demerits(r);
+ } else if ((line_diff==actual_looseness)&&
+ (total_demerits(r)<fewest_demerits)) {
+ best_bet=r;
+ fewest_demerits=total_demerits(r);
+ }
+ }
+ r=vlink(r);
+ } while (r!=active);
+ best_line=line_number(best_bet);
+
+ /* /Find the best active node for the desired looseness;*/
+ if ((actual_looseness==looseness)|| final_pass)
+ goto DONE;
+ }
+ }
+
+ /* Clean up the memory by removing the break nodes; */
+ clean_up_the_memory();
+ /* /Clean up the memory by removing the break nodes; */
+
+ if (!second_pass) {
+ if (tracing_paragraphs>0)
+ tprint_nl("@secondpass");
+ threshold=tolerance;
+ second_pass=true;
+ final_pass=(emergency_stretch<=0);
+ } else { /* if at first you do not succeed, \dots */
+ if (tracing_paragraphs>0)
+ tprint_nl("@emergencypass");
+ background[2] += emergency_stretch;
+ final_pass=true;
+ }
+ }
+ DONE:
+ if (tracing_paragraphs>0) {
+ end_diagnostic(true);
+ normalize_selector();
+ }
+ if (do_last_line_fit) {
+ /* Adjust \(t)the final line of the paragraph;*/
+ /* Here we either reset |do_last_line_fit| or adjust the |par_fill_skip| glue.
+ */
+ if (active_short(best_bet)==0) {
+ do_last_line_fit=false;
+ } else {
+ q=new_spec(glue_ptr(last_line_fill));
+ delete_glue_ref(glue_ptr(last_line_fill));
+ width(q) += (active_short(best_bet)-active_glue(best_bet));
+ stretch(q)=0;
+ glue_ptr(last_line_fill)=q;
+ }
+ /* /Adjust \(t)the final line of the paragraph;*/
+ }
+
+ /* @<Break the paragraph at the chosen...@>; */
+ /* Once the best sequence of breakpoints has been found (hurray), we call on the
+ procedure |post_line_break| to finish the remainder of the work.
+ (By introducing this subprocedure, we are able to keep |line_break|
+ from getting extremely long.)
+ */
+ ext_post_line_break(d,
+ right_skip,
+ left_skip,
+ pdf_protrude_chars,
+ par_shape_ptr,
+ pdf_adjust_spacing,
+ pdf_each_line_height,
+ pdf_each_line_depth,
+ pdf_first_line_height,
+ pdf_last_line_depth,
+ inter_line_penalties_ptr,
+ inter_line_penalty,
+ club_penalty,
+ club_penalties_ptr,
+ display_widow_penalties_ptr,
+ widow_penalties_ptr,
+ display_widow_penalty,
+ widow_penalty,
+ broken_penalty,
+ final_par_glue,
+ best_bet,
+ last_special_line,
+ second_width,
+ second_indent,
+ first_width,
+ first_indent,
+ best_line
+ );
+ /* /Break the paragraph at the chosen... */
+ /* Clean up the memory by removing the break nodes; */
+ clean_up_the_memory();
+ /*
+ flush_node_list(dir_ptr);
+ dir_ptr=null;
+ */
+}
+
+
diff --git a/Build/source/texk/web2c/luatexdir/tex/postlinebreak.c b/Build/source/texk/web2c/luatexdir/tex/postlinebreak.c
new file mode 100644
index 00000000000..86b9562c262
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/tex/postlinebreak.c
@@ -0,0 +1,512 @@
+/* $Id: postlinebreak.c 1078 2008-03-05 15:33:46Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "nodes.h"
+
+/* So far we have gotten a little way into the |line_break| routine, having
+covered its important |try_break| subroutine. Now let's consider the
+rest of the process.
+
+The main loop of |line_break| traverses the given hlist,
+starting at |vlink(temp_head)|, and calls |try_break| at each legal
+breakpoint. A variable called |auto_breaking| is set to true except
+within math formulas, since glue nodes are not legal breakpoints when
+they appear in formulas.
+
+The current node of interest in the hlist is pointed to by |cur_p|. Another
+variable, |prev_p|, is usually one step behind |cur_p|, but the real
+meaning of |prev_p| is this: If |type(cur_p)=glue_node| then |cur_p| is a legal
+breakpoint if and only if |auto_breaking| is true and |prev_p| does not
+point to a glue node, penalty node, explicit kern node, or math node.
+
+*/
+
+static halfword
+do_push_dir_node (halfword p, halfword a ) {
+ halfword n;
+ n = copy_node(a);
+ vlink(n) = p;
+ return n;
+}
+
+static halfword
+do_pop_dir_node ( halfword p ) {
+ halfword n = vlink(p);
+ flush_node(p);
+ return n;
+}
+
+
+/* The total number of lines that will be set by |post_line_break|
+is |best_line-prev_graf-1|. The last breakpoint is specified by
+|break_node(best_bet)|, and this passive node points to the other breakpoints
+via the |prev_break| links. The finishing-up phase starts by linking the
+relevant passive nodes in forward order, changing |prev_break| to
+|next_break|. (The |next_break| fields actually reside in the same memory
+space as the |prev_break| fields did, but we give them a new name because
+of their new significance.) Then the lines are justified, one by one.
+
+The |post_line_break| must also keep an dir stack, so that it can
+output end direction instructions at the ends of lines
+and begin direction instructions at the beginnings of lines.
+
+*/
+
+#define next_break prev_break /*new name for |prev_break| after links are reversed*/
+
+#define append_list(a,b) \
+ { vlink(cur_list.tail_field)=vlink((a)); cur_list.tail_field = b; }
+
+#define left_skip_code 7 /*glue at left of justified lines*/
+#define right_skip_code 8 /*glue at right of justified lines*/
+
+/* the ints are actually halfwords */
+void ext_post_line_break(boolean d,
+ int right_skip,
+ int left_skip,
+ int pdf_protrude_chars,
+ halfword par_shape_ptr,
+ int pdf_adjust_spacing,
+ int pdf_each_line_height,
+ int pdf_each_line_depth,
+ int pdf_first_line_height,
+ int pdf_last_line_depth,
+ halfword inter_line_penalties_ptr,
+ int inter_line_penalty,
+ int club_penalty,
+ halfword club_penalties_ptr,
+ halfword display_widow_penalties_ptr,
+ halfword widow_penalties_ptr,
+ int display_widow_penalty,
+ int widow_penalty,
+ int broken_penalty,
+ halfword final_par_glue,
+ halfword best_bet,
+ halfword last_special_line,
+ scaled second_width,
+ scaled second_indent,
+ scaled first_width,
+ scaled first_indent,
+ halfword best_line ) {
+
+ boolean have_directional = true;
+ halfword q,r,s; /* temporary registers for list manipulation */
+ halfword p, k;
+ scaled w;
+ boolean glue_break; /* was a break at glue? */
+ boolean disc_break; /*was the current break at a discretionary node?*/
+ boolean post_disc_break; /*and did it have a nonempty post-break part?*/
+ scaled cur_width; /*width of line number |cur_line|*/
+ scaled cur_indent; /*left margin of line number |cur_line|*/
+ integer pen; /*use when calculating penalties between lines */
+ halfword cur_p; /* cur_p, but localized */
+ halfword cur_line; /*the current line number being justified*/
+
+ dir_ptr = cur_list.dirs_field;
+ /* @<Reverse the links of the relevant passive nodes, setting |cur_p| to
+ the first breakpoint@>; */
+ /* The job of reversing links in a list is conveniently regarded as the job
+ of taking items off one stack and putting them on another. In this case we
+ take them off a stack pointed to by |q| and having |prev_break| fields;
+ we put them on a stack pointed to by |cur_p| and having |next_break| fields.
+ Node |r| is the passive node being moved from stack to stack.
+ */
+ q=break_node(best_bet);
+ /*used_discs = used_disc(best_bet);*/
+ /*has_direction*/
+ cur_p=null;
+ do {
+ r=q;
+ q=prev_break(q);
+ next_break(r)=cur_p;
+ cur_p=r;
+ } while (q!=null);
+ /* |cur_p| is now the first breakpoint; */
+
+ cur_line=cur_list.pg_field+1; /* prevgraf+1 */
+
+ do {
+ /* @<Justify the line ending at breakpoint |cur_p|, and append it to the
+ current vertical list, together with associated penalties and other
+ insertions@>; */
+ /* The current line to be justified appears in a horizontal list starting
+ at |vlink(temp_head)| and ending at |cur_break(cur_p)|. If |cur_break(cur_p)| is
+ a glue node, we reset the glue to equal the |right_skip| glue; otherwise
+ we append the |right_skip| glue at the right. If |cur_break(cur_p)| is a
+ discretionary node, we modify the list so that the discretionary break
+ is compulsory, and we set |disc_break| to |true|. We also append
+ the |left_skip| glue at the left of the line, unless it is zero. */
+
+#if 0
+ tprint("BEGIN OF LINE ");
+ print_int(cur_break(cur_p));
+ breadth_max=100000;
+ depth_threshold=100000;
+ show_node_list(temp_head);
+#endif
+
+ /* DIR: Insert dir nodes at the beginning of the current line;*/
+ for (q=dir_ptr;q!=null;q=vlink(q)) {
+ halfword tmp = new_dir(dir_dir(q));
+ halfword nxt = vlink(temp_head);
+ couple_nodes(temp_head,tmp);
+ couple_nodes(tmp,nxt);
+ }
+ if (dir_ptr!=null) {
+ flush_node_list(dir_ptr); dir_ptr=null;
+ }
+
+ /* Modify the end of the line to reflect the nature of the break and to
+ include \.{\\rightskip}; also set the proper value of |disc_break|; */
+ /* At the end of the following code, |q| will point to the final node on the
+ list about to be justified. In the meanwhile |r| will point to the
+ node we will use to insert end-of-line stuff after. |q==null| means
+ we use the final position of |r| */
+ r = cur_break(cur_p);
+ q = null;
+ disc_break=false;
+ post_disc_break=false;
+ glue_break = false;
+
+ if (r==null) {
+ for (r=temp_head; vlink(r)!=null; r=vlink(r));
+ if (r==final_par_glue) {
+ /* This should almost always be true... */
+ /* TODO assert ? */
+ q = r;
+ /* |q| refers to the last node of the line (and paragraph) */
+ r = alink(r);
+ }
+ /* |r| refers to the node after which the dir nodes should be closed */
+ } else if (type(r)==glue_node) {
+ delete_glue_ref(glue_ptr(r));
+ glue_ptr(r)=right_skip;
+ subtype(r)=right_skip_code+1;
+ incr(glue_ref_count(right_skip));
+ glue_break = true;
+ /* |q| refers to the last node of the line */
+ q = r;
+ r=alink(r);
+ assert(vlink(r)==q);
+ /* |r| refers to the node after which the dir nodes should be closed */
+ } else if (type(r)==disc_node) {
+ halfword a = alink(r);
+ assert(a!=null);
+ halfword v = vlink(r);
+ if (v==null) { /* nested disc, let's unfold */
+ fprintf(stderr,"Nested disc [%d]<-[%d]->null\n",(int)a,(int)r);
+ do {
+ halfword d;
+ while (alink(a)!=null) a = alink(a);
+ assert(type(a)==nesting_node);
+ assert(subtype(a)=no_break_head(0)); /* No_break */
+ d = a - subtype(a); /* MAGIC subtype is offset of nesting with disc */
+ assert(type(d)==disc_node);
+ v = vlink(d);
+ a = alink(d);
+ fprintf(stderr,"Up to disc [%d]<-[%d]->[%d] & link [%d]\n",(int)a,(int)d,(int)v,(int)vlink_no_break(d));
+ assert(a!=null);
+ couple_nodes(a,vlink_no_break(d));
+ vlink_no_break(d)=null;
+ tlink_no_break(d)=null;
+ flush_node(d);
+ } while (v==null);
+ couple_nodes(r,v);
+ fprintf(stderr,"Close list [%d]<->[%d] a=[%d]\n",(int)r,(int)v,(int)alink(r));
+ a = alink(r);
+ }
+ if (vlink_no_break(r)!=null) {
+ flush_node_list(vlink_no_break(r));
+ vlink_no_break(r)=null;
+ tlink_no_break(r)=null;
+ }
+ if (vlink_pre_break(r)!=null) {
+ couple_nodes(a,vlink_pre_break(r));
+ couple_nodes(tlink_pre_break(r),r);
+ vlink_pre_break(r)=null;
+ tlink_pre_break(r)=null;
+ }
+ if (vlink_post_break(r)!=null) {
+ couple_nodes(r,vlink_post_break(r));
+ couple_nodes(tlink_post_break(r),v);
+ vlink_post_break(r)=null;
+ tlink_post_break(r)=null;
+ post_disc_break = true;
+ }
+ disc_break=true;
+ } else if (type(r)==kern_node) {
+ width(r)=0;
+ } else if (type(r)==math_node) {
+ surround(r)=0;
+ }
+
+ /* DIR: Adjust the dir stack based on dir nodes in this line; */
+ /* TODO what about the previousparagraph ??? */
+ if (have_directional) {
+ halfword e;
+ halfword p;
+ for(e=vlink(temp_head); e!=null && e!=cur_break(cur_p); e=vlink(e)) {
+ if (type(e)!=whatsit_node || subtype(e)!=dir_node)
+ continue;
+ if (dir_dir(e)>=0) {
+ dir_ptr = do_push_dir_node(dir_ptr,e);
+ } else if (dir_ptr!=null && dir_dir(dir_ptr)==(dir_dir(e)+64)) {
+ dir_ptr = do_pop_dir_node(dir_ptr);
+ }
+ }
+ assert(e==cur_break(cur_p));
+
+ /* @<DIR: Insert dir nodes at the end of the current line@>;*/
+ e = vlink(r);
+ for (p=dir_ptr; p!=null; p=vlink(p)) {
+ halfword s=new_dir(dir_dir(p)-64);
+ couple_nodes(r,s);
+ try_couple_nodes(s,e);
+ r=s;
+ }
+ }
+ if (passive_right_box(cur_p)!=null) {
+ /* TODO: CHECK has |s| below a |alink| ? */
+ halfword s = copy_node_list(passive_right_box(cur_p));
+ halfword e = vlink(r);
+ couple_nodes(r,s);
+ try_couple_nodes(s,e);
+ r=s;
+ }
+ if (q==null) {
+ q = r;
+ }
+ /* Now [q] refers to the last node on the line */
+
+ /* FIXME from this point on we no longer keep alink() valid */
+
+ /* at this point |q| is the rightmost breakpoint; the only exception is
+ the case of a discretionary break with non-empty |pre_break|, then |q|
+ has been changed to the last node of the |pre_break| list */
+ /* If the par ends with a \break command, the last line is utterly empty.
+ That is the case of |q==temp_head| */
+ if (q!=temp_head && pdf_protrude_chars > 0) {
+ halfword ptmp;
+ if (disc_break && (is_char_node(q) || (type(q) != disc_node))) {
+ p = q; /* |q| has been reset to the last node of |pre_break| */
+ ptmp = p;
+ } else {
+ p = alink(q); /* get |vlink(p) = q| */
+ assert(vlink(p)==q);
+ ptmp = p;
+ p = find_protchar_right(vlink(temp_head), p);
+ }
+ w = char_pw(p, right_side);
+ if (w!=0) { /* we have found a marginal kern, append it after |ptmp| */
+ k = new_margin_kern(-w, last_rightmost_char, right_side);
+ vlink(k) = vlink(ptmp);
+ vlink(ptmp) = k;
+ if (ptmp == q)
+ q = vlink(q);
+ }
+ }
+ /* if |q| was not a breakpoint at glue and has been reset to |rightskip|
+ then we append |rightskip| after |q| now */
+ if (!glue_break) {
+ /* @<Put the \(r)\.{\\rightskip} glue after node |q|@>;*/
+ halfword r=new_param_glue(right_skip_code);
+ vlink(r)=vlink(q);
+ vlink(q)=r;
+ q=r;
+ }
+
+ /* /Modify the end of the line to reflect the nature of the break and to
+ include \.{\\rightskip}; also set the proper value of |disc_break|; */
+
+ /* Put the \(l)\.{\\leftskip} glue at the left and detach this line;*/
+ /* The following code begins with |q| at the end of the list to be
+ justified. It ends with |q| at the beginning of that list, and with
+ |vlink(temp_head)| pointing to the remainder of the paragraph, if any. */
+ r=vlink(q);
+ vlink(q)=null;
+
+ q=vlink(temp_head);
+ try_couple_nodes(temp_head,r);
+ if (passive_left_box(cur_p)!=null && passive_left_box(cur_p)!=0) {
+ /* omega bits: */
+ r=copy_node_list(passive_left_box(cur_p));
+ s=vlink(q);
+ vlink(r)=q;
+ q=r;
+ if ((cur_line==cur_list.pg_field+1) && (s!=null)) {
+ if (type(s)==hlist_node) {
+ if (list_ptr(s)==null) {
+ q=vlink(q);
+ vlink(r)=vlink(s);
+ vlink(s)=r;
+ }
+ }
+ }
+ }
+ /*at this point |q| is the leftmost node; all discardable nodes have been discarded */
+ if (pdf_protrude_chars > 0) {
+ p = q;
+ p = find_protchar_left(p, false); /* no more discardables */
+ w = char_pw(p, left_side);
+ if (w != 0) {
+ k = new_margin_kern(-w, last_leftmost_char, left_side);
+ vlink(k) = q;
+ q = k;
+ }
+ };
+ if (left_skip!=zero_glue) {
+ r=new_param_glue(left_skip_code);
+ vlink(r)=q;
+ q=r;
+ }
+ /* /Put the \(l)\.{\\leftskip} glue at the left and detach this line;*/
+
+ /* Call the packaging subroutine, setting |just_box| to the justified box;*/
+ /* Now |q| points to the hlist that represents the current line of the
+ paragraph. We need to compute the appropriate line width, pack the
+ line into a box of this size, and shift the box by the appropriate
+ amount of indentation. */
+ if (cur_line>last_special_line) {
+ cur_width=second_width;
+ cur_indent=second_indent;
+ } else if (par_shape_ptr==null) {
+ cur_width=first_width;
+ cur_indent=first_indent;
+ } else {
+ cur_indent=varmem[(par_shape_ptr+2*cur_line)].cint;
+ cur_width=varmem[(par_shape_ptr+2*cur_line+1)].cint;
+ }
+ adjust_tail=adjust_head;
+ pack_direction=paragraph_dir;
+ pre_adjust_tail = pre_adjust_head;
+ if (pdf_adjust_spacing > 0 ) {
+ just_box = hpack(q, cur_width, cal_expand_ratio);
+ } else {
+ just_box = hpack(q, cur_width, exactly);
+ }
+ shift_amount(just_box)=cur_indent;
+ /* /Call the packaging subroutine, setting |just_box| to the justified box;*/
+
+ /* Append the new box to the current vertical list, followed by the list of
+ special nodes taken out of the box by the packager;*/
+ if (pdf_each_line_height!=0)
+ height(just_box) = pdf_each_line_height;
+ if (pdf_each_line_depth != 0)
+ depth(just_box) = pdf_each_line_depth;
+ if ((pdf_first_line_height != 0) && (cur_line == cur_list.pg_field + 1))
+ height(just_box) = pdf_first_line_height;
+ if ((pdf_last_line_depth != 0) && (cur_line + 1 == best_line))
+ depth(just_box) = pdf_last_line_depth;
+
+ if (pre_adjust_head != pre_adjust_tail)
+ append_list(pre_adjust_head,pre_adjust_tail);
+ pre_adjust_tail = null;
+ append_to_vlist(just_box);
+ if (adjust_head != adjust_tail)
+ append_list(adjust_head,adjust_tail);
+ adjust_tail = null;
+
+ /* /Append the new box to the current vertical list, followed by the list of
+ special nodes taken out of the box by the packager;*/
+
+ /* Append a penalty node, if a nonzero penalty is appropriate */
+ /* Penalties between the lines of a paragraph come from club and widow lines,
+ from the |inter_line_penalty| parameter, and from lines that end at
+ discretionary breaks. Breaking between lines of a two-line paragraph gets
+ both club-line and widow-line penalties. The local variable |pen| will
+ be set to the sum of all relevant penalties for the current line, except
+ that the final line is never penalized. */
+ if (cur_line+1!=best_line) {
+ q=inter_line_penalties_ptr;
+ if (q!=null) {
+ r=cur_line;
+ if (r>penalty(q))
+ r=penalty(q);
+ pen=penalty(q+r);
+ } else {
+ if (passive_pen_inter(cur_p)!=0) {
+ pen=passive_pen_inter(cur_p);
+ } else {
+ pen=inter_line_penalty;
+ }
+ }
+ q=club_penalties_ptr;
+ if (q!=null) {
+ r=cur_line-cur_list.pg_field; /* prevgraf */
+ if (r>penalty(q))
+ r=penalty(q);
+ pen += penalty(q+r);
+ } else if (cur_line==cur_list.pg_field+1) { /* prevgraf */
+ pen += club_penalty;
+ }
+ if (d)
+ q = display_widow_penalties_ptr;
+ else
+ q = widow_penalties_ptr;
+ if (q!=null) {
+ r=best_line-cur_line-1;
+ if (r>penalty(q))
+ r=penalty(q);
+ pen += penalty(q+r);
+ } else if (cur_line+2==best_line) {
+ if (d)
+ pen += display_widow_penalty;
+ else
+ pen += widow_penalty;
+ }
+ if (disc_break) {
+ if (passive_pen_broken(cur_p)!=0) {
+ pen += passive_pen_broken(cur_p);
+ } else {
+ pen += broken_penalty;
+ }
+ }
+ if (pen!=0) {
+ r=new_penalty(pen);
+ couple_nodes(cur_list.tail_field,r);
+ cur_list.tail_field=r;
+ }
+ }
+ /* /Append a penalty node, if a nonzero penalty is appropriate */
+
+ /* /Justify the line ending at breakpoint |cur_p|, and append it to the
+ current vertical list, together with associated penalties and other
+ insertions@>; */
+ incr(cur_line);
+ cur_p=next_break(cur_p);
+ if (cur_p!=null && !post_disc_break) {
+ /* @<Prune unwanted nodes at the beginning of the next line@>; */
+ /* Glue and penalty and kern and math nodes are deleted at the
+ beginning of a line, except in the anomalous case that the
+ node to be deleted is actually one of the chosen
+ breakpoints. Otherwise the pruning done here is designed to
+ match the lookahead computation in |try_break|, where the
+ |break_width| values are computed for non-discretionary
+ breakpoints. */
+ r=temp_head;
+ while(1) {
+ q=vlink(r);
+ if (q==cur_break(cur_p) || is_char_node(q))
+ break;
+ if (!((type(q)==whatsit_node)&&(subtype(q)==local_par_node))) {
+ if (non_discardable(q)
+ || (type(q)==kern_node && subtype(q)!=explicit ))
+ break;
+ }
+ r=q;
+ };
+ if (r!=temp_head) {
+ vlink(r)=null;
+ flush_node_list(vlink(temp_head));
+ try_couple_nodes(temp_head,q);
+ }
+ }
+ } while (cur_p!=null);
+ if ((cur_line!=best_line)||(vlink(temp_head)!=null))
+ tconfusion("line breaking");
+ cur_list.pg_field=best_line-1; /* prevgraf */
+ cur_list.dirs_field=dir_ptr; /* dir_save */
+ dir_ptr = null;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/tex/texnodes.c b/Build/source/texk/web2c/luatexdir/tex/texnodes.c
new file mode 100644
index 00000000000..06004160503
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/tex/texnodes.c
@@ -0,0 +1,1694 @@
+/* $Id: texnodes.c 1103 2008-03-11 14:32:50Z taco $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include "nodes.h"
+
+#define MAX_CHAIN_SIZE 12
+
+volatile memory_word *varmem = NULL;
+
+#ifndef NDEBUG
+char *varmem_sizes = NULL;
+#endif
+
+halfword var_mem_max = 0;
+halfword rover = 0;
+
+halfword free_chain[MAX_CHAIN_SIZE] = {null};
+
+static int prealloc=0;
+
+int fix_node_lists=1;
+
+int free_error_seen = 0;
+int copy_error_seen = 0;
+
+halfword slow_get_node (integer s) ; /* defined below */
+int copy_error (halfword p) ; /* define below */
+
+#undef link /* defined by cpascal.h */
+#define info(a) fixmem[(a)].hhlh
+#define link(a) fixmem[(a)].hhrh
+
+#define fake_node 100
+#define fake_node_size 2
+#define fake_node_name "fake"
+
+#define variable_node_size 2
+
+
+char * node_fields_list [] = { "attr", "width", "depth", "height", "dir", "shift",
+ "glue_order", "glue_sign", "glue_set" , "list", NULL };
+char * node_fields_rule [] = { "attr", "width", "depth", "height", "dir", NULL };
+char * node_fields_insert [] = { "attr", "cost", "depth", "height", "spec", "list", NULL };
+char * node_fields_mark [] = { "attr", "class", "mark", NULL };
+char * node_fields_adjust [] = { "attr", "list", NULL };
+char * node_fields_disc [] = { "attr", "pre", "post", "replace", NULL };
+char * node_fields_math [] = { "attr", "surround", NULL };
+char * node_fields_glue [] = { "attr", "spec", "leader", NULL };
+char * node_fields_kern [] = { "attr", "kern", NULL };
+char * node_fields_penalty [] = { "attr", "penalty", NULL };
+char * node_fields_unset [] = { "attr", "width", "depth", "height", "dir", "shrink",
+ "glue_order", "glue_sign", "stretch" , "span", "list", NULL };
+char * node_fields_margin_kern [] = { "attr", "width", "glyph", NULL };
+char * node_fields_glyph [] = { "attr", "char", "font", "lang", "left", "right", "uchyph",
+ "components", "xoffset", "yoffset", NULL };
+char * node_fields_style [] = { NULL };
+char * node_fields_choice [] = { NULL };
+char * node_fields_ord [] = { NULL };
+char * node_fields_op [] = { NULL };
+char * node_fields_bin [] = { NULL };
+char * node_fields_rel [] = { NULL };
+char * node_fields_open [] = { NULL };
+char * node_fields_close [] = { NULL };
+char * node_fields_punct [] = { NULL };
+char * node_fields_inner [] = { NULL };
+char * node_fields_radical [] = { NULL };
+char * node_fields_fraction [] = { NULL };
+char * node_fields_under [] = { NULL };
+char * node_fields_over [] = { NULL };
+char * node_fields_accent [] = { NULL };
+char * node_fields_vcenter [] = { NULL };
+char * node_fields_left [] = { NULL };
+char * node_fields_right [] = { NULL };
+
+char * node_fields_inserting [] = { "height", "last_ins_ptr", "best_ins_ptr", NULL};
+
+char * node_fields_splitup [] = { "height", "last_ins_ptr", "best_ins_ptr",
+ "broken_ptr", "broken_ins", NULL};
+
+char * node_fields_action [] = { "action_type", "named_id", "action_id",
+ "file", "new_window", "data", "ref_count", NULL };
+char * node_fields_attribute [] = { "number", "value", NULL };
+char * node_fields_glue_spec [] = { "width", "stretch", "shrink",
+ "stretch_order", "shrink_order", "ref_count", NULL };
+char * node_fields_attribute_list [] = { NULL };
+
+char * node_fields_whatsit_open [] = { "attr", "stream", "name", "area", "ext", NULL };
+char * node_fields_whatsit_write [] = { "attr", "stream", "data", NULL };
+char * node_fields_whatsit_close [] = { "attr", "stream", NULL };
+char * node_fields_whatsit_special [] = { "attr", "data", NULL };
+
+char * node_fields_whatsit_local_par [] = { "attr", "pen_inter", "pen_broken", "dir",
+ "box_left", "box_left_width", "box_right", "box_right_width", NULL };
+char * node_fields_whatsit_dir [] = { "attr", "dir", "level", "dvi_ptr", "dvi_h", NULL };
+
+char * node_fields_whatsit_pdf_literal [] = { "attr", "mode", "data", NULL };
+char * node_fields_whatsit_pdf_refobj [] = { "attr", "objnum", NULL };
+char * node_fields_whatsit_pdf_refxform [] = { "attr", "width", "height", "depth", "objnum", NULL };
+char * node_fields_whatsit_pdf_refximage [] = { "attr", "width", "height", "depth", "objnum", NULL };
+char * node_fields_whatsit_pdf_annot [] = { "attr", "width", "height", "depth", "objnum", "data", NULL };
+char * node_fields_whatsit_pdf_start_link [] = { "attr", "width", "height", "depth",
+ "objnum", "link_attr", "action", NULL };
+char * node_fields_whatsit_pdf_end_link [] = { "attr", NULL };
+char * node_fields_whatsit_pdf_dest [] = { "attr", "width", "height", "depth",
+ "named_id", "dest_id", "dest_type", "xyz_zoom", "objnum", NULL };
+char * node_fields_whatsit_pdf_thread [] = { "attr", "width", "height", "depth",
+ "named_id", "thread_id", "thread_attr", NULL };
+char * node_fields_whatsit_pdf_start_thread [] = { "attr", "width", "height", "depth",
+ "named_id", "thread_id", "thread_attr", NULL };
+char * node_fields_whatsit_pdf_end_thread [] = { "attr", NULL };
+char * node_fields_whatsit_pdf_save_pos [] = { "attr", NULL };
+char * node_fields_whatsit_late_lua [] = { "attr", "reg", "data", NULL };
+char * node_fields_whatsit_close_lua [] = { "attr", "reg", NULL };
+char * node_fields_whatsit_pdf_colorstack [] = { "attr", "stack", "cmd", "data", NULL };
+char * node_fields_whatsit_pdf_setmatrix [] = { "attr", "data", NULL };
+char * node_fields_whatsit_pdf_save [] = { "attr", NULL };
+char * node_fields_whatsit_pdf_restore [] = { "attr", NULL };
+char * node_fields_whatsit_cancel_boundary [] = { "attr", NULL };
+char * node_fields_whatsit_user_defined [] = { "attr", "user_id", "type", "value", NULL };
+
+node_info node_data[] = {
+ { hlist_node, box_node_size, node_fields_list, "hlist" },
+ { vlist_node, box_node_size, node_fields_list, "vlist" },
+ { rule_node, rule_node_size, node_fields_rule, "rule" },
+ { ins_node, ins_node_size, node_fields_insert, "ins" },
+ { mark_node, mark_node_size, node_fields_mark, "mark" },
+ { adjust_node, adjust_node_size, node_fields_adjust, "adjust" },
+ { fake_node, fake_node_size, NULL, fake_node_name }, /* don't touch this! */
+ { disc_node, disc_node_size, node_fields_disc, "disc" },
+ { whatsit_node, -1, NULL, "whatsit" },
+ { math_node, math_node_size, node_fields_math, "math" },
+ { glue_node, glue_node_size, node_fields_glue, "glue" },
+ { kern_node, kern_node_size, node_fields_kern, "kern" },
+ { penalty_node, penalty_node_size, node_fields_penalty, "penalty" },
+ { unset_node, box_node_size, node_fields_unset, "unset" },
+ { style_node, style_node_size, node_fields_style, "style" },
+ { choice_node, style_node_size, node_fields_choice, "choice" },
+ { ord_noad, noad_size, node_fields_ord, "ord" },
+ { op_noad, noad_size, node_fields_op, "op" },
+ { bin_noad, noad_size, node_fields_bin, "bin" },
+ { rel_noad, noad_size, node_fields_rel, "rel" },
+ { open_noad, noad_size, node_fields_open, "open" },
+ { close_noad, noad_size, node_fields_close, "close" },
+ { punct_noad, noad_size, node_fields_punct, "punct" },
+ { inner_noad, noad_size, node_fields_inner, "inner" },
+ { radical_noad, radical_noad_size, node_fields_radical, "radical" },
+ { fraction_noad, fraction_noad_size, node_fields_fraction, "fraction" },
+ { under_noad, noad_size, node_fields_under, "under" },
+ { over_noad, noad_size, node_fields_over, "over" },
+ { accent_noad, accent_noad_size, node_fields_accent, "accent" },
+ { vcenter_noad, noad_size, node_fields_vcenter, "vcenter" },
+ { left_noad, noad_size, node_fields_left, "left" },
+ { right_noad, noad_size, node_fields_right, "right" },
+ { margin_kern_node, margin_kern_node_size, node_fields_margin_kern, "margin_kern" },
+ { glyph_node, glyph_node_size, node_fields_glyph, "glyph" }, /* 33 */
+ { align_record_node, box_node_size, NULL, "align_record" },
+ { pseudo_file_node, pseudo_file_node_size, NULL, "pseudo_file" },
+ { pseudo_line_node, variable_node_size, NULL, "pseudo_line" },
+ { inserting_node, page_ins_node_size, node_fields_inserting, "page_insert" },
+ { split_up_node, page_ins_node_size, node_fields_splitup, "split_insert" },
+ { expr_node, expr_node_size, NULL, "expr_stack" },
+ { nesting_node, nesting_node_size, NULL, "nested_list" }, /* 40 */
+ { span_node, span_node_size, NULL, "span" },
+ { attribute_node, attribute_node_size, node_fields_attribute, "attribute" },
+ { glue_spec_node, glue_spec_size, node_fields_glue_spec, "glue_spec" },
+ { attribute_list_node, attribute_node_size, node_fields_attribute_list,"attribute_list" },
+ { action_node, pdf_action_size, node_fields_action, "action" },
+ { temp_node, temp_node_size, NULL, "temp" },
+ { align_stack_node, align_stack_node_size, NULL, "align_stack" },
+ { movement_node, movement_node_size, NULL, "movement_stack" },
+ { if_node, if_node_size, NULL, "if_stack" },
+ { unhyphenated_node, active_node_size, NULL, "unhyphenated" }, /* 50 */
+ { hyphenated_node, active_node_size, NULL, "hyphenated" },
+ { delta_node, delta_node_size, NULL, "delta" },
+ { passive_node, passive_node_size, NULL, "passive" },
+ { shape_node, variable_node_size, NULL, "shape" },
+ { -1, -1, NULL, NULL }};
+
+#define last_normal_node shape_node
+
+node_info whatsit_node_data[] = {
+ { open_node, open_node_size, node_fields_whatsit_open, "open" },
+ { write_node, write_node_size, node_fields_whatsit_write, "write" },
+ { close_node, close_node_size, node_fields_whatsit_close, "close" },
+ { special_node, special_node_size, node_fields_whatsit_special, "special" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { local_par_node, local_par_size, node_fields_whatsit_local_par, "local_par" },
+ { dir_node, dir_node_size, node_fields_whatsit_dir, "dir" },
+ { pdf_literal_node, write_node_size, node_fields_whatsit_pdf_literal, "pdf_literal" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { pdf_refobj_node, pdf_refobj_node_size, node_fields_whatsit_pdf_refobj, "pdf_refobj" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { pdf_refxform_node, pdf_refxform_node_size, node_fields_whatsit_pdf_refxform, "pdf_refxform" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { pdf_refximage_node, pdf_refximage_node_size, node_fields_whatsit_pdf_refximage, "pdf_refximage" },
+ { pdf_annot_node, pdf_annot_node_size, node_fields_whatsit_pdf_annot, "pdf_annot" },
+ { pdf_start_link_node, pdf_annot_node_size, node_fields_whatsit_pdf_start_link, "pdf_start_link" },
+ { pdf_end_link_node, pdf_end_link_node_size, node_fields_whatsit_pdf_end_link, "pdf_end_link" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { pdf_dest_node, pdf_dest_node_size, node_fields_whatsit_pdf_dest, "pdf_dest" },
+ { pdf_thread_node, pdf_thread_node_size, node_fields_whatsit_pdf_thread, "pdf_thread" },
+ { pdf_start_thread_node, pdf_thread_node_size, node_fields_whatsit_pdf_start_thread,"pdf_start_thread"},
+ { pdf_end_thread_node, pdf_end_thread_node_size, node_fields_whatsit_pdf_end_thread, "pdf_end_thread" },
+ { pdf_save_pos_node, pdf_save_pos_node_size, node_fields_whatsit_pdf_save_pos, "pdf_save_pos" },
+ { pdf_thread_data_node, pdf_thread_node_size, NULL, "pdf_thread_data" },
+ { pdf_link_data_node, pdf_annot_node_size, NULL, "pdf_link_data" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { late_lua_node, write_node_size, node_fields_whatsit_late_lua, "late_lua" },
+ { close_lua_node, write_node_size, node_fields_whatsit_close_lua, "close_lua" },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { fake_node, fake_node_size, NULL, fake_node_name },
+ { pdf_colorstack_node, pdf_colorstack_node_size, node_fields_whatsit_pdf_colorstack, "pdf_colorstack" },
+ { pdf_setmatrix_node, pdf_setmatrix_node_size, node_fields_whatsit_pdf_setmatrix, "pdf_setmatrix" },
+ { pdf_save_node, pdf_save_node_size, node_fields_whatsit_pdf_save, "pdf_save" },
+ { pdf_restore_node, pdf_restore_node_size, node_fields_whatsit_pdf_restore, "pdf_restore" },
+ { cancel_boundary_node, cancel_boundary_size, node_fields_whatsit_cancel_boundary, "cancel_boundary" },
+ { user_defined_node, user_defined_node_size, node_fields_whatsit_user_defined, "user_defined" },
+ { -1, -1, NULL, NULL }};
+
+#define last_whatsit_node user_defined_node
+
+#define get_node_size(i,j) (i!=whatsit_node ? node_data[i].size : whatsit_node_data[j].size)
+#define get_node_name(i,j) (i!=whatsit_node ? node_data[i].name : whatsit_node_data[j].name)
+
+halfword
+new_node(int i, int j) {
+ register int s;
+ register halfword n;
+ s = get_node_size(i,j);
+ n = get_node(s);
+ /* it should be possible to do this memset at free_node() */
+ /* type() and subtype() will be set below, and vlink() is
+ set to null by get_node(), so we can do we clearing one
+ word less than |s| */
+ (void)memset((void *)(varmem+n+1),0, (sizeof(memory_word)*(s-1)));
+ switch (i) {
+ case glyph_node:
+ init_lang_data(n);
+ break;
+ case glue_node:
+ case kern_node:
+ case glue_spec_node:
+ break;
+ case hlist_node:
+ case vlist_node:
+ box_dir(n)=-1;
+ break;
+ case whatsit_node:
+ if (j==open_node) {
+ open_name(n) = get_nullstr();
+ open_area(n) = open_name(n);
+ open_ext(n) = open_name(n);
+ }
+ break;
+ case disc_node:
+ pre_break(n)=pre_break_head(n);
+ type(pre_break(n))= nesting_node;
+ subtype(pre_break(n))=pre_break_head(0);
+ post_break(n)=post_break_head(n);
+ type(post_break(n))= nesting_node;
+ subtype(post_break(n))=post_break_head(0);
+ no_break(n)=no_break_head(n);
+ type(no_break(n))= nesting_node;
+ subtype(no_break(n))=no_break_head(0);
+ break;
+ case rule_node:
+ depth(n)=null_flag;
+ height(n)=null_flag;
+ rule_dir(n)=-1;
+ /* fall through */
+ case unset_node:
+ width(n) = null_flag;
+ break;
+ case pseudo_line_node:
+ case shape_node:
+ /* this is a trick that makes pseudo_files slightly slower,
+ * but the overall allocation faster then an explicit test
+ * at the top of new_node().
+ */
+ free_node(n,variable_node_size);
+ n = slow_get_node(j);
+ (void)memset((void *)(varmem+n+1),0, (sizeof(memory_word)*(j-1)));
+ break;
+ default:
+ break;
+ }
+ if (nodetype_has_attributes(i)) {
+ build_attribute_list(n);
+ }
+ type(n)=i;
+ subtype(n)=j;
+ return n;
+}
+
+halfword
+raw_glyph_node(void) {
+ register halfword n;
+ n = get_node(glyph_node_size);
+ (void)memset((void *)(varmem+n+1),0, (sizeof(memory_word)*(glyph_node_size-1)));
+ type(n)=glyph_node;
+ subtype(n)=0;
+ return n;
+}
+
+halfword
+new_glyph_node(void) {
+ register halfword n;
+ n = get_node(glyph_node_size);
+ (void)memset((void *)(varmem+n+1),0, (sizeof(memory_word)*(glyph_node_size-1)));
+ type(n)=glyph_node;
+ subtype(n)=0;
+ build_attribute_list(n);
+ return n;
+}
+
+
+/* makes a duplicate of the node list that starts at |p| and returns a
+ pointer to the new list */
+
+halfword
+copy_node_list(halfword p) {
+ halfword q; /* previous position in new list */
+ halfword h = null; /* head of the list */
+ copy_error_seen = 0;
+ while (p!=null) {
+ register halfword s = copy_node(p);
+ if (h==null) {
+ h = s;
+ } else {
+ couple_nodes(q,s);
+ }
+ q=s;
+ p=vlink(p);
+ }
+ return h;
+}
+
+ /* make a dupe of a single node */
+halfword
+copy_node(const halfword p) {
+ halfword r; /* current node being fabricated for new list */
+ register halfword s; /* a helper variable for copying into variable mem */
+ register int i;
+ if (copy_error(p)) {
+ r = new_node(temp_node,0);
+ return r;
+ }
+ i = get_node_size(type(p), subtype(p));
+ r = get_node(i);
+ (void)memcpy((void *)(varmem+r),(void *)(varmem+p),(sizeof(memory_word)*i));
+
+ if (nodetype_has_attributes(type(p))) {
+ add_node_attr_ref(node_attr(p));
+ alink(r)=null; /* needs checking */
+ }
+ vlink(r)=null;
+ switch (type(p)) {
+ case glyph_node:
+ s=copy_node_list(lig_ptr(p));
+ lig_ptr(r)=s;
+ break;
+ case glue_node:
+ add_glue_ref(glue_ptr(p));
+ s=copy_node_list(leader_ptr(p));
+ leader_ptr(r)=s;
+ break;
+ case hlist_node:
+ case vlist_node:
+ case unset_node:
+ s=copy_node_list(list_ptr(p));
+ list_ptr(r)=s;
+ break;
+ case ins_node:
+ add_glue_ref(split_top_ptr(p));
+ s=copy_node_list(ins_ptr(p));
+ ins_ptr(r)=s;
+ break;
+ case margin_kern_node:
+ s=copy_node(margin_char(p));
+ margin_char(r)=s;
+ break;
+ case disc_node:
+ pre_break(r)=pre_break_head(r);
+ if (vlink_pre_break(p)!=null) {
+ s=copy_node_list(vlink_pre_break(p));
+ alink(s)=pre_break(r);
+ tlink_pre_break(r)=tail_of_list(s);
+ vlink_pre_break(r)=s;
+ } else {
+ assert(tlink(pre_break(r))==null);
+ }
+ post_break(r)=post_break_head(r);
+ if (vlink_post_break(p)!=null) {
+ s=copy_node_list(vlink_post_break(p));
+ alink(s)=post_break(r);
+ tlink_post_break(r)=tail_of_list(s);
+ vlink_post_break(r)=s;
+ } else {
+ assert(tlink_post_break(r)==null);
+ }
+ no_break(r)=no_break_head(r);
+ if (vlink(no_break(p))!=null) {
+ s=copy_node_list(vlink_no_break(p));
+ alink(s)=no_break(r);
+ tlink_no_break(r)=tail_of_list(s);
+ vlink_no_break(r)=s;
+ } else {
+ assert(tlink_no_break(r)==null);
+ }
+ break;
+ case mark_node:
+ add_token_ref(mark_ptr(p));
+ break;
+ case adjust_node:
+ s=copy_node_list(adjust_ptr(p));
+ adjust_ptr(r)=s;
+ break;
+ case glue_spec_node:
+ glue_ref_count(r)=null;
+ break;
+ case whatsit_node:
+ switch (subtype(p)) {
+ case dir_node:
+ case local_par_node:
+ break;
+ case write_node:
+ case special_node:
+ add_token_ref(write_tokens(p));
+ break;
+ case pdf_literal_node:
+ add_token_ref(pdf_literal_data(p));
+ break;
+ case pdf_colorstack_node:
+ if (pdf_colorstack_cmd(p) <= colorstack_data)
+ add_token_ref(pdf_colorstack_data(p));
+ break;
+ case pdf_setmatrix_node:
+ add_token_ref(pdf_setmatrix_data(p));
+ break;
+ case late_lua_node:
+ add_token_ref(late_lua_data(p));
+ break;
+ case pdf_annot_node:
+ add_token_ref(pdf_annot_data(p));
+ break;
+ case pdf_start_link_node:
+ if (pdf_link_attr(r) != null)
+ add_token_ref(pdf_link_attr(r));
+ add_action_ref(pdf_link_action(r));
+ break;
+ case pdf_dest_node:
+ if (pdf_dest_named_id(p) > 0)
+ add_token_ref(pdf_dest_id(p));
+ break;
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ if (pdf_thread_named_id(p) > 0)
+ add_token_ref(pdf_thread_id(p));
+ if (pdf_thread_attr(p) != null)
+ add_token_ref(pdf_thread_attr(p));
+ break;
+ case user_defined_node:
+ switch (user_node_type(p)) {
+ case 'a': add_node_attr_ref(user_node_value(p));
+ break;
+ case 't': add_token_ref(user_node_value(p));
+ break;
+ case 'n':
+ s=copy_node_list(user_node_value(p));
+ user_node_value(r)=s;
+ break;
+ }
+ break;
+ default:
+ break;
+ }
+ break;
+ }
+ return r;
+}
+
+int valid_node (halfword p) {
+ if (p>prealloc) {
+ if (p<var_mem_max) {
+ if (varmem_sizes[p]>0)
+ return 1;
+ }
+ } else {
+ return 1;
+ }
+ return 0;
+}
+
+static void
+do_free_error (halfword p) {
+ char errstr[255]= {0};
+ char *errhlp[] = {"When I tried to free the node mentioned in the error message, it turned",
+ "out it was not (or no longer) actually in use.",
+ "Errors such as these are often caused by Lua node list alteration,",
+ "but could also point to a bug in the executable. It should be safe to continue.",
+ NULL};
+
+ check_node_mem();
+ if (free_error_seen)
+ return;
+
+ halfword r = null;
+ free_error_seen = 1;
+ if (type(p)==glyph_node) {
+ snprintf(errstr,255,"Attempt to double-free glyph (%c) node %d, ignored", (int)character (p), (int)p);
+ } else {
+ snprintf(errstr,255,"Attempt to double-free %s node %d, ignored", get_node_name(type(p),subtype(p)), (int)p);
+ }
+ tex_error(errstr,errhlp);
+ for (r=prealloc+1;r<var_mem_max;r++) {
+ if (vlink(r)==p) {
+ halfword s = r;
+ while (s>prealloc && varmem_sizes[s]==0)
+ s--;
+ if (s!=null
+ && s!=prealloc
+ && s!=var_mem_max
+ && (r-s)<get_node_size(type(s),subtype(s) )
+ && alink(s)!=p ) {
+
+ if (type(s)==disc_node) {
+ fprintf(stdout," pointed to from %s node %d (vlink %d, alink %d): ",
+ get_node_name(type(s),subtype(s)), (int)s, (int)vlink(s), (int)alink(s));
+ fprintf(stdout,"pre_break(%d,%d,%d), ", (int)vlink_pre_break(s), (int)tlink(pre_break(s)), (int)alink(pre_break(s)));
+ fprintf(stdout,"post_break(%d,%d,%d), ", (int)vlink_post_break(s), (int)tlink(post_break(s)), (int)alink(post_break(s)));
+ fprintf(stdout,"no_break(%d,%d,%d)", (int)vlink_no_break(s), (int)tlink(no_break(s)), (int)alink(no_break(s)));
+ fprintf(stdout,"\n");
+ } else {
+ if (vlink(s)==p
+ || (type(s)==glyph_node && lig_ptr(s)==p)
+ || (type(s)==vlist_node && list_ptr(s)==p)
+ || (type(s)==hlist_node && list_ptr(s)==p)
+ || (type(s)==unset_node && list_ptr(s)==p)
+ || (type(s)==ins_node && ins_ptr(s)==p)
+ ) {
+ fprintf(stdout," pointed to from %s node %d (vlink %d, alink %d): ",
+ get_node_name(type(s),subtype(s)), (int)s, (int)vlink(s), (int)alink(s));
+ if (type(s)==glyph_node) {
+ fprintf(stdout,"lig_ptr(%d)", (int)lig_ptr(s));
+ } else if (type(s)==vlist_node || type(s)==hlist_node) {
+ fprintf(stdout,"list_ptr(%d)", (int)list_ptr(s));
+ }
+ fprintf(stdout,"\n");
+ } else {
+ if ((type(s)!=penalty_node)
+ && (type(s)!=math_node)
+ && (type(s)!=kern_node)
+ ) {
+ fprintf(stdout," pointed to from %s node %d\n",get_node_name(type(s),subtype(s)), (int)s);
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+int
+free_error (halfword p) {
+ assert(p>prealloc);
+ assert(p<var_mem_max);
+ if (varmem_sizes[p]==0) {
+ do_free_error(p);
+ return 1; /* double free */
+ }
+ return 0;
+}
+
+
+static void
+do_copy_error (halfword p) {
+ char errstr[255]= {0};
+ char *errhlp[] = {"When I tried to copy the node mentioned in the error message, it turned",
+ "out it was not (or no longer) actually in use.",
+ "Errors such as these are often caused by Lua node list alteration,",
+ "but could also point to a bug in the executable. It should be safe to continue.",
+ NULL};
+
+ if (copy_error_seen)
+ return;
+
+ copy_error_seen = 1;
+ if (type(p)==glyph_node) {
+ snprintf(errstr,255,"Attempt to copy free glyph (%c) node %d, ignored", (int)character (p), (int)p);
+ } else {
+ snprintf(errstr,255,"Attempt to copy free %s node %d, ignored", get_node_name(type(p),subtype(p)), (int)p);
+ }
+ tex_error(errstr,errhlp);
+}
+
+
+int
+copy_error (halfword p) {
+ assert(p>=0);
+ assert(p<var_mem_max);
+ if (p>prealloc && varmem_sizes[p]==0) {
+ do_copy_error(p);
+ return 1; /* copy free node */
+ }
+ return 0;
+}
+
+
+
+void
+flush_node (halfword p) {
+
+ if (p==null) /* legal, but no-op */
+ return;
+
+ if (free_error(p))
+ return;
+
+ switch(type(p)) {
+ case glyph_node:
+ flush_node_list(lig_ptr(p));
+ break;
+ case glue_node:
+ delete_glue_ref(glue_ptr(p));
+ flush_node_list(leader_ptr(p));
+ break;
+
+ case attribute_node:
+ case attribute_list_node:
+ case temp_node:
+ case glue_spec_node:
+ case rule_node:
+ case kern_node:
+ case math_node:
+ case penalty_node:
+ break;
+
+ case hlist_node:
+ case vlist_node:
+ case unset_node:
+ flush_node_list(list_ptr(p));
+ break;
+ case whatsit_node:
+ switch (subtype(p)) {
+
+ case dir_node:
+ break;
+ case open_node:
+ case write_node:
+ case close_node:
+ case pdf_save_node:
+ case pdf_restore_node:
+ case cancel_boundary_node:
+ case close_lua_node:
+ case pdf_refobj_node:
+ case pdf_refxform_node:
+ case pdf_refximage_node:
+ case pdf_end_link_node:
+ case pdf_end_thread_node:
+ case pdf_save_pos_node:
+ case local_par_node:
+ break;
+
+ case special_node:
+ delete_token_ref(write_tokens(p));
+ break;
+ case pdf_literal_node:
+ delete_token_ref(pdf_literal_data(p));
+ break;
+ case pdf_colorstack_node:
+ if (pdf_colorstack_cmd(p) <= colorstack_data)
+ delete_token_ref(pdf_colorstack_data(p));
+ break;
+ case pdf_setmatrix_node:
+ delete_token_ref(pdf_setmatrix_data(p));
+ break;
+ case late_lua_node:
+ delete_token_ref(late_lua_data(p));
+ break;
+ case pdf_annot_node:
+ delete_token_ref(pdf_annot_data(p));
+ break;
+
+ case pdf_link_data_node:
+ break;
+
+ case pdf_start_link_node:
+ if (pdf_link_attr(p) != null)
+ delete_token_ref(pdf_link_attr(p));
+ delete_action_ref(pdf_link_action(p));
+ break;
+ case pdf_dest_node:
+ if (pdf_dest_named_id(p) > 0)
+ delete_token_ref(pdf_dest_id(p));
+ break;
+
+ case pdf_thread_data_node:
+ break;
+
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ if (pdf_thread_named_id(p) > 0 ) delete_token_ref(pdf_thread_id(p));
+ if (pdf_thread_attr(p) != null) delete_token_ref(pdf_thread_attr(p));
+ break;
+ case user_defined_node:
+ switch( user_node_type(p)) {
+ case 'a': delete_attribute_ref(user_node_value(p)); break;
+ case 't': delete_token_ref(user_node_value(p)); break;
+ case 'n': flush_node_list(user_node_value(p)); break;
+ default: tconfusion("extuser"); break;
+ }
+ break;
+
+ default:
+ tconfusion("ext3");
+ return;
+
+ }
+ break;
+ case ins_node:
+ flush_node_list(ins_ptr(p));
+ delete_glue_ref(split_top_ptr(p));
+ break;
+ case margin_kern_node:
+ flush_node(margin_char(p));
+ break;
+ case mark_node:
+ delete_token_ref(mark_ptr(p));
+ break;
+ case disc_node:
+ flush_node_list(vlink(pre_break(p)));
+ flush_node_list(vlink(post_break(p)));
+ flush_node_list(vlink(no_break(p)));
+ break;
+ case adjust_node:
+ flush_node_list(adjust_ptr(p));
+ break;
+ case style_node:
+ break;
+ case choice_node:
+ flush_node_list(display_mlist(p));
+ flush_node_list(text_mlist(p));
+ flush_node_list(script_mlist(p));
+ flush_node_list(script_script_mlist(p));
+ break;
+ case ord_noad:
+ case op_noad:
+ case bin_noad:
+ case rel_noad:
+ case open_noad:
+ case close_noad:
+ case punct_noad:
+ case inner_noad:
+ case radical_noad:
+ case over_noad:
+ case under_noad:
+ case vcenter_noad:
+ case accent_noad:
+
+ /*
+ * if (math_type(nucleus(p))>=sub_box)
+ * flush_node_list(vinfo(nucleus(p)));
+ * if (math_type(supscr(p))>=sub_box)
+ * flush_node_list(vinfo(supscr(p)));
+ * if (math_type(subscr(p))>=sub_box)
+ * flush_node_list(vinfo(subscr(p)));
+ */
+
+ break;
+ case left_noad:
+ case right_noad:
+ break;
+ case fraction_noad:
+ flush_node_list(vinfo(numerator(p)));
+ flush_node_list(vinfo(denominator(p)));
+ break;
+ case pseudo_file_node:
+ flush_node_list(pseudo_lines(p));
+ break;
+ case pseudo_line_node:
+ case shape_node:
+ free_node(p,subtype(p));
+ return;
+ break;
+ case align_stack_node:
+ case span_node:
+ case movement_node:
+ case if_node:
+ case nesting_node:
+ case unhyphenated_node:
+ case hyphenated_node:
+ case delta_node:
+ case passive_node:
+ case action_node:
+ case inserting_node:
+ case split_up_node:
+ case expr_node:
+ break;
+ default:
+ fprintf(stdout,"flush_node: type is %d\n", type(p));
+ return;
+
+ }
+ if (nodetype_has_attributes(type(p)))
+ delete_attribute_ref(node_attr(p));
+ free_node(p,get_node_size(type(p),subtype(p)));
+ return;
+}
+
+void
+flush_node_list(halfword pp) { /* erase list of nodes starting at |p| */
+ register halfword p=pp;
+ free_error_seen = 0;
+ if (p==null) /* legal, but no-op */
+ return;
+ if (free_error(p))
+ return;
+
+ while (p!=null) {
+ register halfword q = vlink(p);
+ flush_node(p);
+ p=q;
+ }
+}
+
+static int test_count = 1;
+
+#define dorangetest(a,b,c) do { \
+ if (!(b>=0 && b<c)) { \
+ fprintf(stdout,"For node p:=%d, 0<=%d<%d (l.%d,r.%d)\n", \
+ (int)a, (int)b, (int)c, __LINE__,test_count); \
+ tconfusion("dorangetest"); \
+ } } while (0)
+
+#define dotest(a,b,c) do { \
+ if (b!=c) { \
+ fprintf(stdout,"For node p:=%d, %d==%d (l.%d,r.%d)\n", \
+ (int)a, (int)b, (int)c, __LINE__,test_count); \
+ tconfusion("dotest"); \
+ } } while (0)
+
+#define check_action_ref(a) { dorangetest(p,a,var_mem_max); }
+#define check_glue_ref(a) { dorangetest(p,a,var_mem_max); }
+#define check_attribute_ref(a) { dorangetest(p,a,var_mem_max); }
+#define check_token_ref(a) assert(1)
+
+void
+check_node (halfword p) {
+
+ switch(type(p)) {
+ case glyph_node:
+ dorangetest(p,lig_ptr(p),var_mem_max);
+ break;
+ case glue_node:
+ check_glue_ref(glue_ptr(p));
+ dorangetest(p,leader_ptr(p),var_mem_max);
+ break;
+ case hlist_node:
+ case vlist_node:
+ case unset_node:
+ case align_record_node:
+ dorangetest(p,list_ptr(p),var_mem_max);
+ break;
+ case ins_node:
+ dorangetest(p,ins_ptr(p),var_mem_max);
+ check_glue_ref(split_top_ptr(p));
+ break;
+ case whatsit_node:
+ switch (subtype(p)) {
+ case special_node:
+ check_token_ref(write_tokens(p));
+ break;
+ case pdf_literal_node:
+ check_token_ref(pdf_literal_data(p));
+ break;
+ case pdf_colorstack_node:
+ if (pdf_colorstack_cmd(p) <= colorstack_data)
+ check_token_ref(pdf_colorstack_data(p));
+ break;
+ case pdf_setmatrix_node:
+ check_token_ref(pdf_setmatrix_data(p));
+ break;
+ case late_lua_node:
+ check_token_ref(late_lua_data(p));
+ break;
+ case pdf_annot_node:
+ check_token_ref(pdf_annot_data(p));
+ break;
+ case pdf_start_link_node:
+ if (pdf_link_attr(p) != null)
+ check_token_ref(pdf_link_attr(p));
+ check_action_ref(pdf_link_action(p));
+ break;
+ case pdf_dest_node:
+ if (pdf_dest_named_id(p) > 0)
+ check_token_ref(pdf_dest_id(p));
+ break;
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ if (pdf_thread_named_id(p) > 0 ) check_token_ref(pdf_thread_id(p));
+ if (pdf_thread_attr(p) != null) check_token_ref(pdf_thread_attr(p));
+ break;
+ case user_defined_node:
+ switch( user_node_type(p)) {
+ case 'a': check_attribute_ref(user_node_value(p)); break;
+ case 't': check_token_ref(user_node_value(p)); break;
+ case 'n': dorangetest(p,user_node_value(p),var_mem_max); break;
+ default: tconfusion("extuser"); break;
+ }
+ break;
+ case dir_node:
+ case open_node:
+ case write_node:
+ case close_node:
+ case pdf_save_node:
+ case pdf_restore_node:
+ case cancel_boundary_node:
+ case close_lua_node:
+ case pdf_refobj_node:
+ case pdf_refxform_node:
+ case pdf_refximage_node:
+ case pdf_end_link_node:
+ case pdf_end_thread_node:
+ case pdf_save_pos_node:
+ case local_par_node:
+ break;
+ default:
+ tconfusion("ext3");
+ }
+ break;
+ case margin_kern_node:
+ check_node(margin_char(p));
+ break;
+ case disc_node:
+ dorangetest(p,vlink(pre_break(p)),var_mem_max);
+ dorangetest(p,vlink(post_break(p)),var_mem_max);
+ dorangetest(p,vlink(no_break(p)),var_mem_max);
+ break;
+ case adjust_node:
+ dorangetest(p,adjust_ptr(p),var_mem_max);
+ break;
+ case pseudo_file_node:
+ dorangetest(p,pseudo_lines(p),var_mem_max);
+ break;
+ case pseudo_line_node:
+ case shape_node:
+ break;
+ case choice_node:
+ dorangetest(p,display_mlist(p),var_mem_max);
+ dorangetest(p,text_mlist(p),var_mem_max);
+ dorangetest(p,script_mlist(p),var_mem_max);
+ dorangetest(p,script_script_mlist(p),var_mem_max);
+ break;
+ case fraction_noad:
+ dorangetest(p,vinfo(numerator(p)),var_mem_max);
+ dorangetest(p,vinfo(denominator(p)),var_mem_max);
+ break;
+ case rule_node:
+ case kern_node:
+ case math_node:
+ case penalty_node:
+ case mark_node:
+ case style_node:
+ case ord_noad:
+ case op_noad:
+ case bin_noad:
+ case rel_noad:
+ case open_noad:
+ case close_noad:
+ case punct_noad:
+ case inner_noad:
+ case radical_noad:
+ case over_noad:
+ case under_noad:
+ case vcenter_noad:
+ case accent_noad:
+ case left_noad:
+ case right_noad:
+ case attribute_list_node:
+ case attribute_node:
+ case glue_spec_node:
+ case temp_node:
+ case align_stack_node:
+ case movement_node:
+ case if_node:
+ case nesting_node:
+ case span_node:
+ case unhyphenated_node:
+ case hyphenated_node:
+ case delta_node:
+ case passive_node:
+ case expr_node:
+ break;
+ default:
+ fprintf(stdout,"check_node: type is %d\n", type(p));
+ }
+}
+
+void
+check_static_node_mem (void) {
+ dotest(zero_glue,width(zero_glue),0);
+ dotest(zero_glue,type(zero_glue),glue_spec_node);
+ dotest(zero_glue,vlink(zero_glue),null);
+ dotest(zero_glue,stretch(zero_glue),0);
+ dotest(zero_glue,stretch_order(zero_glue),normal);
+ dotest(zero_glue,shrink(zero_glue),0);
+ dotest(zero_glue,shrink_order(zero_glue),normal);
+
+ dotest(sfi_glue,width(sfi_glue),0);
+ dotest(sfi_glue,type(sfi_glue),glue_spec_node);
+ dotest(sfi_glue,vlink(sfi_glue),null);
+ dotest(sfi_glue,stretch(sfi_glue),0);
+ dotest(sfi_glue,stretch_order(sfi_glue),sfi);
+ dotest(sfi_glue,shrink(sfi_glue),0);
+ dotest(sfi_glue,shrink_order(sfi_glue),normal);
+
+ dotest(fil_glue,width(fil_glue),0);
+ dotest(fil_glue,type(fil_glue),glue_spec_node);
+ dotest(fil_glue,vlink(fil_glue),null);
+ dotest(fil_glue,stretch(fil_glue),unity);
+ dotest(fil_glue,stretch_order(fil_glue),fil);
+ dotest(fil_glue,shrink(fil_glue),0);
+ dotest(fil_glue,shrink_order(fil_glue),normal);
+
+ dotest(fill_glue,width(fill_glue),0);
+ dotest(fill_glue,type(fill_glue),glue_spec_node);
+ dotest(fill_glue,vlink(fill_glue),null);
+ dotest(fill_glue,stretch(fill_glue),unity);
+ dotest(fill_glue,stretch_order(fill_glue),fill);
+ dotest(fill_glue,shrink(fill_glue),0);
+ dotest(fill_glue,shrink_order(fill_glue),normal);
+
+ dotest(ss_glue,width(ss_glue),0);
+ dotest(ss_glue,type(ss_glue),glue_spec_node);
+ dotest(ss_glue,vlink(ss_glue),null);
+ dotest(ss_glue,stretch(ss_glue),unity);
+ dotest(ss_glue,stretch_order(ss_glue),fil);
+ dotest(ss_glue,shrink(ss_glue),unity);
+ dotest(ss_glue,shrink_order(ss_glue),fil);
+
+ dotest(fil_neg_glue,width(fil_neg_glue),0);
+ dotest(fil_neg_glue,type(fil_neg_glue),glue_spec_node);
+ dotest(fil_neg_glue,vlink(fil_neg_glue),null);
+ dotest(fil_neg_glue,stretch(fil_neg_glue),-unity);
+ dotest(fil_neg_glue,stretch_order(fil_neg_glue),fil);
+ dotest(fil_neg_glue,shrink(fil_neg_glue),0);
+ dotest(fil_neg_glue,shrink_order(fil_neg_glue),normal);
+}
+
+void
+check_node_mem(void ) {
+ int i;
+ check_static_node_mem();
+
+ for (i=(prealloc+1);i<var_mem_max;i++) {
+ if (varmem_sizes[i]>0) {
+ check_node(i);
+ }
+ }
+ test_count++;
+}
+
+void
+fix_node_list (halfword head) {
+ halfword p,q;
+ if (head==null)
+ return;
+ p = head;
+ q = vlink(p);
+ while (q!=null) {
+ alink(q) = p;
+ p = q;
+ q = vlink(p);
+ }
+}
+
+halfword
+get_node (integer s) {
+ register halfword r;
+
+ /*check_static_node_mem();*/
+ assert(s<MAX_CHAIN_SIZE);
+
+ r = free_chain[s];
+ if (r!=null) {
+ free_chain[s] = vlink(r);
+#ifndef NDEBUG
+ varmem_sizes[r] = s;
+#endif
+ vlink(r)=null;
+ var_used += s; /* maintain usage statistics */
+ return r;
+ }
+ /* this is the end of the 'inner loop' */
+ return slow_get_node(s);
+}
+
+void print_free_chain (int c) {
+ halfword p = free_chain[c];
+ fprintf(stdout, "\nfree chain[%d] =\n ",c);
+ while (p!=null) {
+ fprintf(stdout, "%d,",p);
+ p = vlink(p);
+ }
+ fprintf(stdout, "null;\n");
+}
+
+void
+free_node (halfword p, integer s) {
+
+ if (p<=prealloc) {
+ fprintf(stdout,"node %d (type %d) should not be freed!\n",(int)p, type(p));
+ return;
+ }
+
+#ifndef NDEBUG
+ varmem_sizes[p] = 0;
+#endif
+ if (s<MAX_CHAIN_SIZE) {
+ vlink(p) = free_chain[s];
+ free_chain[s] = p;
+ } else {
+ /* todo ? it is perhaps possible to merge this node with an existing rover */
+ node_size(p)=s;
+ vlink(p) = rover;
+ while (vlink(rover)!=vlink(p)){
+ rover=vlink(rover);
+ }
+ vlink(rover) = p;
+ }
+ var_used -= s; /* maintain statistics */
+}
+
+void
+free_node_chain (halfword q, integer s) {
+ register halfword p = q;
+ while (vlink(p)!=null) {
+#ifndef NDEBUG
+ varmem_sizes[p] = 0;
+#endif
+ var_used -= s;
+ p = vlink(p);
+ }
+ var_used -= s;
+#ifndef NDEBUG
+ varmem_sizes[p] = 0;
+#endif
+ vlink(p) = free_chain[s];
+ free_chain[s] = q;
+}
+
+
+void
+init_node_mem (halfword prealloced, halfword t) {
+ prealloc=prealloced;
+ assert(whatsit_node_data[user_defined_node].id==user_defined_node);
+ assert(node_data[passive_node].id==passive_node);
+
+ varmem = (memory_word *)realloc((void *)varmem,sizeof(memory_word)*t);
+ if (varmem==NULL) {
+ overflow_string("node memory size",var_mem_max);
+ }
+ memset ((void *)(varmem),0,t*sizeof(memory_word));
+
+#ifndef NDEBUG
+ varmem_sizes = (char *)realloc(varmem_sizes,sizeof(char)*t);
+ if (varmem_sizes==NULL) {
+ overflow_string("node memory size",var_mem_max);
+ }
+ memset ((void *)varmem_sizes,0,sizeof(char)*t);
+#endif
+ var_mem_max=t;
+ rover = prealloced+1; vlink(rover) = rover;
+ node_size(rover)=(t-rover);
+ var_used = 0;
+}
+
+void
+dump_node_mem (void) {
+ dump_int(var_mem_max);
+ dump_int(rover);
+ dump_things(varmem[0],var_mem_max);
+#ifndef NDEBUG
+ dump_things(varmem_sizes[0],var_mem_max);
+#endif
+ dump_things(free_chain[0],MAX_CHAIN_SIZE);
+ dump_int(var_used);
+ dump_int(prealloc);
+}
+
+/* it makes sense to enlarge the varmem array immediately */
+
+void
+undump_node_mem (void) {
+ int x;
+ undump_int(x);
+ undump_int(rover);
+ var_mem_max = (x<100000 ? 100000 : x);
+ varmem = xmallocarray (memory_word, var_mem_max);
+ /*memset ((void *)varmem,0,x*sizeof(memory_word));*/
+ undump_things(varmem[0],x);
+#ifndef NDEBUG
+ varmem_sizes = xmallocarray (char, var_mem_max);
+ memset ((void *)varmem_sizes,0,var_mem_max*sizeof(char));
+ undump_things(varmem_sizes[0],x);
+#endif
+ undump_things(free_chain[0],MAX_CHAIN_SIZE);
+ undump_int(var_used);
+ undump_int(prealloc);
+ if (var_mem_max>x) {
+ /* todo ? it is perhaps possible to merge the new node with an existing rover */
+ vlink (x) = rover;
+ node_size(x) = (var_mem_max-x);
+ while(vlink(rover)!=vlink(x)) {rover=vlink(rover);}
+ vlink (rover) = x;
+ }
+}
+
+#if 0
+void test_rovers (char *s) {
+ int q = rover;
+ int r = q;
+ fprintf(stdout,"%s: {rover=%d,size=%d,link=%d}",s,r,node_size(r),vlink(r));
+ while (vlink(r)!=q) {
+ r = vlink(r);
+ fprintf(stdout,",{rover=%d,size=%d,link=%d}",r,node_size(r),vlink(r));
+ }
+ fprintf(stdout,"\n");
+}
+#else
+#define test_rovers(a)
+#endif
+
+halfword
+slow_get_node (integer s) {
+ register int t;
+
+ RETRY:
+ t = node_size(rover);
+ assert(vlink(rover)<var_mem_max);
+ assert(vlink(rover)!=0);
+ test_rovers("entry");
+ if (t>s) {
+ register halfword r;
+ /* allocating from the bottom helps decrease page faults */
+ r = rover;
+ rover += s;
+ vlink(rover)=vlink(r);
+ node_size(rover) = node_size(r) - s;
+ if (vlink(rover)!=r) { /* list is longer than one */
+ halfword q = r;
+ while (vlink(q)!=r) { q=vlink(q);}
+ vlink(q) += s;
+ } else {
+ vlink(rover) += s;
+ }
+ test_rovers("taken");
+ assert(vlink(rover)<var_mem_max);
+#ifndef NDEBUG
+ varmem_sizes[r]=(s>127 ? 127 : s);
+#endif
+ vlink(r)=null;
+ var_used += s; /* maintain usage statistics */
+ return r; /* this is the only exit */
+ } else {
+ int x;
+ /* attempt to keep the free list small */
+ if (vlink(rover)!=rover) {
+ if (t<MAX_CHAIN_SIZE) {
+ halfword l = vlink(rover);
+ vlink(rover) = free_chain[t];
+ free_chain[t] = rover;
+ rover = l;
+ while (vlink(l)!=free_chain[t]) { l=vlink(l); }
+ vlink(l) = rover;
+ test_rovers("outtake");
+ goto RETRY;
+ } else {
+ halfword l = rover;
+ while (vlink(rover)!=l) {
+ if (node_size(rover)>s) {
+ goto RETRY;
+ }
+ rover=vlink(rover);
+ }
+ }
+ }
+ /* if we are still here, it was apparently impossible to get a match */
+ x = (var_mem_max>>2)+s;
+ varmem = (memory_word *)realloc((void *)varmem,sizeof(memory_word)*(var_mem_max+x));
+ if (varmem==NULL) {
+ overflow_string("node memory size",var_mem_max);
+ }
+ memset ((void *)(varmem+var_mem_max),0,x*sizeof(memory_word));
+
+#ifndef NDEBUG
+ varmem_sizes = (char *)realloc(varmem_sizes,sizeof(char)*(var_mem_max+x));
+ if (varmem_sizes==NULL) {
+ overflow_string("node memory size",var_mem_max);
+ }
+ memset ((void *)(varmem_sizes+var_mem_max),0,x*sizeof(char));
+#endif
+
+ /* todo ? it is perhaps possible to merge the new memory with an existing rover */
+ vlink(var_mem_max) = rover;
+ node_size(var_mem_max) = x;
+ while(vlink(rover)!=vlink(var_mem_max)) {rover=vlink(rover);}
+ vlink (rover) = var_mem_max;
+ rover = var_mem_max;
+ test_rovers("realloc");
+ var_mem_max += x;
+ goto RETRY;
+ }
+}
+
+char *
+sprint_node_mem_usage (void) {
+ int i,b;
+
+ char *s, *ss;
+ char msg[256];
+ int node_counts[last_normal_node+last_whatsit_node+2] = {0};
+
+ for (i=(var_mem_max-1);i>prealloc;i--) {
+ if (varmem_sizes[i]>0) {
+ if (type(i)>last_normal_node+last_whatsit_node) {
+ node_counts[last_normal_node+last_whatsit_node+1] ++;
+ } else if (type(i)==whatsit_node){
+ node_counts[(subtype(i)+last_normal_node+1)] ++;
+ } else {
+ node_counts[type(i)] ++;
+ }
+ }
+ }
+ s = strdup("");
+ b=0;
+ for (i=0;i<last_normal_node+last_whatsit_node+2;i++) {
+ if (node_counts[i]>0) {
+ int j = (i>(last_normal_node+1) ? (i-last_normal_node-1) : 0);
+ snprintf(msg,255,"%s%d %s",(b ? ", " : ""),
+ (int)node_counts[i],
+ get_node_name((i>last_normal_node ? whatsit_node : i),j));
+ ss = concat(s,msg);
+ free (s);
+ s = ss;
+ b=1;
+ }
+ }
+ return s;
+}
+
+halfword
+list_node_mem_usage (void) {
+ halfword i, j;
+ halfword p = null,q = null;
+ char *saved_varmem_sizes = xmallocarray (char, var_mem_max);
+ memcpy (saved_varmem_sizes,varmem_sizes,var_mem_max);
+ for (i=prealloc+1;i<(var_mem_max-1);i++) {
+ if (saved_varmem_sizes[i]>0) {
+ j = copy_node(i);
+ if (p==null) {
+ q = j;
+ } else {
+ vlink(p)=j;
+ }
+ p = j;
+ }
+ }
+ free(saved_varmem_sizes);
+ return q;
+}
+
+void
+print_node_mem_stats (int num, int online) {
+ int i,b;
+ halfword j;
+ char msg[256];
+ char *s;
+ integer free_chain_counts[MAX_CHAIN_SIZE] = {0};
+
+ snprintf(msg,255,"node memory in use: %d words out of %d", (int)(var_used+prealloc), (int)var_mem_max);
+ tprint_nl(msg);
+ tprint_nl("rapidly available: ");
+ b=0;
+ for (i=1;i<MAX_CHAIN_SIZE;i++) {
+ for(j = free_chain[i];j!=null;j = vlink(j))
+ free_chain_counts[i] ++;
+ if (free_chain_counts[i]>0) {
+ snprintf(msg,255,"%s%d:%d",(b ? ", " : ""),i, (int)free_chain_counts[i]);
+ tprint(msg);
+ b=1;
+ }
+ }
+ tprint(" nodes");
+ s = sprint_node_mem_usage();
+ tprint_nl("current usage: ");
+ tprint(s); free(s);
+ tprint(" nodes");
+ print_nlp(); /* newline, if needed */
+}
+
+/* this belongs in the web but i couldn't find the correct syntactic place */
+
+halfword
+new_span_node(halfword n, int s, scaled w) {
+ halfword p=new_node(span_node,0);
+ span_link(p)=n;
+ span_span(p)=s;
+ width(p)=w;
+ return p;
+}
+
+halfword
+string_to_pseudo(integer l,integer pool_ptr, integer nl) {
+ halfword i, r, q = null;
+ four_quarters w;
+ int sz;
+ halfword h = new_node(pseudo_file_node,0);
+ while (l<pool_ptr) {
+ int m = l;
+ while ((l<pool_ptr)&&(str_pool[l]!=nl)) l++;
+ sz = (l-m+7) / 4;
+ if (sz==1)
+ sz=2;
+ r = new_node(pseudo_line_node,sz);
+ i = r;
+ while (--sz>1) {
+ w.b0=str_pool[m++];
+ w.b1=str_pool[m++];
+ w.b2=str_pool[m++];
+ w.b3=str_pool[m++];
+ varmem[++i].qqqq=w;
+ }
+ w.b0 = (l>m ? str_pool[m++] : ' ');
+ w.b1 = (l>m ? str_pool[m++] : ' ');
+ w.b2 = (l>m ? str_pool[m++] : ' ');
+ w.b3 = (l>m ? str_pool[m] : ' ');
+ varmem[++i].qqqq=w;
+ if (pseudo_lines(h)==null) {
+ pseudo_lines(h) = r;
+ q = r;
+ } else {
+ couple_nodes(q,r);
+ }
+ q = vlink(q);
+ if (str_pool[l]==nl) l++;
+ }
+ return h;
+}
+
+/* attribute stuff */
+
+static halfword
+new_attribute_node (unsigned int i, int v) {
+ register halfword r = get_node(attribute_node_size);
+ type(r) = attribute_node;
+ attribute_id(r)= i;
+ attribute_value(r)= v;
+ return r;
+}
+
+halfword
+copy_attribute_list(halfword n) {
+ halfword q = get_node(attribute_node_size);
+ register halfword p = q;
+ type(p) = attribute_list_node;
+ attr_list_ref(p)=0;
+ n = vlink(n);
+ while (n!=null) {
+ register halfword r = get_node(attribute_node_size);
+ /* the link will be fixed automatically in the next loop */
+ (void)memcpy((void *)(varmem+r),(void *)(varmem+n),(sizeof(memory_word)*attribute_node_size));
+ vlink(p) = r;
+ p = r;
+ n = vlink(n);
+ }
+ return q;
+}
+
+void
+update_attribute_cache(void) {
+ halfword p;
+ register int i;
+ attr_list_cache=get_node(attribute_node_size);
+ type(attr_list_cache) = attribute_list_node;
+ attr_list_ref(attr_list_cache)=0;
+ p=attr_list_cache;
+ for (i=0;i<=max_used_attr;i++) {
+ register int v = get_attribute(i);
+ if (v>=0) {
+ register halfword r = new_attribute_node(i,v);
+ vlink(p)=r;
+ p=r;
+ }
+ }
+ if (vlink(attr_list_cache)==null) {
+ free_node(attr_list_cache,attribute_node_size);
+ attr_list_cache = null;
+ }
+ return;
+}
+
+void
+build_attribute_list(halfword b) {
+ if (max_used_attr>=0) {
+ if (attr_list_cache==cache_disabled) {
+ update_attribute_cache();
+ if (attr_list_cache == null)
+ return;
+ }
+ attr_list_ref(attr_list_cache)++;
+ node_attr(b)=attr_list_cache;
+ }
+}
+
+void
+delete_attribute_ref(halfword b) {
+ if (b!=null){
+ assert(type(b)==attribute_list_node);
+ attr_list_ref(b)--;
+ if (attr_list_ref(b)==0) {
+ if (b==attr_list_cache)
+ attr_list_cache=cache_disabled;
+ free_node_chain(b,attribute_node_size);
+ }
+ /* maintain sanity */
+ if (attr_list_ref(b)<0)
+ attr_list_ref(b)=0;
+ }
+}
+
+/* |p| is an attr list head, or zero */
+
+halfword
+do_set_attribute (halfword p, int i, int val) {
+ register halfword q;
+ register int j = 0;
+ if (p==null) { /* add a new head & node */
+ q = get_node(attribute_node_size);
+ type(q) = attribute_list_node;
+ attr_list_ref(q)=1;
+ p = new_attribute_node(i,val);
+ vlink(q)=p;
+ return q;
+ }
+
+ assert(vlink(p)!=null);
+ while (vlink(p)!=null) {
+ int t = attribute_id(vlink(p));
+ if (t==i && attribute_value(vlink(p))==val)
+ return q; /* no need to do anything */
+ if (t>=i)
+ break;
+ j++;
+ p = vlink(p);
+ }
+
+ p = q;
+ while (j-->0) p = vlink(p);
+ if (attribute_id(vlink(p))==i) {
+ attribute_value(vlink(p))=val;
+ } else { /* add a new node */
+ halfword r = new_attribute_node(i,val);
+ vlink(r)=vlink(p);
+ vlink(p)=r;
+ }
+ return q;
+}
+
+void
+set_attribute (halfword n, int i, int val) {
+ register halfword p;
+ register int j = 0;
+ if (!nodetype_has_attributes(type(n)))
+ return;
+ p = node_attr(n);
+ if (p==null) { /* add a new head & node */
+ p = get_node(attribute_node_size);
+ type(p) = attribute_list_node;
+ attr_list_ref(p)=1;
+ node_attr(n) = p ;
+ p = new_attribute_node(i,val);
+ vlink(node_attr(n))=p;
+ return;
+ }
+ assert(vlink(p)!=null);
+ while (vlink(p)!=null) {
+ int t = attribute_id(vlink(p));
+ if (t==i && attribute_value(vlink(p))==val)
+ return;
+ if (t>=i)
+ break;
+ j++;
+ p = vlink(p);
+ }
+ p = node_attr(n);
+ if (attr_list_ref(p)!=1) {
+ if (attr_list_ref(p)>1) {
+ p = copy_attribute_list (p);
+ delete_attribute_ref(node_attr(n));
+ node_attr(n) = p;
+ } else {
+ fprintf(stdout,"Node %d has an attribute list that is free already\n",(int)n);
+ }
+ attr_list_ref(p)=1;
+ }
+ while (j-->0) p = vlink(p);
+
+ if (attribute_id(vlink(p))==i) {
+ attribute_value(vlink(p))=val;
+ } else { /* add a new node */
+ halfword r = new_attribute_node(i,val);
+ vlink(r)=vlink(p);
+ vlink(p)=r;
+ }
+ return;
+}
+
+
+int
+unset_attribute (halfword n, int i, int val) {
+ register halfword p;
+ register int t;
+ register int j = 0;
+
+ if (!nodetype_has_attributes(type(n)))
+ return null;
+ p = node_attr(n);
+ if (p==null)
+ return -1;
+ assert (vlink(p)!=null);
+ while (vlink(p)!=null) {
+ t = attribute_id(vlink(p));
+ if (t>i)
+ return -1;
+ if (t==i)
+ break;
+ j++;
+ p = vlink(p);
+ }
+ /* if we are still here, the attribute exists */
+ p = node_attr(n);
+ if (attr_list_ref(p)!=1) {
+ if (attr_list_ref(p)>1) {
+ p = copy_attribute_list (p);
+ delete_attribute_ref(node_attr(n));
+ node_attr(n) = p;
+ } else {
+ fprintf(stdout,"Node %d has an attribute list that is free already\n",(int)n);
+ }
+ attr_list_ref(p)=1;
+ }
+ p = vlink(p);
+ while (j-->0) p = vlink(p);
+ t = attribute_value(p);
+ if (val==-1 || t==val) {
+ attribute_value(p)=-1;
+ }
+ return t;
+}
+
+int
+has_attribute (halfword n,int i, int val) {
+ register halfword p;
+ if (!nodetype_has_attributes(type(n)))
+ return -1;
+ p = node_attr(n);
+ if (p==null || vlink(p)==null)
+ return -1;
+ p = vlink(p);
+ while (p!=null) {
+ if (attribute_id(p)==i) {
+ int ret = attribute_value(p);
+ if (val==-1 || val==ret)
+ return ret;
+ return -1;
+ } else if (attribute_id(p)>i) {
+ return -1;
+ }
+ p=vlink(p);
+ }
+ return -1;
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/tex/texpdf.c b/Build/source/texk/web2c/luatexdir/tex/texpdf.c
new file mode 100644
index 00000000000..fbb4c2b7e21
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/tex/texpdf.c
@@ -0,0 +1,169 @@
+/* $Id: texpdf.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include <ctype.h>
+
+#define number_chars 1114112
+#define string_offset 2097152
+#define str_start_macro(a) str_start[(a) - string_offset]
+#define str_length(a) (str_start_macro((a)+1)-str_start_macro(a)) /* the number of characters in string number (a) */
+
+#define is_hex_char isxdigit
+
+/* output a byte to PDF buffer without checking of overflow */
+
+#define pdf_quick_out(a) pdf_buf[pdf_ptr++] = a
+
+/* make sure that there are at least |n| bytes free in PDF buffer */
+
+#define pdf_room(a) do { \
+ if ((pdf_os_mode) && ((a) + pdf_ptr > pdf_buf_size)) \
+ pdf_os_get_os_buf(a); \
+ else if ((!pdf_os_mode) && ((a) > pdf_buf_size) ) \
+ overflow("PDF output buffer", pdf_op_buf_size); \
+ else if ((!pdf_os_mode) && ((a) + pdf_ptr > pdf_buf_size)) \
+ pdf_flush(); \
+ } while (0)
+
+/* do the same as |pdf_quick_out| and flush the PDF buffer if necessary */
+
+#define pdf_out(a) do { \
+ pdf_room(1); \
+ pdf_quick_out(a); \
+ } while (0)
+
+
+/* print out a character to PDF buffer; the character will be printed in octal
+ * form in the following cases: chars <= 32, backslash (92), left parenthesis
+ * (40) and right parenthesis (41)
+ */
+
+#define pdf_print_escaped(c) \
+ if ((c)<=32||(c)=='\\'||(c)=='('||(c)==')'||(c)>127) { \
+ pdf_room(4); \
+ pdf_quick_out('\\'); \
+ pdf_quick_out('0' + (((c)>>6) & 0x3)); \
+ pdf_quick_out('0' + (((c)>>3) & 0x7)); \
+ pdf_quick_out('0' + ( (c) & 0x7)); \
+ } else { \
+ pdf_out((c)); \
+ }
+
+void
+pdf_print_char(internal_font_number f, integer cc) {
+ register int c;
+ pdf_mark_char(f, cc);
+ if (font_encodingbytes(f)==2) {
+ register int chari;
+ chari = char_index(f, cc);
+ c = chari >> 8;
+ pdf_print_escaped(c);
+ c = chari & 0xFF;
+ } else {
+ if (cc>255) return;
+ c = cc;
+ }
+ pdf_print_escaped(c);
+}
+
+/* print out a string to PDF buffer */
+
+void
+pdf_print(str_number s) {
+ if (s < number_chars) {
+ assert(s<256);
+ pdf_out(s);
+ } else {
+ register pool_pointer j = str_start_macro(s);
+ while (j < str_start_macro(s + 1)) {
+ pdf_out(str_pool[j++]);
+ }
+ }
+}
+
+/* print out a integer to PDF buffer */
+
+void
+pdf_print_int(integer n) {
+ register integer k = 0; /* current digit; we assume that $|n|<10^{23}$ */
+ if (n<0) {
+ pdf_out('-');
+ if (n<-0x7FFFFFFF) { /* need to negate |n| more carefully */
+ register integer m;
+ k++;
+ m =-1-n; n=m / 10; m= (m % 10)+1;
+ if (m<10) {
+ dig[0]=m ;
+ } else {
+ dig[0]=0; incr(n);
+ }
+ } else {
+ n = -n;
+ }
+ }
+ do {
+ dig[k++] = n % 10;
+ n = n / 10;
+ } while (n!=0);
+ pdf_room(k);
+ while (k-->0) {
+ pdf_quick_out('0'+dig[k]);
+ }
+}
+
+
+/* print $m/10^d$ as real */
+void
+pdf_print_real(integer m, integer d) {
+ if (m < 0) {
+ pdf_out('-');
+ m = -m;
+ };
+ pdf_print_int(m / ten_pow[d]);
+ m = m % ten_pow[d];
+ if (m > 0) {
+ pdf_out('.');
+ d--;
+ while (m < ten_pow[d]) {
+ pdf_out('0');
+ d--;
+ }
+ while (m % 10 == 0)
+ m = m / 10;
+ pdf_print_int(m);
+ }
+}
+
+/* print out |s| as string in PDF output */
+
+void
+pdf_print_str(str_number s) {
+ pool_pointer i, j;
+ i = str_start_macro(s);
+ j = str_start_macro(s+1) - 1;
+ if (i > j) {
+ pdf_room(2);
+ pdf_quick_out('(');
+ pdf_quick_out(')');
+ return;
+ }
+ /* the next is not really safe, the string could be "(a)xx(b)" */
+ if ((str_pool[i] == '(') && (str_pool[j] == ')')) {
+ pdf_print(s);
+ return;
+ }
+ if ((str_pool[i] != '<') || (str_pool[j] != '>') || odd(str_length(s))) {
+ pdf_out('('); pdf_print(s); pdf_out(')');
+ return;
+ }
+ i++;
+ j--;
+ while (i < j) {
+ if (!is_hex_char(str_pool[i++])) {
+ pdf_out('('); pdf_print(s); pdf_out(')');
+ return;
+ }
+ }
+ pdf_print(s); /* it was a hex string after all */
+}
diff --git a/Build/source/texk/web2c/luatexdir/tex/textoken.c b/Build/source/texk/web2c/luatexdir/tex/textoken.c
new file mode 100644
index 00000000000..20c57b9479b
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/tex/textoken.c
@@ -0,0 +1,753 @@
+/* $Id: textoken.c 1013 2008-02-14 00:09:02Z oneiros $ */
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+
+#include "tokens.h"
+
+/* Integer parameters and other command-related defines. This needs it's own header file! */
+
+#define end_line_char_code 48 /* character placed at the right end of the buffer */
+#define cat_code_table_code 63
+#define tex_int_pars 66 /* total number of \.{\\TeX} + Aleph integer parameters */
+/* this is not what happens in the pascal code! there the values shift from bare numbers to offsets ! */
+#define dir_base tex_int_pars
+#define dir_pars 5
+#define pdftex_first_integer_code dir_base+dir_pars /* base for \pdfTeX's integer parameters */
+#define pdf_int_pars pdftex_first_integer_code+27 /*total number of \pdfTeX's integer parameters*/
+#define etex_int_base pdf_int_pars /*base for \eTeX's integer parameters*/
+#define tracing_nesting_code etex_int_base+4 /*show incomplete groups and ifs within files*/
+
+#define int_par(a) zeqtb[static_int_base+a].cint /* an integer parameter */
+#define cat_code_table int_par(cat_code_table_code)
+#define tracing_nesting int_par(tracing_nesting_code)
+#define end_line_char int_par(end_line_char_code)
+
+#define every_eof get_every_eof()
+
+#define number_active_chars 65536+65536
+#define active_base 1 /* beginning of region 1, for active character equivalents */
+#define null_cs active_base+number_active_chars /* equivalent of \.{\\csname\\endcsname} */
+
+
+#define eq_level(a) zeqtb[a].hh.u.B1
+#define eq_type(a) zeqtb[a].hh.u.B0
+#define equiv(a) zeqtb[a].hh.v.RH
+
+/* leave an input level, re-enter the old */
+#define pop_input() cur_input=input_stack[--input_ptr]
+
+#define nonstop_mode 1
+
+/* command codes */
+#define relax 0
+#define out_param 5
+#define max_command 117 /* fetched from C output */
+#define dont_expand 133 /* fetched from C output */
+
+#define terminal_input (name==0) /* are we reading from the terminal? */
+#define special_char 1114113 /* |biggest_char+2| */
+#define cur_file input_file[index] /* the current |alpha_file| variable */
+
+#define no_expand_flag special_char /*this characterizes a special variant of |relax|*/
+
+extern void insert_vj_template (void);
+
+#define do_get_cat_code(a) do { \
+ if (local_catcode_table) \
+ a=get_cat_code(line_catcode_table,cur_chr); \
+ else \
+ a=get_cat_code(cat_code_table,cur_chr); \
+ } while (0)
+
+
+static void
+invalid_character_error (void) {
+ char *hlp[] = {"A funny symbol that I can't read has just been input.",
+ "Continue, and I'll forget that it ever happened.",
+ NULL};
+ deletions_allowed=false;
+ tex_error("Text line contains an invalid character", hlp);
+ deletions_allowed=true;
+}
+
+/* no longer done */
+
+static boolean process_sup_mark(void); /* below */
+
+static int scan_control_sequence(void); /* below */
+
+typedef enum {next_line_ok, next_line_return, next_line_restart } next_line_retval ;
+
+static next_line_retval next_line(void); /* below */
+
+/* @^inner loop@>*/
+
+static void
+utf_error (void) {
+ char *hlp[] = {"A funny symbol that I can't read has just been input.",
+ "Just continue, I'll change it to 0xFFFD.",
+ NULL };
+ deletions_allowed=false;
+ tex_error("Text line contains an invalid utf-8 sequence", hlp);
+ deletions_allowed=true;
+}
+
+static integer
+qbuffer_to_unichar (integer *k) {
+ register int ch;
+ int val = 0xFFFD;
+ unsigned char *text = buffer+*k;
+ if ( (ch = *text++)<0x80 ) {
+ val = ch;
+ *k+=1;
+ } else if ( ch<=0xbf ) { /* error */
+ *k+=1;
+ } else if ( ch<=0xdf ) {
+ if ( *text>=0x80 && *text<0xc0 )
+ val = ((ch&0x1f)<<6) | (*text++&0x3f);
+ *k+=2;
+ } else if ( ch<=0xef ) {
+ if ( *text>=0x80 && *text<0xc0 && text[1]>=0x80 && text[1]<0xc0 ) {
+ val = ((ch&0xf)<<12) | ((text[0]&0x3f)<<6) | (text[1]&0x3f);
+ *k+=3;
+ }
+ } else {
+ int w = ( ((ch&0x7)<<2) | ((text[0]&0x30)>>4) )-1, w2;
+ w = (w<<6) | ((text[0]&0xf)<<2) | ((text[1]&0x30)>>4);
+ w2 = ((text[1]&0xf)<<6) | (text[2]&0x3f);
+ val = w*0x400 + w2 + 0x10000;
+ if ( *text<0x80 || text[1]<0x80 || text[2]<0x80 ||
+ *text>=0xc0 || text[1]>=0xc0 || text[2]>=0xc0 )
+ val = 0xFFFD;
+ *k+=4;
+ }
+ if (val==0xFFFD)
+ utf_error();
+ return( val );
+}
+
+static boolean
+get_next_file (void) {
+ SWITCH:
+ if (loc<=limit) { /* current line not yet finished */
+ cur_chr = qbuffer_to_unichar(&loc);
+ RESWITCH:
+ if (detokenized_line) {
+ cur_cmd = (cur_chr==' ' ? 10 : 12) ;
+ } else {
+ do_get_cat_code(cur_cmd);
+ }
+ /*
+ @<Change state if necessary, and |goto switch| if the current
+ character should be ignored, or |goto reswitch| if the current
+ character changes to another@>;
+ */
+ /* The following 48-way switch accomplishes the scanning quickly, assuming
+ that a decent \PASCAL\ compiler has translated the code. Note that the numeric
+ values for |mid_line|, |skip_blanks|, and |new_line| are spaced
+ apart from each other by |max_char_code+1|, so we can add a character's
+ command code to the state to get a single number that characterizes both.
+ */
+ switch(state+cur_cmd) {
+ case mid_line + ignore:
+ case skip_blanks + ignore:
+ case new_line + ignore:
+ case skip_blanks + spacer:
+ case new_line + spacer: /* @<Cases where character is ignored@> */
+ goto SWITCH;
+ break;
+ case mid_line + escape:
+ case new_line + escape:
+ case skip_blanks + escape: /* @<Scan a control sequence ...@>;*/
+ state = scan_control_sequence();
+ break;
+ case mid_line + active_char:
+ case new_line + active_char:
+ case skip_blanks + active_char: /* @<Process an active-character */
+ cur_cs=cur_chr+active_base;
+ cur_cmd=eq_type(cur_cs);
+ cur_chr=equiv(cur_cs);
+ state=mid_line;
+ break;
+ case mid_line + sup_mark:
+ case new_line + sup_mark:
+ case skip_blanks + sup_mark: /* @<If this |sup_mark| starts */
+ if (process_sup_mark())
+ goto RESWITCH;
+ else
+ state=mid_line;
+ break;
+ case mid_line + invalid_char:
+ case new_line + invalid_char:
+ case skip_blanks + invalid_char: /* @<Decry the invalid character and |goto restart|@>;*/
+ invalid_character_error();
+ return false; /* because state may be token_list now */
+ break;
+ case mid_line + spacer: /* @<Enter |skip_blanks| state, emit a space@>;*/
+ state=skip_blanks;
+ cur_chr=' ';
+ break;
+ case mid_line + car_ret: /* @<Finish line, emit a space@>;*/
+ /* When a character of type |spacer| gets through, its character code is
+ changed to $\.{"\ "}=@'40$. This means that the ASCII codes for tab and space,
+ and for the space inserted at the end of a line, will
+ be treated alike when macro parameters are being matched. We do this
+ since such characters are indistinguishable on most computer terminal displays.
+ */
+ loc=limit+1;
+ cur_cmd=spacer;
+ cur_chr=' ';
+ break;
+ case skip_blanks + car_ret:
+ case mid_line + comment:
+ case new_line + comment:
+ case skip_blanks + comment: /* @<Finish line, |goto switch|@>;*/
+ loc=limit+1;
+ goto SWITCH;
+ break;
+ case new_line + car_ret: /* @<Finish line, emit a \.{\\par}@>;*/
+ loc=limit+1;
+ cur_cs=par_loc;
+ cur_cmd=eq_type(cur_cs);
+ cur_chr=equiv(cur_cs);
+ break;
+ case skip_blanks + left_brace:
+ case new_line + left_brace:
+ state=mid_line; /* fall through */
+ case mid_line + left_brace:
+ align_state++;
+ break;
+ case skip_blanks + right_brace:
+ case new_line + right_brace:
+ state=mid_line; /* fall through */
+ case mid_line + right_brace:
+ align_state--;
+ break;
+ case mid_line + math_shift:
+ case mid_line + tab_mark:
+ case mid_line + mac_param:
+ case mid_line + sub_mark:
+ case mid_line + letter:
+ case mid_line + other_char:
+ break;
+ default:
+ /*
+ case skip_blanks + math_shift:
+ case skip_blanks + tab_mark:
+ case skip_blanks + mac_param:
+ case skip_blanks + sub_mark:
+ case skip_blanks + letter:
+ case skip_blanks + other_char:
+ case new_line + math_shift:
+ case new_line + tab_mark:
+ case new_line + mac_param:
+ case new_line + sub_mark:
+ case new_line + letter:
+ case new_line + other_char:
+ */
+ state=mid_line;
+ break;
+ }
+ } else {
+ if (current_ocp_lstack>0) {
+ pop_input();
+ return false;
+ }
+ if (name!=21)
+ state=new_line;
+
+ /*
+ @<Move to next line of file,
+ or |goto restart| if there is no next line,
+ or |return| if a \.{\\read} line has finished@>;
+ */
+ do {
+ next_line_retval r = next_line();
+ if (r==next_line_return) {
+ return true;
+ } else if (r==next_line_restart) {
+ return false;
+ }
+ } while (0);
+ check_interrupt();
+ goto SWITCH;
+ }
+ return true;
+}
+
+#define is_hex(a) ((a>='0'&&a<='9')||(a>='a'&&a<='f'))
+
+#define add_nybble(a) do { \
+ if (a<='9') cur_chr=(cur_chr<<4)+a-'0'; \
+ else cur_chr=(cur_chr<<4)+a-'a'+10; \
+ } while (0)
+
+#define hex_to_cur_chr do { \
+ if (c<='9') cur_chr=c-'0'; \
+ else cur_chr=c-'a'+10; \
+ add_nybble(cc); \
+ } while (0)
+
+#define four_hex_to_cur_chr do { \
+ hex_to_cur_chr; \
+ add_nybble(ccc); add_nybble(cccc); \
+ } while (0)
+
+#define five_hex_to_cur_chr do { \
+ four_hex_to_cur_chr; \
+ add_nybble(ccccc); \
+ } while (0)
+
+#define six_hex_to_cur_chr do { \
+ five_hex_to_cur_chr; \
+ add_nybble(cccccc); \
+ } while (0)
+
+
+/* Notice that a code like \.{\^\^8} becomes \.x if not followed by a hex digit.*/
+
+static boolean
+process_sup_mark(void) {
+ if (cur_chr==buffer[loc]) {
+ int c,cc;
+ if (loc<limit) {
+ if ((cur_chr==buffer[loc+1]) && (cur_chr==buffer[loc+2])
+ && (cur_chr==buffer[loc+3]) && (cur_chr==buffer[loc+4])
+ && ((loc+10)<=limit)) {
+ int ccc,cccc,ccccc,cccccc; /* constituents of a possible expanded code */
+ c=buffer[loc+5];
+ cc=buffer[loc+6];
+ ccc=buffer[loc+7];
+ cccc=buffer[loc+8];
+ ccccc=buffer[loc+9];
+ cccccc=buffer[loc+10];
+ if ((is_hex(c)) && (is_hex(cc)) && (is_hex(ccc)) && (is_hex(cccc))
+ && (is_hex(ccccc)) && (is_hex(cccccc))) {
+ loc=loc+11;
+ six_hex_to_cur_chr;
+ return true;
+ }
+ }
+ if ((cur_chr==buffer[loc+1]) && (cur_chr==buffer[loc+2])
+ && (cur_chr==buffer[loc+3]) && ((loc+8)<=limit)) {
+ int ccc,cccc,ccccc; /* constituents of a possible expanded code */
+ c=buffer[loc+4];
+ cc=buffer[loc+5];
+ ccc=buffer[loc+6];
+ cccc=buffer[loc+7];
+ ccccc=buffer[loc+8];
+ if ((is_hex(c)) && (is_hex(cc)) && (is_hex(ccc)) && (is_hex(cccc)) && (is_hex(ccccc))) {
+ loc=loc+9;
+ five_hex_to_cur_chr;
+ return true;
+ }
+ }
+ if ((cur_chr==buffer[loc+1]) && (cur_chr==buffer[loc+2]) && ((loc+6)<=limit)) {
+ int ccc,cccc; /* constituents of a possible expanded code */
+ c=buffer[loc+3];
+ cc=buffer[loc+4];
+ ccc=buffer[loc+5];
+ cccc=buffer[loc+6];
+ if ((is_hex(c)) && (is_hex(cc)) && (is_hex(ccc)) && (is_hex(cccc))) {
+ loc=loc+7;
+ four_hex_to_cur_chr;
+ return true;
+ }
+ }
+ c = buffer[loc+1];
+ if (c<0200) { /* yes we have an expanded char */
+ loc=loc+2;
+ if (is_hex(c) && loc<=limit) {
+ cc=buffer[loc];
+ if (is_hex(cc)){
+ incr(loc);
+ hex_to_cur_chr;
+ return true;
+ }
+ }
+ cur_chr = (c<0100 ? c+0100 : c-0100);
+ return true;
+ }
+ }
+ }
+ return false;
+}
+
+/* Control sequence names are scanned only when they appear in some line of
+ a file; once they have been scanned the first time, their |eqtb| location
+ serves as a unique identification, so \TeX\ doesn't need to refer to the
+ original name any more except when it prints the equivalent in symbolic form.
+
+ The program that scans a control sequence has been written carefully
+ in order to avoid the blowups that might otherwise occur if a malicious
+ user tried something like `\.{\\catcode\'15=0}'. The algorithm might
+ look at |buffer[limit+1]|, but it never looks at |buffer[limit+2]|.
+
+ If expanded characters like `\.{\^\^A}' or `\.{\^\^df}'
+ appear in or just following
+ a control sequence name, they are converted to single characters in the
+ buffer and the process is repeated, slowly but surely.
+*/
+
+static boolean check_expanded_code (integer *kk) ; /* below */
+
+static int scan_control_sequence (void ) {
+ int retval = mid_line;
+ if (loc>limit) {
+ cur_cs=null_cs; /* |state| is irrelevant in this case */
+ } else {
+ register int cat; /* |cat_code(cur_chr)|, usually */
+ while (1) {
+ integer k=loc;
+ cur_chr = qbuffer_to_unichar(&k);
+ do_get_cat_code(cat);
+ if (cat!=letter||k>limit) {
+ retval = (cat==spacer ? skip_blanks : mid_line);
+ if (cat==sup_mark && check_expanded_code(&k)) /* @<If an expanded...@>; */
+ continue;
+ } else {
+ retval=skip_blanks;
+ do {
+ cur_chr = qbuffer_to_unichar(&k);
+ do_get_cat_code(cat);
+ } while (cat==letter&&k<=limit);
+
+ if (cat==sup_mark && check_expanded_code(&k)) /* @<If an expanded...@>; */
+ continue;
+ if (cat!=letter) {
+ decr(k);
+ if (cur_chr>0xFFFF) decr(k);
+ if (cur_chr>0x7FF) decr(k);
+ if (cur_chr>0x7F) decr(k);
+ } /* now |k| points to first nonletter */
+ }
+ cur_cs=id_lookup(loc,k-loc);
+ loc=k;
+ break;
+ }
+ }
+ cur_cmd=eq_type(cur_cs);
+ cur_chr=equiv(cur_cs);
+ return retval;
+}
+
+/* Whenever we reach the following piece of code, we will have
+ |cur_chr=buffer[k-1]| and |k<=limit+1| and |cat=get_cat_code(cat_code_table,cur_chr)|. If an
+ expanded code like \.{\^\^A} or \.{\^\^df} appears in |buffer[(k-1)..(k+1)]|
+ or |buffer[(k-1)..(k+2)]|, we
+ will store the corresponding code in |buffer[k-1]| and shift the rest of
+ the buffer left two or three places.
+*/
+
+static boolean
+check_expanded_code (integer *kk) {
+ int l;
+ int k = *kk;
+ int d =1; /* number of excess characters in an expanded code */
+ int c,cc,ccc,cccc,ccccc,cccccc; /* constituents of a possible expanded code */
+ if (buffer[k]==cur_chr && k<limit) {
+ if ((cur_chr==buffer[k+1]) && (cur_chr==buffer[k+2]) && ((k+6)<=limit)) {
+ d = 4;
+ if ((cur_chr==buffer[k+3]) && ((k+8)<=limit))
+ d = 5;
+ if ((cur_chr==buffer[k+4]) && ((k+10)<=limit))
+ d = 6;
+ c = buffer[k+d-1];
+ cc = buffer[k+d];
+ ccc = buffer[k+d+1];
+ cccc= buffer[k+d+2];
+ if (d==6) {
+ ccccc =buffer[k+d+3];
+ cccccc=buffer[k+d+4];
+ if (is_hex(c) && is_hex(cc) && is_hex(ccc) && is_hex(cccc)
+ && is_hex(ccccc) && is_hex(cccccc))
+ six_hex_to_cur_chr;
+ } else if (d==5) {
+ ccccc=buffer[k+d+3];
+ if (is_hex(c) && is_hex(cc) && is_hex(ccc) && is_hex(cccc) && is_hex(ccccc))
+ five_hex_to_cur_chr;
+ } else {
+ if (is_hex(c) && is_hex(cc) && is_hex(ccc) && is_hex(cccc))
+ four_hex_to_cur_chr;
+ }
+ } else {
+ c=buffer[k+1];
+ if (c<0200) {
+ d=1;
+ if (is_hex(c) && (k+2)<=limit) {
+ cc=buffer[k+2];
+ if (is_hex(c) && is_hex(cc)) {
+ d=2;
+ hex_to_cur_chr;
+ }
+ } else if (c<0100) {
+ cur_chr=c+0100;
+ } else {
+ cur_chr=c-0100;
+ }
+ }
+ }
+ if (d>2)
+ d=2*d-1;
+ else
+ d++;
+ if (cur_chr <= 0x7F) {
+ buffer[k-1]= cur_chr;
+ } else if (cur_chr<=0x7FF) {
+ buffer[k-1]=0xC0 + cur_chr / 0x40;
+ k++; d--;
+ buffer[k-1]=0x80 + cur_chr % 0x40;
+ } else if (cur_chr<=0xFFFF){
+ buffer[k-1]=0xE0 + cur_chr / 0x1000;
+ k++; d--;
+ buffer[k-1]=0x80 + (cur_chr % 0x1000) / 0x40;
+ k++; d--;
+ buffer[k-1]=0x80 + (cur_chr % 0x1000) % 0x40;
+ } else {
+ buffer[k-1]=0xF0 + cur_chr / 0x40000;
+ k++; d--;
+ buffer[k-1]=0x80 + (cur_chr % 0x40000) / 0x1000;
+ k++; d--;
+ buffer[k-1]=0x80 + ((cur_chr % 0x40000) % 0x1000) / 0x40;
+ k++; d--;
+ buffer[k-1]=0x80 + ((cur_chr % 0x40000) % 0x1000) % 0x40;
+ }
+ l = k;
+ limit = limit - d;
+ while (l<=limit) {
+ buffer[l]=buffer[l+d];
+ l++;
+ }
+ *kk =k;
+ return true;
+ }
+ return false;
+}
+
+#define end_line_char_inactive ((end_line_char<0)||(end_line_char>127))
+
+/* The global variable |force_eof| is normally |false|; it is set |true|
+ by an \.{\\endinput} command.
+
+ @<Glob...@>=
+ @!force_eof:boolean; {should the next \.{\\input} be aborted early?}
+
+*/
+
+
+/* All of the easy branches of |get_next| have now been taken care of.
+ There is one more branch.
+*/
+
+static next_line_retval
+next_line (void) {
+ integer tab; /* a category table */
+ boolean inhibit_eol = false; /* a way to end a pseudo file without trailing space */
+ detokenized_line=false;
+ local_catcode_table=false;
+ if (name>17) {
+ /* @<Read next line of file into |buffer|, or |goto restart| if the file has ended@> */
+ incr(line);
+ first=start;
+ if (!force_eof) {
+ if (name<=20) {
+ if (pseudo_input()) { /* not end of file */
+ firm_up_the_line(); /* this sets |limit| */
+ if ((name==19)&&(pseudo_lines(pseudo_files)==null))
+ inhibit_eol=true;
+ } else if ((every_eof!=null)&&!eof_seen[index]) {
+ limit=first-1; eof_seen[index]=true; /* fake one empty line */
+ if (name!=19)
+ begin_token_list(every_eof,every_eof_text);
+ return next_line_restart;
+ } else {
+ force_eof=true;
+ }
+ } else {
+ if (name==21) {
+ if (luacstring_input()) { /* not end of strings */
+ firm_up_the_line();
+ if ((luacstring_penultimate())||(luacstring_simple()))
+ inhibit_eol=true;
+ if (!luacstring_simple())
+ state=new_line;
+ if (luacstring_detokenized()) {
+ inhibit_eol=true;
+ detokenized_line=true;
+ } else {
+ if (! luacstring_defaultcattable()) {
+ tab=luacstring_cattable();
+ if (valid_catcode_table(tab)) {
+ local_catcode_table=true;
+ line_catcode_table=tab;
+ }
+ }
+ }
+ } else {
+ force_eof=true;
+ }
+ } else {
+ if (lua_input_ln(cur_file,0,true)) { /* not end of file */
+ firm_up_the_line(); /* this sets |limit| */
+ } else if ((every_eof!=null)&& (!eof_seen[index])) {
+ limit=first-1; eof_seen[index]=true; /* fake one empty line */
+ begin_token_list(every_eof,every_eof_text);
+ return next_line_restart;
+ } else {
+ force_eof=true;
+ }
+ }
+ }
+ }
+ if (force_eof) {
+ if (tracing_nesting>0)
+ if ((grp_stack[in_open]!=cur_boundary)||(if_stack[in_open]!=cond_ptr))
+ if (!((name==19)||(name=21)))
+ file_warning(); /* give warning for some unfinished groups and/or conditionals */
+ if ((name>21)||(name==20)) {
+ if (tracefilenames)
+ print_char(')');
+ open_parens--;
+ /* update_terminal();*/ /* show user that file has been read */
+ }
+ force_eof=false;
+ end_file_reading();
+ return next_line_restart;
+ }
+ if (inhibit_eol||end_line_char_inactive)
+ limit--;
+ else
+ buffer[limit]=end_line_char;
+ first=limit+1;
+ loc=start; /* ready to read */
+ } else {
+ if (!terminal_input) { /* \.{\\read} line has ended */
+ cur_cmd=0;
+ cur_chr=0;
+ return next_line_return; /* OUTER */
+ }
+ if (input_ptr>0) { /* text was inserted during error recovery */
+ end_file_reading();
+ return next_line_restart; /* resume previous level */
+ }
+ if (selector<log_only)
+ open_log_file();
+ if (interaction>nonstop_mode) {
+ if (end_line_char_inactive)
+ limit++;
+ if (limit==start) { /* previous line was empty */
+ tprint_nl("(Please type a command or say `\\end')");
+ }
+ print_ln();
+ first=start;
+ prompt_input((str_number)'*'); /* input on-line into |buffer| */
+ limit=last;
+ if (end_line_char_inactive)
+ limit--;
+ else
+ buffer[limit]=end_line_char;
+ first=limit+1;
+ loc=start;
+ } else {
+ fatal_error(maketexstring("*** (job aborted, no legal \\end found)"));
+ /* nonstop mode, which is intended for overnight batch processing,
+ never waits for on-line input */
+ }
+ }
+ return next_line_ok;
+}
+
+
+
+
+/* Let's consider now what happens when |get_next| is looking at a token list. */
+
+static boolean
+get_next_tokenlist (void) {
+ register halfword t; /* a token*/
+ t=info(loc);
+ loc=link(loc); /* move to next */
+ if (t>=cs_token_flag) { /* a control sequence token */
+ cur_cs=t-cs_token_flag;
+ cur_cmd=eq_type(cur_cs);
+ if (cur_cmd==dont_expand) { /* @<Get the next token, suppressing expansion@>*/
+ /* The present point in the program is reached only when the |expand|
+ routine has inserted a special marker into the input. In this special
+ case, |info(loc)| is known to be a control sequence token, and |link(loc)=null|.
+ */
+ cur_cs=info(loc)-cs_token_flag;
+ loc=null;
+ cur_cmd=eq_type(cur_cs);
+ if (cur_cmd>max_command) {
+ cur_cmd=relax;
+ cur_chr=no_expand_flag;
+ return true;
+ }
+ }
+ cur_chr=equiv(cur_cs);
+ } else {
+ cur_cmd=t >> string_offset_bits; /* cur_cmd=t / string_offset; */
+ cur_chr=t & (string_offset-1); /* cur_chr=t % string_offset; */
+ switch (cur_cmd) {
+ case left_brace:
+ align_state++;
+ break;
+ case right_brace:
+ align_state--;
+ break;
+ case out_param: /* @<Insert macro parameter and |goto restart|@>; */
+ begin_token_list(param_stack[param_start+cur_chr-1],parameter);
+ return false;
+ break;
+ }
+ }
+ return true;
+}
+
+/* Now we're ready to take the plunge into |get_next| itself. Parts of
+ this routine are executed more often than any other instructions of \TeX.
+ @^mastication@>@^inner loop@>
+*/
+
+/* sets |cur_cmd|, |cur_chr|, |cur_cs| to next token */
+
+void
+get_next (void) {
+ RESTART:
+ cur_cs=0;
+ if (state!=token_list) {
+ /* Input from external file, |goto restart| if no input found */
+ if (!get_next_file())
+ goto RESTART;
+ } else {
+ if (loc==null) {
+ end_token_list();
+ goto RESTART; /* list exhausted, resume previous level */
+ } else if (!get_next_tokenlist()) {
+ goto RESTART; /* parameter needs to be expanded */
+ }
+ }
+ /* @<If an alignment entry has just ended, take appropriate action@> */
+ if ((cur_cmd==tab_mark || cur_cmd==car_ret) && align_state==0) {
+ insert_vj_template();
+ goto RESTART;
+ }
+}
+
+void
+get_token_lua (void) {
+ register int callback_id ;
+ callback_id = callback_defined(token_filter_callback);
+ if (callback_id!=0) {
+ while (state==token_list && loc==null && index!=v_template)
+ end_token_list();
+ /* there is some stuff we don't want to see inside the callback */
+ if (!(state==token_list &&
+ ((nofilter==true) || (index==backed_up && loc!=null)))) {
+ do_get_token_lua(callback_id);
+ return;
+ }
+ }
+ get_next();
+}
diff --git a/Build/source/texk/web2c/luatexdir/textcodes.c b/Build/source/texk/web2c/luatexdir/textcodes.c
new file mode 100644
index 00000000000..05f85b941c4
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/textcodes.c
@@ -0,0 +1,278 @@
+
+/*
+Copyright (c) 2006 Taco Hoekwater, <taco@elvenkind.com>
+
+This file is part of LuaTeX.
+
+LuaTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+LuaTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with LuaTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id $
+*/
+
+
+#include "luatex-api.h"
+#include <ptexlib.h>
+#include <stdarg.h>
+
+#include "managed-sa.h"
+
+#define LCCODESTACK 8
+#define LCCODEDEFAULT 0
+
+static sa_tree lccode_head = NULL;
+
+#define UCCODESTACK 8
+#define UCCODEDEFAULT 0
+
+static sa_tree uccode_head = NULL;
+
+#define SFCODESTACK 8
+#define SFCODEDEFAULT 1000
+
+static sa_tree sfcode_head = NULL;
+
+#define CATCODESTACK 8
+#define CATCODEDEFAULT 12
+
+void set_lc_code (integer n, halfword v, quarterword gl) {
+ set_sa_item(lccode_head,n,v,gl);
+}
+
+halfword get_lc_code (integer n) {
+ return (halfword)get_sa_item(lccode_head,n);
+}
+
+static void unsavelccodes (quarterword gl) {
+ restore_sa_stack(lccode_head,gl);
+}
+
+static void initializelccodes (void) {
+ lccode_head = new_sa_tree(LCCODESTACK,LCCODEDEFAULT);
+}
+
+static void dumplccodes (void) {
+ dump_sa_tree(lccode_head);
+}
+
+static void undumplccodes (void) {
+ lccode_head = undump_sa_tree();
+}
+
+void set_uc_code (integer n, halfword v, quarterword gl) {
+ set_sa_item(uccode_head,n,v,gl);
+}
+
+halfword get_uc_code (integer n) {
+ return (halfword)get_sa_item(uccode_head,n);
+}
+
+static void unsaveuccodes (quarterword gl) {
+ restore_sa_stack(uccode_head,gl);
+}
+
+static void initializeuccodes (void) {
+ uccode_head = new_sa_tree(UCCODESTACK,UCCODEDEFAULT);
+}
+
+static void dumpuccodes (void) {
+ dump_sa_tree(uccode_head);
+}
+
+static void undumpuccodes (void) {
+ uccode_head = undump_sa_tree();
+}
+
+void set_sf_code (integer n, halfword v, quarterword gl) {
+ set_sa_item(sfcode_head,n,v,gl);
+}
+
+halfword get_sf_code (integer n) {
+ return (halfword)get_sa_item(sfcode_head,n);
+}
+
+static void unsavesfcodes (quarterword gl) {
+ restore_sa_stack(sfcode_head,gl);
+}
+
+static void initializesfcodes (void) {
+ sfcode_head = new_sa_tree(SFCODESTACK,SFCODEDEFAULT);
+}
+
+static void dumpsfcodes (void) {
+ dump_sa_tree(sfcode_head);
+}
+
+static void undumpsfcodes (void) {
+ sfcode_head = undump_sa_tree();
+}
+
+
+static sa_tree *catcode_heads = NULL;
+static int catcode_max = 0;
+static unsigned char *catcode_valid = NULL;
+
+void check_catcode_sizes (int h) {
+ int k;
+ if (h < 0)
+ uexit(1);
+ if (h>catcode_max) {
+ catcode_heads = Mxrealloc_array(catcode_heads,sa_tree,(h+1));
+ catcode_valid = Mxrealloc_array(catcode_valid,unsigned char,(h+1));
+ for (k=(catcode_max+1);k<=h;k++) {
+ catcode_heads[k] = NULL;
+ catcode_valid[k] = 0;
+ }
+ catcode_max = h;
+ }
+}
+
+void set_cat_code (integer h, integer n, halfword v, quarterword gl) {
+ check_catcode_sizes(h);
+ if (catcode_heads[h] == NULL) {
+ catcode_heads[h] = new_sa_tree(CATCODESTACK,CATCODEDEFAULT);
+ }
+ set_sa_item(catcode_heads[h],n,v,gl);
+}
+
+halfword get_cat_code (integer h, integer n) {
+ check_catcode_sizes(h);
+ if (catcode_heads[h] == NULL) {
+ catcode_heads[h] = new_sa_tree(CATCODESTACK,CATCODEDEFAULT);
+ }
+ return (halfword)get_sa_item(catcode_heads[h],n);
+}
+
+void unsave_cat_codes (integer h, quarterword gl) {
+ int k;
+ check_catcode_sizes(h);
+ for (k=0;k<=catcode_max;k++) {
+ if (catcode_heads[k] != NULL)
+ restore_sa_stack(catcode_heads[k],gl);
+ }
+}
+
+void clearcatcodestack(integer h) {
+ clear_sa_stack(catcode_heads[h]);
+}
+
+static void initializecatcodes (void) {
+ catcode_max = 0;
+ catcode_heads = Mxmalloc_array(sa_tree,(catcode_max+1));
+ catcode_valid = Mxmalloc_array(unsigned char,(catcode_max+1));
+ catcode_valid[0] = 1;
+ catcode_heads[0] = new_sa_tree(CATCODESTACK,CATCODEDEFAULT);
+}
+
+static void dumpcatcodes (void) {
+ int k,total;
+ dump_int(catcode_max);
+ total = 0;
+ for (k=0;k<=catcode_max;k++) {
+ if (catcode_valid[k]) {
+ total++;
+ }
+ }
+ dump_int(total);
+ for (k=0;k<=catcode_max;k++) {
+ if (catcode_valid[k]) {
+ dump_int(k);
+ dump_sa_tree(catcode_heads[k]);
+ }
+ }
+}
+
+static void undumpcatcodes (void) {
+ int total,h,k;
+ undump_int(catcode_max);
+ catcode_heads = Mxmalloc_array(sa_tree,(catcode_max+1));
+ catcode_valid = Mxmalloc_array(unsigned char,(catcode_max+1));
+ for (k=0;k<=catcode_max;k++) {
+ catcode_heads[k]=NULL;
+ catcode_valid[k]=0;
+ }
+ undump_int(total);
+ for (k=0;k<total;k++) {
+ undump_int(h);
+ catcode_heads[h] = undump_sa_tree();
+ catcode_valid[h] = 1;
+ }
+}
+
+int valid_catcode_table (int h) {
+ if (h<=catcode_max && h>=0 && catcode_valid[h]) {
+ return 1;
+ }
+ return 0;
+}
+
+void copy_cat_codes (int from, int to) {
+ if (from<0 || from>catcode_max || catcode_valid[from] == 0) {
+ uexit(1);
+ }
+ check_catcode_sizes(to);
+ destroy_sa_tree(catcode_heads[to]);
+ catcode_heads[to] = copy_sa_tree(catcode_heads[from]);
+ catcode_valid[to] = 1;
+}
+
+void initex_cat_codes (int h) {
+ int k;
+ check_catcode_sizes(h);
+ destroy_sa_tree(catcode_heads[h]);
+ catcode_heads[h] = NULL;
+ set_cat_code(h,'\r',car_ret,1);
+ set_cat_code(h,' ',spacer,1);
+ set_cat_code(h,'\\',escape,1);
+ set_cat_code(h,'%',comment,1);
+ set_cat_code(h,127,invalid_char,1);
+ set_cat_code(h,0,ignore,1);
+ for (k='A';k<='Z';k++) {
+ set_cat_code(h,k,letter,1);
+ set_cat_code(h,k+'a'-'A',letter,1);
+ }
+ catcode_valid[h] = 1;
+}
+
+void
+unsave_text_codes (quarterword grouplevel) {
+ unsavesfcodes(grouplevel);
+ unsaveuccodes(grouplevel);
+ unsavelccodes(grouplevel);
+}
+
+void
+initialize_text_codes (void) {
+ initializesfcodes();
+ initializeuccodes();
+ initializecatcodes();
+ initializelccodes();
+}
+
+void
+dump_text_codes (void) {
+ dumpsfcodes();
+ dumpuccodes();
+ dumplccodes();
+ dumpcatcodes();
+}
+
+void
+undump_text_codes (void) {
+ undumpsfcodes();
+ undumpuccodes();
+ undumplccodes();
+ undumpcatcodes();
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/tokens.h b/Build/source/texk/web2c/luatexdir/tokens.h
new file mode 100644
index 00000000000..6078644ba22
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/tokens.h
@@ -0,0 +1,68 @@
+/* $Id$ */
+
+
+#define token_list 0
+#define cs_token_flag 0x1FFFFFFF
+#define string_offset 0x200000
+#define string_offset_bits 21
+
+#define token_type index /* type of current token list */
+#define param_start limit /* base of macro parameters in |param_stack| */
+
+typedef enum {
+ parameter=0, /* code for parameter */
+ u_template=1, /* code for \<u_j> template */
+ v_template=2, /* code for \<v_j> template */
+ backed_up=3, /* code for text to be reread */
+ inserted=4, /* code for inserted texts */
+ macro=5, /* code for defined control sequences */
+ output_text=6, /* code for output routines */
+ every_par_text=7, /* code for \.{\\everypar} */
+ every_math_text=8, /* code for \.{\\everymath} */
+ every_display_text=9, /* code for \.{\\everydisplay} */
+ every_hbox_text=10, /* code for \.{\\everyhbox} */
+ every_vbox_text=11, /* code for \.{\\everyvbox} */
+ every_job_text=12, /* code for \.{\\everyjob}/ */
+ every_cr_text=13, /* code for \.{\\everycr} */
+ mark_text=14, /* code for \.{\\topmark}, etc. */
+ every_eof_text=19 /* was calculated, value fetched from the generated C */
+} token_types;
+
+#undef link /* defined by cpascal.h */
+#define info(a) fixmem[(a)].hhlh
+#define link(a) fixmem[(a)].hhrh
+
+#define store_new_token(a) { q=get_avail(); link(p)=q; info(q)=(a); p=q; }
+#define free_avail(a) { link((a))=avail; avail=(a); decr(dyn_used); }
+
+
+#define str_start_macro(a) str_start[(a) - string_offset]
+
+#define length(a) (str_start_macro((a)+1)-str_start_macro(a))
+
+#if defined(index)
+#undef index
+#endif
+
+#define loc cur_input.loc_field /* location of first unread character in |buffer| */
+#define state cur_input.state_field /* current scanner state */
+#define index cur_input.index_field /* reference for buffer information */
+#define start cur_input.start_field /* starting position in |buffer| */
+#define limit cur_input.limit_field /* end of current line in |buffer| */
+#define nofilter cur_input.nofilter_field /* is token filtering explicitly disallowed? */
+#define name cur_input.name_field /* name of the current file */
+#define current_ocp_lstack cur_input.ocp_lstack_field /* name of the current ocp */
+#define current_ocp_no cur_input.ocp_no_field /* name of the current ocp */
+
+#define max_char_code 15 /* largest catcode for individual characters */
+
+typedef enum {
+ mid_line=1, /* |state| code when scanning a line of characters */
+ skip_blanks=2+max_char_code, /* |state| code when ignoring blanks */
+ new_line=3+max_char_code+max_char_code, /* |state| code at start of line */
+} state_codes ;
+
+
+extern void make_token_table (lua_State *L, int cmd, int chr, int cs);
+
+
diff --git a/Build/source/texk/web2c/luatexdir/ttf2afm.c b/Build/source/texk/web2c/luatexdir/ttf2afm.c
new file mode 100644
index 00000000000..45524e658fa
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/ttf2afm.c
@@ -0,0 +1,1053 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+/*
+#include <kpathsea/c-auto.h>
+#include <kpathsea/c-fopen.h>
+#include <kpathsea/c-limits.h>
+#include <kpathsea/c-memstr.h>
+#include <kpathsea/c-proto.h>
+#include <kpathsea/c-std.h>
+#include <kpathsea/c-unistd.h>
+#include <kpathsea/c-vararg.h>
+#include <kpathsea/getopt.h>
+*/
+#include <kpathsea/kpathsea.h>
+#include <time.h>
+#include <libgen.h>
+#include <pdftexdir/ptexmac.h>
+#include <pdftexdir/writettf.h>
+#include <string.h>
+
+/* constants used for print_glyph */
+#define AS_NAME 0
+#define AS_INDEX 1
+#define AS_UNICODE 2
+
+#define VERSION "1.02"
+
+/* FIXME */
+#define NOGLYPH_ASSIGNED_YET USHRT_MAX
+
+#define enc_getchar() xgetc(encfile)
+#define enc_eof() feof(encfile)
+#define pdftex_fail ttf_fail
+
+#define print_str(S) if (S != NULL) fprintf(outfile, #S " %s\n", S)
+#define print_dimen(N) if (N != 0) fprintf(outfile, #N " %i\n", (int)get_ttf_funit(N))
+
+#define get_ttf_funit(n) \
+ (n < 0 ? -((-n/upem)*1000 + ((-n%upem)*1000)/upem) :\
+ ((n/upem)*1000 + ((n%upem)*1000)/upem))
+
+typedef struct _unicode_entry {
+ TTF_USHORT code;
+ struct _unicode_entry *next;
+} unicode_entry;
+
+typedef struct {
+ TTF_ULONG wx;
+ const char *name;
+ TTF_USHORT index;
+ TTF_LONG bbox[4];
+ TTF_LONG offset;
+ char found;
+ unicode_entry *unicode_list;
+} mtx_entry;
+
+typedef struct _kern_entry {
+ TTF_FWORD value;
+ TTF_USHORT adjacent;
+ struct _kern_entry *next;
+} kern_entry;
+
+
+char *FontName = NULL;
+char *FullName = NULL;
+char *FamilyName = NULL;
+char *Notice = NULL;
+char *Version = NULL;
+char *Weight = NULL;
+TTF_LONG ItalicAngle = 0;
+TTF_LONG IsFixedPitch = 0;
+TTF_LONG FontBBox1 = 0;
+TTF_LONG FontBBox2 = 0;
+TTF_LONG FontBBox3 = 0;
+TTF_LONG FontBBox4 = 0;
+TTF_LONG UnderlinePosition = 0;
+TTF_LONG UnderlineThickness = 0;
+TTF_LONG CapHeight = 0;
+TTF_LONG XHeight = 0;
+TTF_LONG Ascender = 0;
+TTF_LONG Descender = 0;
+
+char *cur_file_name = NULL;
+char *bname = NULL;
+FILE *fontfile, *encfile, *outfile = NULL;
+char enc_line[ENC_BUF_SIZE];
+int print_glyph = AS_NAME; /* print glyph as names by default */
+int print_cmap = 0;
+int use_ext_enc = 0; /* use external encoding? */
+int select_unicode = 1; /* use the first unicode mapping by default */
+int printing_enc = 0; /* set to 1 while printing encodings */
+
+
+TTF_USHORT upem;
+TTF_USHORT ntabs;
+int nhmtx;
+int post_format;
+int loca_format;
+int nglyphs;
+int nkernpairs = 0;
+int names_count = 0;
+char *ps_glyphs_buf = NULL;
+dirtab_entry *dir_tab;
+mtx_entry *mtx_tab;
+kern_entry *kern_tab;
+char *enc_names[256];
+
+cmap_entry *cmap_tab;
+TTF_USHORT ncmapsubtabs;
+long cmap_offset;
+
+TTF_USHORT unicode_map[0xFFFF];
+
+#include "macnames.c"
+
+void ttf_fail(char *fmt, ...)
+{
+ va_list args;
+ va_start(args, fmt);
+ fprintf(stderr, "\nError: ttf2afm");
+ if (cur_file_name)
+ fprintf(stderr, " (file %s)", cur_file_name);
+ fprintf(stderr, ": ");
+ vfprintf(stderr, fmt, args);
+ fprintf(stderr, "\n");
+ va_end(args);
+ exit(-1);
+}
+
+void ttf_warn(char *fmt, ...)
+{
+ va_list args;
+ va_start(args, fmt);
+ fprintf(stderr, "\nWarning: ttf2afm");
+ if (cur_file_name)
+ fprintf(stderr, " (file %s)", cur_file_name);
+ fprintf(stderr, ": ");
+ vfprintf(stderr, fmt, args);
+ fprintf(stderr, "\n");
+ va_end(args);
+}
+
+int xgetc(FILE * stream)
+{
+ int c = getc(stream);
+ if (c < 0 && c != EOF)
+ ttf_fail("getc() failed");
+ return c;
+}
+
+long ttf_getnum(int s)
+{
+ long i = 0;
+ int c;
+ while (s > 0) {
+ if ((c = xgetc(fontfile)) < 0)
+ ttf_fail("unexpected EOF");
+ i = (i << 8) + c;
+ s--;
+ }
+ return i;
+}
+
+dirtab_entry *name_lookup(char *s)
+{
+ dirtab_entry *p;
+ for (p = dir_tab; p - dir_tab < ntabs; p++)
+ if (strncmp(p->tag, s, 4) == 0)
+ break;
+ if (p - dir_tab == ntabs)
+ p = NULL;
+ return p;
+}
+
+void ttf_seek_tab(char *name, TTF_LONG offset)
+{
+ dirtab_entry *p = name_lookup(name);
+ if (p == NULL)
+ ttf_fail("can't find table `%s'", name);
+ if (fseek(fontfile, p->offset + offset, SEEK_SET) < 0)
+ ttf_fail("fseek() failed while reading `%s' table", name);
+}
+
+void ttf_seek_off(char *name, TTF_LONG offset)
+{
+ if (fseek(fontfile, offset, SEEK_SET) < 0)
+ ttf_fail("fseek() failed while reading `%s' table", name);
+}
+
+void store_kern_value(TTF_USHORT i, TTF_USHORT j, TTF_FWORD v)
+{
+ kern_entry *pk;
+ for (pk = kern_tab + i; pk->next != NULL; pk = pk->next);
+ pk->next = xtalloc(1, kern_entry);
+ pk = pk->next;
+ pk->next = NULL;
+ pk->adjacent = j;
+ pk->value = v;
+}
+
+TTF_FWORD get_kern_value(TTF_USHORT i, TTF_USHORT j)
+{
+ kern_entry *pk;
+ for (pk = kern_tab + i; pk->next != NULL; pk = pk->next)
+ if (pk->adjacent == j)
+ return pk->value;
+ return 0;
+}
+
+void free_tabs()
+{
+ int i;
+ kern_entry *p, *q, *r;
+ unicode_entry *u, *v;
+ mtx_entry *pm;
+ xfree(ps_glyphs_buf);
+ xfree(dir_tab);
+ xfree(cmap_tab);
+ for (pm = mtx_tab; pm - mtx_tab < nglyphs; pm++)
+ if (pm->unicode_list != NULL) {
+ for (u = pm->unicode_list; u != NULL; u = v) {
+ v = u->next;
+ xfree(u);
+ }
+ }
+ xfree(mtx_tab);
+ for (i = 0; i < 256; i++)
+ if (enc_names[i] != notdef)
+ free(enc_names[i]);
+ if (kern_tab == NULL)
+ return;
+ for (p = kern_tab; p - kern_tab < nglyphs; p++)
+ if (p->next != NULL) {
+ for (q = p->next; q != NULL; q = r) {
+ r = q->next;
+ xfree(q);
+ }
+ }
+ xfree(kern_tab);
+}
+
+void enc_getline()
+{
+ char *p;
+ int c;
+ restart:
+ if (enc_eof())
+ ttf_fail("unexpected end of file");
+ p = enc_line;
+ do {
+ c = enc_getchar();
+ append_char_to_buf(c, p, enc_line, ENC_BUF_SIZE);
+ } while (c != 10);
+ append_eol(p, enc_line, ENC_BUF_SIZE);
+ if (p - enc_line <= 2 || *enc_line == '%')
+ goto restart;
+}
+
+void read_encoding(char *encname)
+{
+ char buf[ENC_BUF_SIZE], *q, *r;
+ int i;
+ cur_file_name = encname;
+ if ((encfile = kpse_open_file(encname, kpse_enc_format)) == NULL)
+ ttf_fail("can't open encoding file for reading");
+ enc_getline();
+ if (*enc_line != '/' || (r = strchr(enc_line, '[')) == 0)
+ ttf_fail("invalid encoding vector: name or `[' missing:\n%s", enc_line);
+ for (i = 0; i < 256; i++)
+ enc_names[i] = (char *) notdef;
+ if (r[1] == 32)
+ r += 2;
+ else
+ r++;
+ for (;;) {
+ while (*r == '/') {
+ for (q = buf, r++; *r != ' ' && *r != 10 && *r != ']' && *r != '/';
+ *q++ = *r++);
+ *q = 0;
+ if (*r == ' ')
+ r++;
+ if (strcmp(buf, notdef) != 0)
+ enc_names[names_count] = xstrdup(buf);
+ if (++names_count > 256)
+ ttf_fail("encoding vector contains more than 256 names");
+ }
+ if (*r != 10 && *r != '%') {
+ if (str_prefix(r, "] def"))
+ goto done;
+ else
+ ttf_fail
+ ("invalid encoding vector: a name or `] def' expected:\n%s",
+ enc_line);
+ }
+ enc_getline();
+ r = enc_line;
+ }
+ done:
+ xfclose(encfile, cur_file_name);
+ if (names_count != 256)
+ ttf_warn("encoding vector contains only %i names (expected %i)",
+ names_count, 256);
+}
+
+void append_unicode(long glyph_index, TTF_USHORT code)
+{
+ mtx_entry *m;
+ unicode_entry *u, *v;
+ assert(glyph_index >= 0 && glyph_index < nglyphs);
+ u = xtalloc(1, unicode_entry);
+ m = mtx_tab + glyph_index;
+ u->next = NULL;
+ u->code = code;
+ if (m->unicode_list == NULL)
+ m->unicode_list = u;
+ else {
+ for (v = m->unicode_list; v->next != NULL; v = v->next);
+ v->next = u;
+ }
+}
+
+void read_cmap()
+{
+ cmap_entry *e;
+ seg_entry *seg_tab, *s;
+ TTF_USHORT *glyphId, format, segCount;
+ long int n, i, k, length, index;
+ int unicode_map_count = 0;
+ ttf_seek_tab("cmap", TTF_USHORT_SIZE); /* skip the table vesrion number (=0) */
+ ncmapsubtabs = get_ushort();
+ cmap_offset = xftell(fontfile, cur_file_name) - 2 * TTF_USHORT_SIZE;
+ cmap_tab = xtalloc(ncmapsubtabs, cmap_entry);
+ for (e = cmap_tab; e - cmap_tab < ncmapsubtabs; e++) {
+ e->platform_id = get_ushort();
+ e->encoding_id = get_ushort();
+ e->offset = get_ulong();
+ }
+ for (i = 0; i < 0xFFFF; ++i)
+ unicode_map[i] = NOGLYPH_ASSIGNED_YET;
+ for (e = cmap_tab; e - cmap_tab < ncmapsubtabs; e++) {
+ ttf_seek_off("cmap", cmap_offset + e->offset);
+ format = get_ushort();
+ if (is_unicode_mapping(e) && format == 4) {
+ ++unicode_map_count;
+ if (unicode_map_count == select_unicode)
+ goto read_unicode_mapping;
+ }
+ continue;
+ read_unicode_mapping:
+ length = get_ushort(); /* length of subtable */
+ (void) get_ushort(); /* skip the version number */
+ segCount = get_ushort() / 2;
+ (void) get_ushort(); /* skip searchRange */
+ (void) get_ushort(); /* skip entrySelector */
+ (void) get_ushort(); /* skip rangeShift */
+ seg_tab = xtalloc(segCount, seg_entry);
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->endCode = get_ushort();
+ (void) get_ushort(); /* skip reversedPad */
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->startCode = get_ushort();
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->idDelta = get_ushort();
+ for (s = seg_tab; s - seg_tab < segCount; s++)
+ s->idRangeOffset = get_ushort();
+ length -= 8 * TTF_USHORT_SIZE + 4 * segCount * TTF_USHORT_SIZE;
+ n = length / TTF_USHORT_SIZE; /* number of glyphID's */
+ glyphId = xtalloc(n, TTF_USHORT);
+ for (i = 0; i < n; i++)
+ glyphId[i] = get_ushort();
+ for (s = seg_tab; s - seg_tab < segCount; s++) {
+ for (i = s->startCode; i <= s->endCode; i++) {
+ if (i == 0xFFFF)
+ break;
+ if (s->idRangeOffset != 0xFFFF) {
+ if (s->idRangeOffset == 0)
+ index = (s->idDelta + i) & 0xFFFF;
+ else {
+ k = (i - s->startCode) + s->idRangeOffset / 2 +
+ (s - seg_tab) - segCount;
+ assert(k >= 0 && k < n);
+ index = glyphId[k];
+ if (index != 0)
+ index = (index + s->idDelta) & 0xFFFF;
+ }
+ if (index < 0 || index >= nglyphs)
+ ttf_fail("cmap: glyph index out of range [0..%i)",
+ nglyphs);
+ if (unicode_map[i] != NOGLYPH_ASSIGNED_YET)
+ ttf_fail
+ ("cmap: unicode %.4X is mapped to multiple glyphs",
+ i);
+ if (unicode_map[i] == 0)
+ ttf_warn("unicode %.4X is mapped to glyph 0", i);
+ unicode_map[i] = index;
+ append_unicode(index, i);
+ }
+ }
+ }
+ xfree(seg_tab);
+ xfree(glyphId);
+ break;
+ }
+ if (e - cmap_tab == ncmapsubtabs)
+ ttf_fail("Invalid argument `-m %i': out of range [1..%i]",
+ select_unicode, unicode_map_count);
+}
+
+void read_font()
+{
+ long i, j, k, l, n, m, platform_id, encoding_id;
+ TTF_FWORD kern_value;
+ char buf[1024], *p;
+ dirtab_entry *pd;
+ kern_entry *pk;
+ mtx_entry *pm;
+ ttf_skip(TTF_FIXED_SIZE);
+ ntabs = get_ushort();
+ ttf_skip(3 * TTF_USHORT_SIZE);
+ dir_tab = xtalloc(ntabs, dirtab_entry);
+ for (pd = dir_tab; pd - dir_tab < ntabs; pd++) {
+ pd->tag[0] = get_char();
+ pd->tag[1] = get_char();
+ pd->tag[2] = get_char();
+ pd->tag[3] = get_char();
+ ttf_skip(TTF_ULONG_SIZE);
+ pd->offset = get_ulong();
+ pd->length = get_ulong();
+ }
+ ttf_seek_tab("head",
+ 2 * TTF_FIXED_SIZE + 2 * TTF_ULONG_SIZE + TTF_USHORT_SIZE);
+ upem = get_ushort();
+ ttf_skip(16);
+ FontBBox1 = get_fword();
+ FontBBox2 = get_fword();
+ FontBBox3 = get_fword();
+ FontBBox4 = get_fword();
+ ttf_skip(TTF_USHORT_SIZE);
+ ttf_skip(TTF_USHORT_SIZE + TTF_SHORT_SIZE);
+ loca_format = get_short();
+ ttf_seek_tab("maxp", TTF_FIXED_SIZE);
+ nglyphs = get_ushort();
+ mtx_tab = xtalloc(nglyphs + 1, mtx_entry);
+ for (pm = mtx_tab; pm - mtx_tab < nglyphs + 1; pm++) {
+ pm->name = NULL; /* notdef */
+ pm->found = 0;
+ pm->unicode_list = NULL;
+ }
+ ttf_seek_tab("hhea", TTF_FIXED_SIZE);
+ Ascender = get_fword();
+ Descender = get_fword();
+ ttf_skip(TTF_FWORD_SIZE + TTF_UFWORD_SIZE + 3 * TTF_FWORD_SIZE +
+ 8 * TTF_SHORT_SIZE);
+ nhmtx = get_ushort();
+ ttf_seek_tab("hmtx", 0);
+ for (pm = mtx_tab; pm - mtx_tab < nhmtx; pm++) {
+ pm->wx = get_ufword();
+ ttf_skip(TTF_FWORD_SIZE);
+ }
+ i = pm[-1].wx;
+ for (; pm - mtx_tab < nglyphs; pm++)
+ pm->wx = i;
+ ttf_seek_tab("post", 0);
+ post_format = get_fixed();
+ ItalicAngle = get_fixed();
+ UnderlinePosition = get_fword();
+ UnderlineThickness = get_fword();
+ IsFixedPitch = get_ulong();
+ ttf_skip(4 * TTF_ULONG_SIZE);
+ switch (post_format) {
+ case 0x00010000:
+ for (pm = mtx_tab; pm - mtx_tab < NMACGLYPHS; pm++)
+ pm->name = (char *) mac_glyph_names[pm - mtx_tab];
+ break;
+ case 0x00020000:
+ l = get_ushort(); /* some fonts have this value different from nglyphs */
+ for (pm = mtx_tab; pm - mtx_tab < l; pm++)
+ pm->index = get_ushort();
+ if ((pd = name_lookup("post")) == NULL)
+ ttf_fail("can't find table `post'");
+ n = pd->length - (xftell(fontfile, cur_file_name) - pd->offset);
+ ps_glyphs_buf = xtalloc(n + 1, char);
+ for (m = 0, p = ps_glyphs_buf; p - ps_glyphs_buf < n;) {
+ for (i = get_byte(); i > 0; i--)
+ *p++ = get_char();
+ *p++ = 0;
+ m++;
+ }
+ for (pm = mtx_tab; pm - mtx_tab < l; pm++) {
+ if (pm->index < NMACGLYPHS)
+ pm->name = (char *) mac_glyph_names[pm->index];
+ else {
+ k = pm->index - NMACGLYPHS;
+ if (k < m) {
+ for (p = ps_glyphs_buf; k > 0; k--)
+ p = (char *) strend(p) + 1;
+ pm->name = p;
+ } else {
+ pm->name = NULL; /* index out of valid range, fix name to notdef */
+ }
+ }
+ }
+ break;
+ case 0x00030000:
+ if (print_glyph == AS_NAME) {
+ ttf_warn
+ ("no names available in `post' table, print glyph names as indices");
+ print_glyph = AS_INDEX;
+ }
+ break;
+ default:
+ ttf_fail("unsupported format (%.8X) of `post' table", post_format);
+ }
+ ttf_seek_tab("loca", 0);
+ for (pm = mtx_tab; pm - mtx_tab < nglyphs + 1; pm++)
+ pm->offset = (loca_format == 1 ? get_ulong() : get_ushort() << 1);
+ if ((pd = name_lookup("glyf")) == NULL)
+ ttf_fail("can't find table `glyf'");
+ for (n = pd->offset, pm = mtx_tab; pm - mtx_tab < nglyphs; pm++) {
+ ttf_seek_off("glyf", n + pm->offset);
+ ttf_skip(TTF_SHORT_SIZE);
+ pm->bbox[0] = get_fword();
+ pm->bbox[1] = get_fword();
+ pm->bbox[2] = get_fword();
+ pm->bbox[3] = get_fword();
+ }
+
+ ttf_seek_tab("name", 0);
+ i = ftell(fontfile);
+ (void) get_ushort(); /* skip Format selector (=0) */
+ n = get_ushort(); /* number of name records */
+ j = get_ushort() + i; /* start of string storage */
+ i += 3 * TTF_USHORT_SIZE; /* update the current offset */
+ while (n-- > 0) {
+ ttf_seek_off("name", i);
+ platform_id = get_ushort();
+ encoding_id = get_ushort();
+ (void) get_ushort(); /* skip language_id */
+ k = get_ushort(); /* name_id */
+ l = get_ushort(); /* string length */
+ if ((platform_id == 1 && encoding_id == 0) &&
+ (k == 0 || k == 1 || k == 4 || k == 5 || k == 6)) {
+ ttf_seek_off("name", j + get_ushort());
+ for (p = buf; l-- > 0; p++)
+ *p = get_char();
+ *p++ = 0;
+ p = xstrdup(buf);
+ switch (k) {
+ case 0:
+ Notice = p;
+ break;
+ case 1:
+ FamilyName = p;
+ break;
+ case 4:
+ FullName = p;
+ break;
+ case 5:
+ Version = p;
+ break;
+ case 6:
+ FontName = p;
+ break;
+ }
+ if (Notice != NULL && FamilyName != NULL &&
+ FullName != NULL && FontName != NULL && Version != NULL)
+ break;
+ }
+ i += 6 * TTF_USHORT_SIZE;
+ }
+ if ((pd = name_lookup("PCLT")) != NULL) {
+ ttf_seek_off("PCLT",
+ pd->offset + TTF_FIXED_SIZE + TTF_ULONG_SIZE +
+ TTF_USHORT_SIZE);
+ XHeight = get_ushort();
+ if (XHeight > FontBBox4) {
+ ttf_warn("XHeight is too big (%i)\n"
+ "This is likely a font bug, so I discarded this parameter.",
+ (int) get_ttf_funit(XHeight));
+ XHeight = 0;
+ }
+ ttf_skip(2 * TTF_USHORT_SIZE);
+ CapHeight = get_ushort();
+ if (CapHeight > FontBBox4) {
+ ttf_warn("CapHeight is too big (%i)\n"
+ "This is likely a font bug, so I discarded this parameter.",
+ (int) get_ttf_funit(CapHeight));
+ CapHeight = 0;
+ }
+ }
+ if ((pd = name_lookup("OS/2")) != NULL) {
+ ttf_seek_off("OS/2", pd->offset + TTF_USHORT_SIZE + TTF_SHORT_SIZE);
+ switch (get_ushort()) {
+ case 100:
+ Weight = xstrdup("Thin");
+ break;
+ case 200:
+ Weight = xstrdup("ExtraLight");
+ break;
+ case 300:
+ Weight = xstrdup("Light");
+ break;
+ case 400:
+ Weight = xstrdup("Normal");
+ break;
+ case 500:
+ Weight = xstrdup("Medium");
+ break;
+ case 600:
+ Weight = xstrdup("SemiBold");
+ break;
+ case 700:
+ Weight = xstrdup("Bold");
+ break;
+ case 800:
+ Weight = xstrdup("ExtraBold");
+ break;
+ case 900:
+ Weight = xstrdup("Black");
+ break;
+ }
+ }
+ read_cmap();
+ if ((pd = name_lookup("kern")) == NULL)
+ return;
+ kern_tab = xtalloc(nglyphs, kern_entry);
+ for (pk = kern_tab; pk - kern_tab < nglyphs; pk++) {
+ pk->next = NULL;
+ pk->value = 0;
+ }
+ ttf_seek_off("kern", pd->offset + TTF_USHORT_SIZE);
+ for (n = get_ushort(); n > 0; n--) {
+ ttf_skip(2 * TTF_USHORT_SIZE);
+ k = get_ushort();
+ if (!(k & 1) || (k & 2) || (k & 4))
+ return;
+ if (k >> 8 != 0) {
+ ttf_warn("warning: only format 0 supported of `kern' \
+ subtables, others are ignored\n");
+ continue;
+ }
+ k = get_ushort();
+ ttf_skip(3 * TTF_USHORT_SIZE);
+ while (k-- > 0) {
+ i = get_ushort();
+ j = get_ushort();
+ kern_value = get_fword();
+ if (kern_value != 0) {
+ store_kern_value(i, j, kern_value);
+ nkernpairs++;
+ }
+ }
+ }
+}
+
+int null_glyph(const char *s)
+{
+ return (s == NULL || s == notdef);
+ /*
+ strcmp(s, ".null") == 0 ||
+ strcmp(s, ".notdef") == 0 ||
+ strcmp(s, "CR") == 0 ||
+ strcmp(s, "nonmarkingreturn") == 0
+ */
+}
+
+void print_glyph_name(FILE * f, long glyph_index, int convention)
+{
+ unicode_entry *u;
+ static char buf[1024];
+ const char *n;
+ assert(glyph_index >= 0 && glyph_index < nglyphs);
+ n = mtx_tab[glyph_index].name;
+ if (printing_enc && (n == notdef || glyph_index == 0)) {
+ fputs(notdef, f);
+ return;
+ }
+ switch (convention) {
+ case AS_NAME:
+ if (!null_glyph(n))
+ fprintf(f, "%s", mtx_tab[glyph_index].name);
+ else if (n == notdef && glyph_index == 0)
+ fputs(notdef, f);
+ else
+ fprintf(f, "%s%li", GLYPH_PREFIX_INDEX, glyph_index);
+ break;
+ case AS_INDEX:
+ fprintf(f, "%s%li", GLYPH_PREFIX_INDEX, glyph_index);
+ break;
+ case AS_UNICODE:
+ u = mtx_tab[glyph_index].unicode_list;
+ if (glyph_index == 0 || u == NULL)
+ fprintf(f, "%s%li", GLYPH_PREFIX_INDEX, glyph_index);
+ else {
+ fprintf(f, "%s%.4X", GLYPH_PREFIX_UNICODE, u->code);
+ if (u->next != NULL) {
+ *buf = 0;
+ for (; u != NULL; u = u->next) {
+ assert(strlen(buf) + strlen(GLYPH_PREFIX_UNICODE) + 4 <
+ sizeof(buf));
+ sprintf(strend(buf), "%s%.4X ", GLYPH_PREFIX_UNICODE,
+ u->code);
+ }
+ ttf_warn
+ ("glyph %li have multiple encodings (the first one being used): %s",
+ glyph_index, buf);
+ }
+ }
+ break;
+ }
+}
+
+void print_char_metric(FILE * f, int charcode, long glyph_index)
+{
+ assert(glyph_index >= 0 && glyph_index < nglyphs);
+ fprintf(f, "C %i ; WX %i ; N ", (int) charcode,
+ (int) get_ttf_funit(mtx_tab[glyph_index].wx));
+ print_glyph_name(f, glyph_index, print_glyph);
+ fprintf(f, " ; B %i %i %i %i ;\n",
+ (int) get_ttf_funit(mtx_tab[glyph_index].bbox[0]),
+ (int) get_ttf_funit(mtx_tab[glyph_index].bbox[1]),
+ (int) get_ttf_funit(mtx_tab[glyph_index].bbox[2]),
+ (int) get_ttf_funit(mtx_tab[glyph_index].bbox[3]));
+}
+
+void print_afm(char *date, char *fontname)
+{
+ int ncharmetrics;
+ mtx_entry *pm;
+ short mtx_index[256], *idx;
+ unsigned int index;
+ char **pe;
+ kern_entry *pk, *qk;
+ fputs("StartFontMetrics 2.0\n", outfile);
+ fprintf(outfile,
+ "Comment Converted at %s by ttf2afm from font file `%s'\n", date,
+ fontname);
+ print_str(FontName);
+ print_str(FullName);
+ print_str(FamilyName);
+ print_str(Weight);
+ fprintf(outfile, "ItalicAngle %i", (int) (ItalicAngle / 0x10000));
+ if (ItalicAngle % 0x10000 > 0)
+ fprintf(outfile, ".%i",
+ (int) ((ItalicAngle % 0x10000) * 1000) / 0x10000);
+ fputs("\n", outfile);
+ fprintf(outfile, "IsFixedPitch %s\n", IsFixedPitch ? "true" : "false");
+ fprintf(outfile, "FontBBox %i %i %i %i\n",
+ (int) get_ttf_funit(FontBBox1),
+ (int) get_ttf_funit(FontBBox2),
+ (int) get_ttf_funit(FontBBox3), (int) get_ttf_funit(FontBBox4));
+ print_dimen(UnderlinePosition);
+ print_dimen(UnderlineThickness);
+ print_str(Version);
+ print_str(Notice);
+ fputs("EncodingScheme FontSpecific\n", outfile);
+ print_dimen(CapHeight);
+ print_dimen(XHeight);
+ print_dimen(Ascender);
+ print_dimen(Descender);
+ ncharmetrics = nglyphs;
+ if (use_ext_enc == 0) { /* external encoding vector not given */
+ fprintf(outfile, "StartCharMetrics %u\n", ncharmetrics);
+ for (pm = mtx_tab; pm - mtx_tab < nglyphs; pm++) {
+ pm->found = 1;
+ print_char_metric(outfile, -1, pm - mtx_tab);
+ }
+ } else { /* external encoding vector given */
+ for (idx = mtx_index; idx - mtx_index < 256; *idx++ = 0);
+ for (pe = enc_names; pe - enc_names < names_count; pe++) {
+ if (*pe == notdef)
+ continue;
+ /* scan form `uniABCD' */
+ if (sscanf(*pe, GLYPH_PREFIX_UNICODE "%4X", &index) == 1) {
+ if (unicode_map[index] != NOGLYPH_ASSIGNED_YET) {
+ pm = mtx_tab + unicode_map[index];
+ mtx_index[pe - enc_names] = pm - mtx_tab;
+ pm->found = 1;
+ } else
+ ttf_warn("`unicode %s%.4X' is not mapped to any glyph",
+ GLYPH_PREFIX_UNICODE, index);
+ continue;
+ }
+ /* scan form `index123' */
+ if (sscanf(*pe, GLYPH_PREFIX_INDEX "%u", &index) == 1) {
+ if (index >= nglyphs)
+ ttf_fail("`%s' out of valid range [0..%i)", *pe, nglyphs);
+ pm = mtx_tab + index;
+ mtx_index[pe - enc_names] = pm - mtx_tab;
+ pm->found = 1;
+ continue;
+ }
+ for (pm = mtx_tab; pm - mtx_tab < nglyphs; pm++)
+ if (pm->name != NULL && strcmp(*pe, pm->name) == 0)
+ break;
+ if (pm - mtx_tab < nglyphs) {
+ mtx_index[pe - enc_names] = pm - mtx_tab;
+ pm->found = 1;
+ continue;
+ } else
+ ttf_warn("glyph `%s' not found", *pe);
+ }
+ fprintf(outfile, "StartCharMetrics %u\n", ncharmetrics);
+ for (idx = mtx_index; idx - mtx_index < 256; idx++) {
+ if (*idx != 0 && mtx_tab[*idx].found == 1)
+ print_char_metric(outfile, idx - mtx_index, *idx);
+ }
+ for (pm = mtx_tab; pm - mtx_tab < nglyphs; pm++) {
+ if (pm->found == 0)
+ print_char_metric(outfile, -1, pm - mtx_tab);
+ }
+ }
+ fputs("EndCharMetrics\n", outfile);
+ if (nkernpairs == 0)
+ goto end_kerns;
+ fprintf(outfile, "StartKernData\nStartKernPairs %i\n", nkernpairs);
+ for (pk = kern_tab; pk - kern_tab < nglyphs; pk++)
+ for (qk = pk; qk != NULL; qk = qk->next)
+ if (qk->value != 0) {
+ fputs("KPX ", outfile);
+ print_glyph_name(outfile, pk - kern_tab, print_glyph);
+ fputs(" ", outfile);
+ print_glyph_name(outfile, qk->adjacent, print_glyph);
+ fprintf(outfile, " %i\n", get_ttf_funit(qk->value));
+ }
+ fputs("EndKernPairs\nEndKernData\n", outfile);
+ end_kerns:
+ fputs("EndFontMetrics\n", outfile);
+}
+
+void print_encoding(char *fontname)
+{
+ long int i, k, first_code, length;
+ FILE *file;
+ TTF_USHORT format;
+ char *enc_name, *end_enc_name;
+ cmap_entry *e;
+ printing_enc = 1;
+ enc_name = xtalloc(strlen(bname) + 20, char);
+ strcpy(enc_name, bname);
+ end_enc_name = strend(enc_name);
+ for (e = cmap_tab; e - cmap_tab < ncmapsubtabs; e++) {
+ ttf_seek_off("cmap", cmap_offset + e->offset);
+ format = get_ushort();
+ if (format != 0 && format != 4 && format != 6) {
+ ttf_warn("format %i of encoding subtable unsupported",
+ (int) format);
+ continue;
+ }
+ sprintf(end_enc_name, ".e%i%i",
+ (int) e->platform_id, (int) e->encoding_id);
+ if ((file = xfopen(enc_name, FOPEN_W_MODE)) == NULL)
+ ttf_fail("cannot open file for writing (%s)\n", enc_name);
+ fprintf(file, "%% Encoding table from font file %s\n", fontname);
+ fprintf(file, "%% Platform ID %i", (int) e->platform_id);
+ switch (e->platform_id) {
+ case 0:
+ fprintf(file, " (Apple Unicode)");
+ break;
+ case 1:
+ fprintf(file, " (Macintosh)");
+ break;
+ case 2:
+ fprintf(file, " (ISO)");
+ break;
+ case 3:
+ fprintf(file, " (Microsoft)");
+ break;
+ }
+ fprintf(file, "\n");
+ fprintf(file, "%% Encoding ID %i", (int) e->encoding_id);
+ if (e->platform_id == 1 && e->encoding_id == 0)
+ fprintf(file, " (Roman)");
+ if (e->platform_id == 3)
+ switch (e->encoding_id) {
+ case 0:
+ fprintf(file, " (Symbol)");
+ break;
+ case 1:
+ fprintf(file, " (Unicode)");
+ break;
+ }
+ fprintf(file, "\n");
+ fprintf(file, "%% Format %i", (int) (format));
+ switch (format) {
+ case 0:
+ fprintf(file, " (byte encoding table)");
+ break;
+ case 4:
+ fprintf(file, " (segment mapping to delta values)");
+ break;
+ case 6:
+ fprintf(file, " (trimmed table mapping)");
+ break;
+ }
+ fprintf(file, "\n");
+ fprintf(file, "/Encoding%i [\n", (int) (e - cmap_tab + 1));
+ switch (format) {
+ case 0:
+ (void) get_ushort(); /* skip length */
+ (void) get_ushort(); /* skip version number */
+ for (i = 0; i < 256; i++) {
+ fputs("/", file);
+ print_glyph_name(file, get_byte(), print_glyph);
+ fputs("\n", file);
+ }
+ break;
+ case 4:
+ for (i = 0; i < nglyphs; ++i) {
+ fprintf(file, "%% Glyph %li -> ", i);
+ print_glyph_name(file, i, AS_UNICODE);
+ fputs("\n", file);
+ }
+ break;
+ case 6:
+ (void) get_ushort(); /* skip table length */
+ (void) get_ushort(); /* skip version number */
+ first_code = get_ushort(); /* first character code */
+ for (i = 0; i < first_code; ++i)
+ fprintf(file, "/%s\n", notdef);
+ length = get_ushort(); /* number of character codes */
+ for (i = first_code; i < first_code + length; i++) {
+ k = get_ushort();
+ if (i > 255)
+ fputs("% ", file);
+ fputs("/", file);
+ print_glyph_name(file, k, print_glyph);
+ fputs("\n", file);
+ }
+ for (i = first_code + length; i < 256; i++)
+ fprintf(file, "/%s\n", notdef);
+ break;
+ default:
+ ttf_warn("format %i of encoding subtable unsupported",
+ (int) format);
+ }
+ fprintf(file, "] def\n");
+ }
+ xfree(enc_name);
+}
+
+void usage()
+{
+ cur_file_name = NULL;
+ fprintf(stderr,
+ "Usage: ttf2afm [-i|-u|-c|-v] [-e enc] [-o filename] [-m NUM] fontfile\n"
+ " -i: force printing glyph names in form 'index123'\n"
+ " -u: force printing glyph names in form 'uniABCD'\n"
+ " -c: print encoding tables to `basename.e<platformID><encodingID>'\n"
+ " -v: print version\n"
+ " -e enc: encode the AFM output using encoding vector from `enc'\n"
+ " -o filename: write output to file `filename' instead of stdout\n"
+ " -m NUM: select unicode mapping (default = 1, ie the first)\n"
+ " fontfile: the TrueType fontfile\n"
+ "\nPlease send bug reports or feature requests to <pdftex@tug.org>\n");
+ _exit(-1);
+}
+
+int main(int argc, char **argv)
+{
+ char date[128], *s;
+ time_t t = time(&t);
+ int c;
+ kpse_set_progname(argv[0]);
+ kpse_init_prog("ttf2afm", 0, 0, 0);
+ while ((c = getopt(argc, argv, "iucve:o:m:")) != -1)
+ switch (c) {
+ case 'i':
+ print_glyph = AS_INDEX;
+ break;
+ case 'u':
+ print_glyph = AS_UNICODE;
+ break;
+ case 'c':
+ print_cmap = 1;
+ break;
+ case 'e':
+ cur_file_name = optarg;
+ read_encoding(cur_file_name);
+ use_ext_enc = 1;
+ break;
+ case 'o':
+ cur_file_name = optarg;
+ outfile = xfopen(cur_file_name, FOPEN_W_MODE);
+ if (outfile == NULL)
+ ttf_fail("cannot open file for writing");
+ break;
+ case 'm':
+ select_unicode = atoi(optarg);
+ break;
+ case 'v':
+ fprintf(stderr,
+ "ttf2afm version " VERSION "\n"
+ "Copyright (C) 1997-2005 Han The Thanh.\n"
+ "There is NO warranty. Redistribution of this software is\n"
+ "covered by the terms of both the pdfTeX copyright and\n"
+ "the GNU General Public License.\n"
+ "For more information about these matters, see the files\n"
+ "named COPYING and the pdfTeX source.\n"
+ "Primary author of ttf2afm: Han The Thanh.\n");
+ _exit(0);
+ default:
+ usage();
+ }
+ if (argc - optind != 1)
+ usage();
+ sprintf(date, "%s\n", ctime(&t));
+ *(char *) strchr(date, '\n') = 0;
+ cur_file_name = argv[optind];
+ if (print_cmap) {
+ bname = xstrdup(xbasename(cur_file_name));
+ if ((s = strrchr(bname, '.')) != NULL)
+ *s = 0;
+ }
+ if ((fontfile =
+ kpse_open_file(cur_file_name, kpse_truetype_format)) == NULL)
+ ttf_fail("can't open font file for reading");
+ read_font();
+ if (outfile == NULL)
+ outfile = stdout;
+ print_afm(date, cur_file_name);
+ if (print_cmap)
+ print_encoding(cur_file_name);
+ xfree(FontName);
+ xfree(FullName);
+ xfree(FamilyName);
+ xfree(Notice);
+ xfree(Version);
+ xfree(Weight);
+ free_tabs();
+ xfclose(fontfile, cur_file_name);
+ return 0;
+}
diff --git a/Build/source/texk/web2c/luatexdir/ttf2afm.rc b/Build/source/texk/web2c/luatexdir/ttf2afm.rc
new file mode 100644
index 00000000000..a63881df7d1
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/ttf2afm.rc
@@ -0,0 +1,35 @@
+/* ttf2afm.rc: ttf2afm -*- C++ -*-
+
+ Copyright (C) 1996-2003 Fabrice Popineau <fabrice.popineau@supelec.fr>
+
+ This file is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published
+ by the Free Software Foundation; either version 2, or (at your
+ option) any later version.
+
+ This file is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this file; if not, write to the Free Software
+ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+ USA. */
+
+#include <texlive-version.h>
+
+#define VER_FILEVERSION TEXLIVE_MAJOR_VERSION,TEXLIVE_MINOR_VERSION,TEXLIVE_BETA_NUMBER,TEXLIVE_ALPHA_NUMBER
+#define VER_FILEVERSION_STR TEXLIVE_PRODUCTVERSION_STR " ttf2afm 1.10a"
+
+#define VER_INTERNALNAME_STR "ttf2afm"
+#define VER_ORIGINALFILENAME_STR "ttf2afm.exe"
+
+#define VER_FILEDESCRIPTION_STR "TTF-to-AFM Converter"
+
+#define VER_COMPANYNAME_STR ""
+#define VER_LEGALCOPYRIGHT_STR "Copyright (c) 1996-2002 Han The Thanh, <thanh@pdftex.org>"
+
+#include "texlive.version"
+
+/* ttf2afm.rc ends here */
diff --git a/Build/source/texk/web2c/luatexdir/utils.c b/Build/source/texk/web2c/luatexdir/utils.c
new file mode 100644
index 00000000000..707ac7855f9
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/utils.c
@@ -0,0 +1,1798 @@
+/*
+Copyright (c) 1996-2006 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id$
+*/
+
+#include "sys/types.h"
+#ifndef __MINGW32__
+#include "sysexits.h"
+#else
+#define EX_SOFTWARE 70
+#endif
+#include "md5.h"
+#include <kpathsea/c-proto.h>
+#include <kpathsea/c-stat.h>
+#include <kpathsea/c-fopen.h>
+#include <string.h>
+#include <time.h>
+#include <float.h> /* for DBL_EPSILON */
+#include "zlib.h"
+#include "ptexlib.h"
+
+#include "svnversion.h"
+
+#include "openbsd-compat.h"
+#include "png.h"
+#include "xpdf/config.h" /* just to get the xpdf version */
+
+#define check_nprintf(size_get, size_want) \
+ if ((unsigned)(size_get) >= (unsigned)(size_want)) \
+ pdftex_fail ("snprintf failed: file %s, line %d", __FILE__, __LINE__);
+
+char *cur_file_name = NULL;
+strnumber last_tex_string;
+static char print_buf[PRINTF_BUF_SIZE];
+static char *jobname_cstr = NULL;
+static char *job_id_string = NULL;
+extern string ptexbanner; /* from web2c/lib/texmfmp.c */
+extern string versionstring; /* from web2c/lib/version.c */
+extern KPSEDLL string kpathsea_version_string; /* from kpathsea/version.c */
+
+size_t last_ptr_index; /* for use with alloc_array */
+
+/* define fb_ptr, fb_array & fb_limit */
+typedef char fb_entry;
+define_array (fb);
+
+/* define char_ptr, char_array & char_limit */
+typedef char char_entry;
+define_array (char);
+
+integer fb_offset (void)
+{
+ return fb_ptr - fb_array;
+}
+
+void fb_seek (integer offset)
+{
+ fb_ptr = fb_array + offset;
+}
+
+void fb_putchar (eight_bits b)
+{
+ alloc_array (fb, 1, SMALL_ARRAY_SIZE);
+ *fb_ptr++ = b;
+}
+
+void fb_flush (void)
+{
+ fb_entry *p;
+ integer n;
+ for (p = fb_array; p < fb_ptr;) {
+ n = pdf_buf_size - pdf_ptr;
+ if (fb_ptr - p < n)
+ n = fb_ptr - p;
+ memcpy (pdf_buf + pdf_ptr, p, (unsigned) n);
+ pdf_ptr += n;
+ if (pdf_ptr == pdf_buf_size)
+ pdf_flush ();
+ p += n;
+ }
+ fb_ptr = fb_array;
+}
+
+#define SUBSET_TAG_LENGTH 6
+void make_subset_tag(fd_entry * fd)
+{
+ int i, j = 0, a[SUBSET_TAG_LENGTH];
+ md5_state_t pms;
+ char *glyph;
+ glw_entry *glw_glyph;
+ struct avl_traverser t;
+ md5_byte_t digest[16];
+ void **aa;
+ static struct avl_table *st_tree = NULL;
+ if (st_tree == NULL)
+ st_tree = avl_create(comp_string_entry, NULL, &avl_xallocator);
+ assert(fd != NULL);
+ assert(fd->gl_tree != NULL);
+ assert(fd->fontname != NULL);
+ assert(fd->subset_tag == NULL);
+ fd->subset_tag = xtalloc(SUBSET_TAG_LENGTH + 1, char);
+ do {
+ md5_init(&pms);
+ avl_t_init(&t, fd->gl_tree);
+ if (is_cidkeyed(fd->fm)) { /* glw_entry items */
+ for (glw_glyph = (glw_entry *) avl_t_first(&t, fd->gl_tree); glw_glyph != NULL;
+ glw_glyph = (glw_entry *) avl_t_next(&t)) {
+ glyph = malloc(12);
+ sprintf(glyph,"%05u%05u ",glw_glyph->id,glw_glyph->wd);
+ md5_append(&pms, (md5_byte_t *) glyph, strlen(glyph));
+ free(glyph);
+ }
+ } else {
+ for (glyph = (char *) avl_t_first(&t, fd->gl_tree); glyph != NULL;
+ glyph = (char *) avl_t_next(&t)) {
+ md5_append(&pms, (md5_byte_t *) glyph, strlen(glyph));
+ md5_append(&pms, (md5_byte_t *) " ", 1);
+ }
+ }
+ md5_append(&pms, (md5_byte_t *) fd->fontname, strlen(fd->fontname));
+ md5_append(&pms, (md5_byte_t *) & j, sizeof(int)); /* to resolve collision */
+ md5_finish(&pms, digest);
+ for (a[0] = 0, i = 0; i < 13; i++)
+ a[0] += digest[i];
+ for (i = 1; i < SUBSET_TAG_LENGTH; i++)
+ a[i] = a[i - 1] - digest[i - 1] + digest[(i + 12) % 16];
+ for (i = 0; i < SUBSET_TAG_LENGTH; i++)
+ fd->subset_tag[i] = a[i] % 26 + 'A';
+ fd->subset_tag[SUBSET_TAG_LENGTH] = '\0';
+ j++;
+ assert(j < 100);
+ }
+ while ((char *) avl_find(st_tree, fd->subset_tag) != NULL);
+ aa = avl_probe(st_tree, fd->subset_tag);
+ assert(aa != NULL);
+ if (j > 2)
+ pdftex_warn
+ ("\nmake_subset_tag(): subset-tag collision, resolved in round %d.\n",
+ j);
+}
+
+void pdf_puts (const char *s)
+{
+ pdfroom (strlen (s) + 1);
+ while (*s)
+ pdf_buf[pdf_ptr++] = *s++;
+}
+
+__attribute__ ((format (printf, 1, 2)))
+void pdf_printf (const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+ vsnprintf (print_buf, PRINTF_BUF_SIZE, fmt, args);
+ pdf_puts (print_buf);
+ va_end (args);
+}
+
+strnumber maketexstring (const char *s)
+{
+ if (s == NULL || *s == 0)
+ return get_nullstr ();
+ return maketexlstring(s,strlen(s));
+}
+
+strnumber maketexlstring (const char *s, size_t l)
+{
+ if (s == NULL || l == 0)
+ return get_nullstr ();
+ check_pool_overflow (pool_ptr + l);
+ while (l-- > 0)
+ str_pool[pool_ptr++] = *s++;
+ last_tex_string = make_string ();
+ return last_tex_string;
+}
+
+
+/* print a C string through TeX */
+void
+print_string (char *j) {
+ while (*j) {
+ print_char(*j);
+ j++;
+ }
+}
+
+/* append a C string to a TeX string */
+void
+append_string (char *s) {
+ if (s == NULL || *s == 0)
+ return;
+ check_buf (pool_ptr + strlen(s), pool_size);
+ while (*s)
+ str_pool[pool_ptr++] = *s++;
+ return;
+}
+
+__attribute__ ((format (printf, 1, 2)))
+void tex_printf (const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+ vsnprintf (print_buf, PRINTF_BUF_SIZE, fmt, args);
+ print_string (print_buf);
+ xfflush (stdout);
+ va_end (args);
+}
+
+/* Helper for pdftex_fail. */
+static void safe_print (const char *str)
+{
+ const char *c;
+ for (c = str; *c; ++c)
+ print (*c);
+}
+
+void remove_pdffile (void)
+{
+ if (!kpathsea_debug && output_file_name && !fixed_pdf_draftmode) {
+ xfclose (pdf_file, makecstring (output_file_name));
+ remove (makecstring (output_file_name));
+ }
+}
+
+/* pdftex_fail may be called when a buffer overflow has happened/is
+ happening, therefore may not call mktexstring. However, with the
+ current implementation it appears that error messages are misleading,
+ possibly because pool overflows are detected too late.
+
+ The output format of this fuction must be the same as pdf_error in
+ pdftex.web! */
+
+__attribute__ ((noreturn, format (printf, 1, 2)))
+void pdftex_fail (const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+ print_ln ();
+ safe_print ("!luaTeX error");
+ if (cur_file_name) {
+ safe_print (" (file ");
+ safe_print (cur_file_name);
+ safe_print (")");
+ }
+ safe_print (": ");
+ vsnprintf (print_buf, PRINTF_BUF_SIZE, fmt, args);
+ safe_print (print_buf);
+ va_end (args);
+ print_ln ();
+ remove_pdffile();
+ safe_print (" ==> Fatal error occurred, no output PDF file produced!");
+ print_ln ();
+ if (kpathsea_debug) {
+ abort ();
+ } else {
+ exit (EX_SOFTWARE);
+ }
+}
+
+/* The output format of this fuction must be the same as pdf_warn in
+ pdftex.web! */
+
+__attribute__ ((format (printf, 1, 2)))
+void pdftex_warn (const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+ print_ln ();
+ tex_printf ("luaTeX warning");
+ if (cur_file_name)
+ tex_printf (" (file %s)", cur_file_name);
+ tex_printf (": ");
+ vsnprintf (print_buf, PRINTF_BUF_SIZE, fmt, args);
+ print_string (print_buf);
+ va_end (args);
+ print_ln ();
+}
+
+
+void tex_error(char *msg, char **hlp) {
+ strnumber aa = 0,bb = 0,cc = 0,dd = 0,ee = 0;
+ int k = 0;
+ while (hlp[k]!=NULL)
+ k++;
+ if (k>0) aa =maketexstring(hlp[0]);
+ if (k>1) bb =maketexstring(hlp[1]);
+ if (k>2) cc =maketexstring(hlp[2]);
+ if (k>3) dd =maketexstring(hlp[3]);
+ if (k>4) ee =maketexstring(hlp[4]);
+
+ do_print_err(maketexstring(msg));
+ flush_str(last_tex_string);
+
+ switch (k) {
+ case 1: dohelp1(aa); break;
+ case 2: dohelp2(aa,bb); break;
+ case 3: dohelp3(aa,bb,cc); break;
+ case 4: dohelp4(aa,bb,cc,dd); break;
+ case 5: dohelp5(aa,bb,cc,dd,ee); break;
+ }
+ error();
+
+ if (ee) flush_str(ee);
+ if (dd) flush_str(dd);
+ if (cc) flush_str(cc);
+ if (bb) flush_str(bb);
+ if (aa) flush_str(aa);
+}
+
+
+void garbage_warning (void)
+{
+ pdftex_warn ("dangling objects discarded, no output file produced.");
+ remove_pdffile ();
+}
+
+char *makecstring (integer s) {
+ int l;
+ return makeclstring(s,&l);
+}
+
+
+char *makeclstring (integer s, int *len)
+{
+ static char *cstrbuf = NULL;
+ char *p;
+ static int allocsize;
+ int allocgrow, i, l;
+ if (s >=2097152) {
+ s -= 2097152;
+ l = str_start[s + 1] - str_start[s];
+ *len = l;
+ check_buf (l + 1, MAX_CSTRING_LEN);
+ if (cstrbuf == NULL) {
+ allocsize = l + 1;
+ cstrbuf = xmallocarray (char, allocsize);
+ } else if (l + 1 > allocsize) {
+ allocgrow = allocsize * 0.2;
+ if (l + 1 - allocgrow > allocsize)
+ allocsize = l + 1;
+ else if (allocsize < MAX_CSTRING_LEN - allocgrow)
+ allocsize += allocgrow;
+ else
+ allocsize = MAX_CSTRING_LEN;
+ cstrbuf = xreallocarray (cstrbuf, char, allocsize);
+ }
+ p = cstrbuf;
+ for (i = 0; i < l; i++)
+ *p++ = str_pool[i + str_start[s]];
+ *p = 0;
+ } else {
+ if (cstrbuf == NULL) {
+ allocsize = 5;
+ cstrbuf = xmallocarray (char, allocsize);
+ }
+ if (s <= 0x7F) {
+ cstrbuf[0] = s;
+ cstrbuf[1] = 0;
+ *len = 1;
+ } else if (s <= 0x7FF ) {
+ cstrbuf[0] = 0xC0 + (s / 0x40);
+ cstrbuf[1] = 0x80 + (s % 0x40);
+ cstrbuf[2] = 0;
+ *len = 2;
+ } else if (s <= 0xFFFF ) {
+ cstrbuf[0] = 0xE0 + (s / 0x1000);
+ cstrbuf[1] = 0x80 + ((s % 0x1000) / 0x40);
+ cstrbuf[2] = 0x80 + ((s % 0x1000) % 0x40);
+ cstrbuf[3] = 0;
+ *len = 3;
+ } else {
+ if (s >= 0x10FF00) {
+ cstrbuf[0] = s-0x10FF00;
+ cstrbuf[1] = 0;
+ *len = 1;
+ } else {
+ cstrbuf[0] = 0xF0 + (s / 0x40000);
+ cstrbuf[1] = 0x80 + ((s % 0x40000) / 0x1000);
+ cstrbuf[2] = 0x80 + (((s % 0x40000) % 0x1000) / 0x40);
+ cstrbuf[3] = 0x80 + (((s % 0x40000) % 0x1000) % 0x40);
+ cstrbuf[4] = 0;
+ *len = 4;
+ }
+ }
+ }
+ return cstrbuf;
+}
+
+void set_job_id (int year, int month, int day, int time)
+{
+ char *name_string, *format_string, *s;
+ size_t slen;
+ int i;
+
+ if (job_id_string != NULL)
+ return;
+
+ name_string = xstrdup (makecstring (job_name));
+ format_string = xstrdup (makecstring (format_ident));
+ slen = SMALL_BUF_SIZE +
+ strlen (name_string) +
+ strlen (format_string) +
+ strlen (ptexbanner) +
+ strlen (versionstring) + strlen (kpathsea_version_string);
+ s = xtalloc (slen, char);
+ /* The Web2c version string starts with a space. */
+ i = snprintf (s, slen,
+ "%.4d/%.2d/%.2d %.2d:%.2d %s %s %s%s %s",
+ year, month, day, time / 60, time % 60,
+ name_string, format_string, ptexbanner,
+ versionstring, kpathsea_version_string);
+ check_nprintf(i,slen);
+ job_id_string = xstrdup (s);
+ xfree (s);
+ xfree (name_string);
+ xfree (format_string);
+}
+
+int get_build_revision (void) {
+ int revision;
+ if(sscanf (BUILD_REVISION,"$Revision: %d $", &revision)) {
+ return revision;
+ }
+ return 0;
+}
+
+void make_pdftex_banner (void)
+{
+ static boolean pdftexbanner_init = false;
+ char *s;
+ size_t slen;
+ int i;
+
+ if (pdftexbanner_init)
+ return;
+
+ slen = SMALL_BUF_SIZE +
+ strlen (ptexbanner) +
+ strlen (versionstring) + strlen (kpathsea_version_string);
+ s = xtalloc (slen, char);
+ /* The Web2c version string starts with a space. */
+ i = snprintf (s, slen,
+ "%s%s %s", ptexbanner, versionstring, kpathsea_version_string);
+ check_nprintf (i, slen);
+ pdftex_banner = maketexstring (s);
+ xfree (s);
+ pdftexbanner_init = true;
+}
+
+strnumber get_resname_prefix (void)
+{
+/* static char name_str[] = */
+/* "!\"$&'*+,-.0123456789:;=?@ABCDEFGHIJKLMNOPQRSTUVWXYZ\\" */
+/* "^_`abcdefghijklmnopqrstuvwxyz|~"; */
+ static char name_str[] =
+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
+ char prefix[7]; /* make a tag of 6 chars long */
+ unsigned long crc;
+ short i;
+ size_t base = strlen (name_str);
+ crc = crc32 (0L, Z_NULL, 0);
+ crc = crc32 (crc, (Bytef *) job_id_string, strlen (job_id_string));
+ for (i = 0; i < 6; i++) {
+ prefix[i] = name_str[crc % base];
+ crc /= base;
+ }
+ prefix[6] = 0;
+ return maketexstring (prefix);
+}
+
+size_t xfwrite (void *ptr, size_t size, size_t nmemb, FILE * stream)
+{
+ if (fwrite (ptr, size, nmemb, stream) != nmemb)
+ pdftex_fail ("fwrite() failed");
+ return nmemb;
+}
+
+int xfflush (FILE * stream)
+{
+ if (fflush (stream) != 0)
+ pdftex_fail ("fflush() failed");
+ return 0;
+}
+
+int xgetc (FILE * stream)
+{
+ int c = getc (stream);
+ if (c < 0 && c != EOF)
+ pdftex_fail ("getc() failed");
+ return c;
+}
+
+int xputc (int c, FILE * stream)
+{
+ int i = putc (c, stream);
+ if (i < 0)
+ pdftex_fail ("putc() failed");
+ return i;
+}
+
+void write_stream_length (integer length, integer offset)
+{
+ if (jobname_cstr == NULL)
+ jobname_cstr = xstrdup (makecstring (job_name));
+ if (fixed_pdf_draftmode == 0) {
+ xfseek (pdf_file, offset, SEEK_SET, jobname_cstr);
+ fprintf (pdf_file, "%li", (long int) length);
+ xfseek (pdf_file, pdfoffset (), SEEK_SET, jobname_cstr);
+ }
+}
+
+scaled ext_xn_over_d (scaled x, scaled n, scaled d)
+{
+ double r = (((double) x) * ((double) n)) / ((double) d);
+ if (r > DBL_EPSILON)
+ r += 0.5;
+ else
+ r -= 0.5;
+ if (r >= (double) maxinteger || r <= -(double) maxinteger)
+ pdftex_warn ("arithmetic: number too big");
+ return (scaled) r;
+}
+
+void libpdffinish ()
+{
+ xfree (fb_array);
+ xfree (char_array);
+ xfree (job_id_string);
+ fm_free ();
+ t1_free ();
+ enc_free ();
+ epdf_free ();
+ ttf_free ();
+ sfd_free ();
+ glyph_unicode_free ();
+ zip_free ();
+}
+
+/* Converts any string given in in in an allowed PDF string which can be
+ * handled by printf et.al.: \ is escaped to \\, parenthesis are escaped and
+ * control characters are octal encoded.
+ * This assumes that the string does not contain any already escaped
+ * characters!
+ */
+char *convertStringToPDFString (const char *in, int len)
+{
+ static char pstrbuf[MAX_PSTRING_LEN];
+ char *out = pstrbuf;
+ int i, j, k;
+ char buf[5];
+ j = 0;
+ for (i = 0; i < len; i++) {
+ check_buf (j + sizeof (buf), MAX_PSTRING_LEN);
+ if (((unsigned char) in[i] < '!') || ((unsigned char) in[i] > '~')) {
+ /* convert control characters into oct */
+ k = snprintf (buf, sizeof (buf),
+ "\\%03o", (unsigned int) (unsigned char) in[i]);
+ check_nprintf (k, sizeof (buf));
+ out[j++] = buf[0];
+ out[j++] = buf[1];
+ out[j++] = buf[2];
+ out[j++] = buf[3];
+ } else if ((in[i] == '(') || (in[i] == ')')) {
+ /* escape paranthesis */
+ out[j++] = '\\';
+ out[j++] = in[i];
+ } else if (in[i] == '\\') {
+ /* escape backslash */
+ out[j++] = '\\';
+ out[j++] = '\\';
+ } else {
+ /* copy char :-) */
+ out[j++] = in[i];
+ }
+ }
+ out[j] = '\0';
+ return pstrbuf;
+}
+
+
+/* Converts any string given in in in an allowed PDF string which can be
+ * handled by printf et.al.: \ is escaped to \\, parenthesis are escaped and
+ * control characters are octal encoded.
+ * This assumes that the string does not contain any already escaped
+ * characters!
+ *
+ * See escapename for parameter description.
+ */
+void escapestring (poolpointer in)
+{
+ const poolpointer out = pool_ptr;
+ unsigned char ch;
+ int i;
+ while (in < out) {
+ if (pool_ptr + 4 >= pool_size) {
+ pool_ptr = pool_size;
+ /* error by str_toks that calls str_room(1) */
+ return;
+ }
+
+ ch = (unsigned char) str_pool[in++];
+
+ if ((ch < '!') || (ch > '~')) {
+ /* convert control characters into oct */
+ i = snprintf ((char *) &str_pool[pool_ptr], 5,
+ "\\%.3o", (unsigned int) ch);
+ check_nprintf (i, 5);
+ pool_ptr += i;
+ continue;
+ }
+ if ((ch == '(') || (ch == ')') || (ch == '\\')) {
+ /* escape parenthesis and backslash */
+ str_pool[pool_ptr++] = '\\';
+ }
+ /* copy char :-) */
+ str_pool[pool_ptr++] = ch;
+ }
+}
+
+
+/* Convert any given string in a PDF name using escaping mechanism
+ of PDF 1.2. The result does not include the leading slash.
+
+ PDF specification 1.6, section 3.2.6 "Name Objects" explains:
+ <blockquote>
+ Beginning with PDF 1.2, any character except null (character code 0) may
+ be included in a name by writing its 2-digit hexadecimal code, preceded
+ by the number sign character (#); see implementation notes 3 and 4 in
+ Appendix H. This syntax is required to represent any of the delimiter or
+ white-space characters or the number sign character itself; it is
+ recommended but not required for characters whose codes are outside the
+ range 33 (!) to 126 (~).
+ </blockquote>
+ The following table shows the conversion that are done by this
+ function:
+ code result reason
+ -----------------------------------
+ 0 ignored not allowed
+ 1..32 escaped must for white-space:
+ 9 (tab), 10 (lf), 12 (ff), 13 (cr), 32 (space)
+ recommended for the other control characters
+ 35 escaped escape char "#"
+ 37 escaped delimiter "%"
+ 40..41 escaped delimiters "(" and ")"
+ 47 escaped delimiter "/"
+ 60 escaped delimiter "<"
+ 62 escaped delimiter ">"
+ 91 escaped delimiter "["
+ 93 escaped delimiter "]"
+ 123 escaped delimiter "{"
+ 125 escaped delimiter "}"
+ 127..255 escaped recommended
+ else copy regular characters
+
+ Parameter "in" is a pointer into the string pool where
+ the input string is located. The output string is written
+ as temporary string right after the input string.
+ Thus at the begin of the procedure the global variable
+ "pool_ptr" points to the start of the output string and
+ after the end when the procedure returns.
+*/
+void escapename (poolpointer in)
+{
+ const poolpointer out = pool_ptr;
+ unsigned char ch;
+ int i;
+
+ while (in < out) {
+ if (pool_ptr + 3 >= pool_size) {
+ pool_ptr = pool_size;
+ /* error by str_toks that calls str_room(1) */
+ return;
+ }
+
+ ch = (unsigned char) str_pool[in++];
+
+ if ((ch >= 1 && ch <= 32) || ch >= 127) {
+ /* escape */
+ i = snprintf ((char *) &str_pool[pool_ptr], 4,
+ "#%.2X", (unsigned int) ch);
+ check_nprintf (i, 4);
+ pool_ptr += i;
+ continue;
+ }
+ switch (ch) {
+ case 0:
+ /* ignore */
+ break;
+ case 35:
+ case 37:
+ case 40:
+ case 41:
+ case 47:
+ case 60:
+ case 62:
+ case 91:
+ case 93:
+ case 123:
+ case 125:
+ /* escape */
+ i = snprintf ((char *) &str_pool[pool_ptr], 4,
+ "#%.2X", (unsigned int) ch);
+ check_nprintf (i, 4);
+ pool_ptr += i;
+ break;
+ default:
+ /* copy */
+ str_pool[pool_ptr++] = ch;
+ }
+ }
+}
+
+/* Convert any given string in a PDF hexadecimal string. The
+ result does not include the angle brackets.
+
+ This procedure uses uppercase hexadecimal letters.
+
+ See escapename for description of parameters.
+*/
+void escapehex (poolpointer in)
+{
+ const poolpointer out = pool_ptr;
+ unsigned char ch;
+ int i;
+
+ while (in < out) {
+ if (pool_ptr + 2 >= pool_size) {
+ pool_ptr = pool_size;
+ /* error by str_toks that calls str_room(1) */
+ return;
+ }
+
+ ch = (unsigned char) str_pool[in++];
+
+ i = snprintf ((char *) &str_pool[pool_ptr], 3,"%.2X", (unsigned int) ch);
+ check_nprintf (i, 3);
+ pool_ptr += 2;
+ }
+}
+
+/* Unescape any given hexadecimal string.
+
+ Last hex digit can be omitted, it is replaced by zero, see
+ PDF specification.
+
+ Invalid digits are silently ignored.
+
+ See escapename for description of parameters.
+*/
+void unescapehex (poolpointer in)
+{
+ const poolpointer out = pool_ptr;
+ unsigned char ch;
+ boolean first = true;
+ unsigned char a = 0; /* to avoid warning about uninitialized use of a */
+ while (in < out) {
+ if (pool_ptr + 1 >= pool_size) {
+ pool_ptr = pool_size;
+ /* error by str_toks that calls str_room(1) */
+ return;
+ }
+
+ ch = (unsigned char) str_pool[in++];
+
+ if ((ch >= '0') && (ch <= '9')) {
+ ch -= '0';
+ } else if ((ch >= 'A') && (ch <= 'F')) {
+ ch -= 'A' - 10;
+ } else if ((ch >= 'a') && (ch <= 'f')) {
+ ch -= 'a' - 10;
+ } else {
+ continue; /* ignore wrong character */
+ }
+
+ if (first) {
+ a = ch << 4;
+ first = false;
+ continue;
+ }
+
+ str_pool[pool_ptr++] = a + ch;
+ first = true;
+ }
+ if (!first) { /* last hex digit is omitted */
+ str_pool[pool_ptr++] = ch << 4;
+ }
+}
+
+
+/* Converts any string given in in in an allowed PDF string which is
+ * hexadecimal encoded;
+ * sizeof(out) should be at least lin*2+1.
+ */
+static void convertStringToHexString (const char *in, char *out, int lin)
+{
+ int i, j, k;
+ char buf[3];
+ j = 0;
+ for (i = 0; i < lin; i++) {
+ k = snprintf (buf, sizeof (buf),
+ "%02X", (unsigned int) (unsigned char) in[i]);
+ check_nprintf (k, sizeof (buf));
+ out[j++] = buf[0];
+ out[j++] = buf[1];
+ }
+ out[j] = '\0';
+}
+
+/* Compute the ID string as per PDF1.4 9.3:
+ <blockquote>
+ File identifers are defined by the optional ID entry in a PDF file's
+ trailer dictionary (see Section 3.4.4, "File Trailer"; see also
+ implementation note 105 in Appendix H). The value of this entry is an
+ array of two strings. The first string is a permanent identifier based
+ on the contents of the file at the time it was originally created, and
+ does not change when the file is incrementally updated. The second
+ string is a changing identifier based on the file's contents at the
+ time it was last updated. When a file is first written, both
+ identifiers are set to the same value. If both identifiers match when a
+ file reference is resolved, it is very likely that the correct file has
+ been found; if only the first identifier matches, then a different
+ version of the correct file has been found.
+ To help ensure the uniqueness of file identifiers, it is recommend
+ that they be computed using a message digest algorithm such as MD5
+ (described in Internet RFC 1321, The MD5 Message-Digest Algorithm; see
+ the Bibliography), using the following information (see implementation
+ note 106 in Appendix H):
+ - The current time
+ - A string representation of the file's location, usually a pathname
+ - The size of the file in bytes
+ - The values of all entries in the file's document information
+ dictionary (see Section 9.2.1, Document Information Dictionary )
+ </blockquote>
+ This stipulates only that the two IDs must be identical when the file is
+ created and that they should be reasonably unique. Since it's difficult
+ to get the file size at this point in the execution of pdfTeX and
+ scanning the info dict is also difficult, we start with a simpler
+ implementation using just the first two items.
+ */
+void print_ID (strnumber filename)
+{
+ time_t t;
+ size_t size;
+ char time_str[32];
+ md5_state_t state;
+ md5_byte_t digest[16];
+ char id[64];
+ char *file_name;
+ char pwd[4096];
+ /* start md5 */
+ md5_init (&state);
+ /* get the time */
+ t = time (NULL);
+ size =
+ strftime (time_str, sizeof (time_str), "%Y%m%dT%H%M%SZ", gmtime (&t));
+ md5_append (&state, (const md5_byte_t *) time_str, size);
+ /* get the file name */
+ if (getcwd (pwd, sizeof (pwd)) == NULL)
+ pdftex_fail ("getcwd() failed (path too long?)");
+ file_name = makecstring (filename);
+ md5_append (&state, (const md5_byte_t *) pwd, strlen (pwd));
+ md5_append (&state, (const md5_byte_t *) "/", 1);
+ md5_append (&state, (const md5_byte_t *) file_name, strlen (file_name));
+ /* finish md5 */
+ md5_finish (&state, digest);
+ /* write the IDs */
+ convertStringToHexString ((char *) digest, id, 16);
+ pdf_printf ("/ID [<%s> <%s>]", id, id);
+}
+
+/* Print the /CreationDate entry.
+
+ PDF Reference, third edition says about the expected date format:
+ <blockquote>
+ 3.8.2 Dates
+
+ PDF defines a standard date format, which closely follows that of
+ the international standard ASN.1 (Abstract Syntax Notation One),
+ defined in ISO/IEC 8824 (see the Bibliography). A date is a string
+ of the form
+
+ (D:YYYYMMDDHHmmSSOHH'mm')
+
+ where
+
+ YYYY is the year
+ MM is the month
+ DD is the day (01-31)
+ HH is the hour (00-23)
+ mm is the minute (00-59)
+ SS is the second (00-59)
+ O is the relationship of local time to Universal Time (UT),
+ denoted by one of the characters +, -, or Z (see below)
+ HH followed by ' is the absolute value of the offset from UT
+ in hours (00-23)
+ mm followed by ' is the absolute value of the offset from UT
+ in minutes (00-59)
+
+ The apostrophe character (') after HH and mm is part of the syntax.
+ All fields after the year are optional. (The prefix D:, although also
+ optional, is strongly recommended.) The default values for MM and DD
+ are both 01; all other numerical fields default to zero values. A plus
+ sign (+) as the value of the O field signifies that local time is
+ later than UT, a minus sign (-) that local time is earlier than UT,
+ and the letter Z that local time is equal to UT. If no UT information
+ is specified, the relationship of the specified time to UT is
+ considered to be unknown. Whether or not the time zone is known, the
+ rest of the date should be specified in local time.
+
+ For example, December 23, 1998, at 7:52 PM, U.S. Pacific Standard
+ Time, is represented by the string
+
+ D:199812231952-08'00'
+ </blockquote>
+
+ The main difficulty is get the time zone offset. strftime() does this in ISO
+ C99 (e.g. newer glibc) with %z, but we have to work with other systems (e.g.
+ Solaris 2.5).
+*/
+
+static time_t start_time = 0;
+#define TIME_STR_SIZE 30
+static char start_time_str[TIME_STR_SIZE];
+static char time_str[TIME_STR_SIZE];
+ /* minimum size for time_str is 24: "D:YYYYmmddHHMMSS+HH'MM'" */
+
+static void makepdftime (time_t t, char *time_str)
+{
+
+ struct tm lt, gmt;
+ size_t size;
+ int i, off, off_hours, off_mins;
+
+ /* get the time */
+ lt = *localtime (&t);
+ size = strftime (time_str, TIME_STR_SIZE, "D:%Y%m%d%H%M%S", &lt);
+ /* expected format: "YYYYmmddHHMMSS" */
+ if (size == 0) {
+ /* unexpected, contents of time_str is undefined */
+ time_str[0] = '\0';
+ return;
+ }
+
+ /* correction for seconds: %S can be in range 00..61,
+ the PDF reference expects 00..59,
+ therefore we map "60" and "61" to "59" */
+ if (time_str[14] == '6') {
+ time_str[14] = '5';
+ time_str[15] = '9';
+ time_str[16] = '\0'; /* for safety */
+ }
+
+ /* get the time zone offset */
+ gmt = *gmtime (&t);
+
+ /* this calculation method was found in exim's tod.c */
+ off = 60 * (lt.tm_hour - gmt.tm_hour) + lt.tm_min - gmt.tm_min;
+ if (lt.tm_year != gmt.tm_year) {
+ off += (lt.tm_year > gmt.tm_year) ? 1440 : -1440;
+ } else if (lt.tm_yday != gmt.tm_yday) {
+ off += (lt.tm_yday > gmt.tm_yday) ? 1440 : -1440;
+ }
+
+ if (off == 0) {
+ time_str[size++] = 'Z';
+ time_str[size] = 0;
+ } else {
+ off_hours = off / 60;
+ off_mins = abs (off - off_hours * 60);
+ i = snprintf (&time_str[size], 9,
+ "%+03d'%02d'", off_hours, off_mins);
+ check_nprintf (i, 9);
+ }
+}
+
+void init_start_time ()
+{
+ if (start_time == 0) {
+ start_time = time ((time_t *) NULL);
+ makepdftime (start_time, start_time_str);
+ }
+}
+
+void print_creation_date ()
+{
+ init_start_time ();
+ pdf_printf ("/CreationDate (%s)\n", start_time_str);
+}
+
+void print_mod_date ()
+{
+ init_start_time ();
+ pdf_printf ("/ModDate (%s)\n", start_time_str);
+}
+
+void getcreationdate ()
+{
+ /* put creation date on top of string pool and update pool_ptr */
+ size_t len = strlen (start_time_str);
+
+ init_start_time ();
+
+ if ((unsigned)(pool_ptr + len) >= (unsigned)pool_size) {
+ pool_ptr = pool_size;
+ /* error by str_toks that calls str_room(1) */
+ return;
+ }
+
+ memcpy (&str_pool[pool_ptr], start_time_str, len);
+ pool_ptr += len;
+}
+
+/* makecfilename
+ input/ouput same as makecstring:
+ input: string number
+ output: C string with quotes removed.
+ That means, file names that are legal on some operation systems
+ cannot any more be used since pdfTeX version 1.30.4.
+*/
+char *makecfilename (strnumber s)
+{
+ char *name = makecstring (s);
+ char *p = name;
+ char *q = name;
+
+ while (*p) {
+ if (*p != '"')
+ *q++ = *p;
+ p++;
+ }
+ *q = '\0';
+ return name;
+}
+
+/* function strips trailing zeros in string with numbers; */
+/* leading zeros are not stripped (as in real life) */
+char *stripzeros (char *a)
+{
+ enum { NONUM, DOTNONUM, INT, DOT, LEADDOT, FRAC } s = NONUM, t = NONUM;
+ char *p, *q, *r;
+ for (p = q = r = a; *p != '\0';) {
+ switch (s) {
+ case NONUM:
+ if (*p >= '0' && *p <= '9')
+ s = INT;
+ else if (*p == '.')
+ s = LEADDOT;
+ break;
+ case DOTNONUM:
+ if (*p != '.' && (*p < '0' || *p > '9'))
+ s = NONUM;
+ break;
+ case INT:
+ if (*p == '.')
+ s = DOT;
+ else if (*p < '0' || *p > '9')
+ s = NONUM;
+ break;
+ case DOT:
+ case LEADDOT:
+ if (*p >= '0' && *p <= '9')
+ s = FRAC;
+ else if (*p == '.')
+ s = DOTNONUM;
+ else
+ s = NONUM;
+ break;
+ case FRAC:
+ if (*p == '.')
+ s = DOTNONUM;
+ else if (*p < '0' || *p > '9')
+ s = NONUM;
+ break;
+ default:;
+ }
+ switch (s) {
+ case DOT:
+ r = q;
+ break;
+ case LEADDOT:
+ r = q + 1;
+ break;
+ case FRAC:
+ if (*p > '0')
+ r = q + 1;
+ break;
+ case NONUM:
+ if ((t == FRAC || t == DOT) && r != a) {
+ q = r--;
+ if (*r == '.') /* was a LEADDOT */
+ *r = '0';
+ r = a;
+ }
+ break;
+ default:;
+ }
+ *q++ = *p++;
+ t = s;
+ }
+ *q = '\0';
+ return a;
+}
+
+void initversionstring(char **versions)
+{
+ (void) asprintf(versions,
+ "This is build %d, created on %dT%06dZ\n"
+ "Compiled with libpng %s; using libpng %s\n"
+ "Compiled with zlib %s; using zlib %s\n"
+ "Compiled with xpdf version %s\n",
+ get_build_revision(), BUILD_DATE, (BUILD_TIME-1000000),
+ PNG_LIBPNG_VER_STRING, png_libpng_ver,
+ ZLIB_VERSION, zlib_version, xpdfVersion);
+}
+
+
+/*************************************************/
+/* Color Stack and Matrix Transformation Support */
+/*************************************************/
+
+/*
+ In the following array and especially stack data structures are used.
+ They have the following properties:
+ - They automatically grow dynamically.
+ - The size never decreases.
+ - The variable with name ending in "size" contains the number how many
+ entries the data structure can hold.
+ - The variable with name ending in "used" contains the number of
+ actually used entries.
+ - Memory of strings in stack entries must be allocated and
+ freed if the stack is cleared.
+*/
+
+/* Color Stack */
+
+#define STACK_INCREMENT 8
+#define MAX_COLORSTACKS 32768
+/* The colorstack number is stored in two bytes (info field of the node) */
+/* Condition (newcolorstack): MAX_COLORSTACKS mod STACK_INCREMENT = 0 */
+
+#define COLOR_DEFAULT "0 g 0 G"
+/* literal_modes, see pdftex.web */
+#define SET_ORIGIN 0
+#define DIRECT_PAGE 1
+#define DIRECT_ALWAYS 2
+
+/* remember shipout mode: page/form */
+static boolean page_mode;
+
+typedef struct {
+ char **page_stack;
+ char **form_stack;
+ char *page_current;
+ char *form_current;
+ char *form_init;
+ int page_size;
+ int form_size;
+ int page_used;
+ int form_used;
+ int literal_mode;
+ boolean page_start;
+} colstack_type;
+
+static colstack_type *colstacks = NULL;
+static int colstacks_size = 0;
+static int colstacks_used = 0;
+
+/*
+ Initialization is done, if the color stacks are used,
+ init_colorstacks() is defined as macro to avoid unnecessary
+ procedure calls.
+*/
+#define init_colorstacks() if (colstacks_size == 0) colstacks_first_init();
+void colstacks_first_init()
+{
+ colstacks_size = STACK_INCREMENT;
+ colstacks = xtalloc(colstacks_size, colstack_type);
+ colstacks_used = 1;
+ colstacks[0].page_stack = NULL;
+ colstacks[0].form_stack = NULL;
+ colstacks[0].page_size = 0;
+ colstacks[0].form_size = 0;
+ colstacks[0].page_used = 0;
+ colstacks[0].form_used = 0;
+ colstacks[0].page_current = xstrdup(COLOR_DEFAULT);
+ colstacks[0].form_current = xstrdup(COLOR_DEFAULT);
+ colstacks[0].form_init = xstrdup(COLOR_DEFAULT);
+ colstacks[0].literal_mode = DIRECT_ALWAYS;
+ colstacks[0].page_start = true;
+}
+
+int colorstackused()
+{
+ init_colorstacks();
+ return colstacks_used;
+}
+
+/*
+ newcolorstack()
+ A new color stack is setup with the given parameters.
+ The stack number is returned or -1 in case of error (no room).
+*/
+int newcolorstack(integer s, integer literal_mode, boolean page_start)
+{
+ colstack_type *colstack;
+ int colstack_num;
+ char *str;
+
+ init_colorstacks();
+
+ /* make room */
+ if (colstacks_used == MAX_COLORSTACKS) {
+ return -1;
+ }
+ if (colstacks_used == colstacks_size) {
+ colstacks_size += STACK_INCREMENT;
+ /* If (MAX_COLORSTACKS mod STACK_INCREMENT = 0) then we don't
+ need to check the case that size overruns MAX_COLORSTACKS. */
+ colstacks = xreallocarray(colstacks, colstack_type, colstacks_size);
+ }
+ /* claim new color stack */
+ colstack_num = colstacks_used++;
+ colstack = &colstacks[colstack_num];
+ /* configure the new color stack */
+ colstack->page_stack = NULL;
+ colstack->form_stack = NULL;
+ colstack->page_size = 0;
+ colstack->page_used = 0;
+ colstack->form_size = 0;
+ colstack->form_used = 0;
+ colstack->literal_mode = literal_mode;
+ colstack->page_start = page_start;
+ str = makecstring(s);
+ if (*str == 0) {
+ colstack->page_current = NULL;
+ colstack->form_current = NULL;
+ colstack->form_init = NULL;
+ } else {
+ colstack->page_current = xstrdup(str);
+ colstack->form_current = xstrdup(str);
+ colstack->form_init = xstrdup(str);
+ }
+ return colstack_num;
+}
+
+#define get_colstack(n) (&colstacks[n])
+
+/*
+ Puts a string on top of the string pool and updates pool_ptr.
+*/
+void put_cstring_on_str_pool(poolpointer start, char *str)
+{
+ size_t len;
+
+ if (str == NULL || *str == 0) {
+ return;
+ }
+
+ len = strlen(str);
+ pool_ptr = start + len;
+ if (pool_ptr >= pool_size) {
+ pool_ptr = pool_size;
+ /* error by str_toks that calls str_room(1) */
+ return;
+ }
+ memcpy(&str_pool[start], str, len);
+}
+
+integer colorstackset(int colstack_no, integer s)
+{
+ colstack_type *colstack = get_colstack(colstack_no);
+
+ if (page_mode) {
+ xfree(colstack->page_current);
+ colstack->page_current = xstrdup(makecstring(s));
+ } else {
+ xfree(colstack->form_current);
+ colstack->form_current = xstrdup(makecstring(s));
+ }
+ return colstack->literal_mode;
+}
+
+integer colorstackcurrent(int colstack_no)
+{
+ colstack_type *colstack = get_colstack(colstack_no);
+
+ if (page_mode) {
+ put_cstring_on_str_pool(pool_ptr, colstack->page_current);
+ } else {
+ put_cstring_on_str_pool(pool_ptr, colstack->form_current);
+ }
+ return colstack->literal_mode;
+}
+
+integer colorstackpush(int colstack_no, integer s)
+{
+ colstack_type *colstack = get_colstack(colstack_no);
+ char *str;
+
+ if (page_mode) {
+ if (colstack->page_used == colstack->page_size) {
+ colstack->page_size += STACK_INCREMENT;
+ colstack->page_stack = xretalloc(colstack->page_stack,
+ colstack->page_size, char *);
+ }
+ colstack->page_stack[colstack->page_used++] = colstack->page_current;
+ str = makecstring(s);
+ if (*str == 0) {
+ colstack->page_current = NULL;
+ } else {
+ colstack->page_current = xstrdup(str);
+ }
+ } else {
+ if (colstack->form_used == colstack->form_size) {
+ colstack->form_size += STACK_INCREMENT;
+ colstack->form_stack = xretalloc(colstack->form_stack,
+ colstack->form_size, char *);
+ }
+ colstack->form_stack[colstack->form_used++] = colstack->form_current;
+ str = makecstring(s);
+ if (*str == 0) {
+ colstack->form_current = NULL;
+ } else {
+ colstack->form_current = xstrdup(str);
+ }
+ }
+ return colstack->literal_mode;
+}
+
+integer colorstackpop(int colstack_no)
+{
+ colstack_type *colstack = get_colstack(colstack_no);
+
+ if (page_mode) {
+ if (colstack->page_used == 0) {
+ pdftex_warn("pop empty color page stack %u",
+ (unsigned int) colstack_no);
+ return colstack->literal_mode;
+ }
+ xfree(colstack->page_current);
+ colstack->page_current = colstack->page_stack[--colstack->page_used];
+ put_cstring_on_str_pool(pool_ptr, colstack->page_current);
+ } else {
+ if (colstack->form_used == 0) {
+ pdftex_warn("pop empty color form stack %u",
+ (unsigned int) colstack_no);
+ return colstack->literal_mode;
+ }
+ xfree(colstack->form_current);
+ colstack->form_current = colstack->form_stack[--colstack->form_used];
+ put_cstring_on_str_pool(pool_ptr, colstack->form_current);
+ }
+ return colstack->literal_mode;
+}
+
+void colorstackpagestart()
+{
+ int i, j;
+ colstack_type *colstack;
+
+ if (page_mode) {
+ /* see procedure pdf_out_colorstack_startpage */
+ return;
+ }
+
+ for (i = 0; i < colstacks_used; i++) {
+ colstack = &colstacks[i];
+ for (j = 0; j < colstack->form_used; j++) {
+ xfree(colstack->form_stack[j]);
+ }
+ colstack->form_used = 0;
+ xfree(colstack->form_current);
+ if (colstack->form_init == NULL) {
+ colstack->form_current = NULL;
+ } else {
+ colstack->form_current = xstrdup(colstack->form_init);
+ }
+ }
+}
+
+integer colorstackskippagestart(int colstack_no)
+{
+ colstack_type *colstack = get_colstack(colstack_no);
+
+ if (!colstack->page_start) {
+ return 1;
+ }
+ if (strcmp(COLOR_DEFAULT, colstack->page_current) == 0) {
+ return 2;
+ }
+ return 0;
+}
+
+
+/* stack for \pdfsetmatrix */
+
+typedef struct {
+ double a;
+ double b;
+ double c;
+ double d;
+ double e;
+ double f;
+} matrix_entry;
+static matrix_entry *matrix_stack = 0;
+static int matrix_stack_size = 0;
+static int matrix_stack_used = 0;
+
+boolean matrixused()
+{
+ return matrix_stack_used > 0;
+}
+
+/* stack for positions of \pdfsave */
+typedef struct {
+ int pos_h;
+ int pos_v;
+ int matrix_stack;
+} pos_entry;
+static pos_entry *pos_stack = 0; /* the stack */
+static int pos_stack_size = 0; /* initially empty */
+static int pos_stack_used = 0; /* used entries */
+
+void matrix_stack_room()
+{
+ matrix_entry *new_stack;
+
+ if (matrix_stack_used >= matrix_stack_size) {
+ matrix_stack_size += STACK_INCREMENT;
+ new_stack = xtalloc(matrix_stack_size, matrix_entry);
+ memcpy((void *) new_stack, (void *) matrix_stack,
+ matrix_stack_used * sizeof(matrix_entry));
+ xfree(matrix_stack);
+ matrix_stack = new_stack;
+ }
+}
+
+void checkpdfsave(int cur_h, int cur_v)
+{
+ pos_entry *new_stack;
+
+ if (pos_stack_used >= pos_stack_size) {
+ pos_stack_size += STACK_INCREMENT;
+ new_stack = xtalloc(pos_stack_size, pos_entry);
+ memcpy((void *) new_stack, (void *) pos_stack,
+ pos_stack_used * sizeof(pos_entry));
+ xfree(pos_stack);
+ pos_stack = new_stack;
+ }
+ pos_stack[pos_stack_used].pos_h = cur_h;
+ pos_stack[pos_stack_used].pos_v = cur_v;
+ if (page_mode) {
+ pos_stack[pos_stack_used].matrix_stack = matrix_stack_used;
+ }
+ pos_stack_used++;
+}
+
+void checkpdfrestore(int cur_h, int cur_v)
+{
+ int diff_h, diff_v;
+ if (pos_stack_used == 0) {
+ pdftex_warn("%s", "\\pdfrestore: missing \\pdfsave");
+ return;
+ }
+ pos_stack_used--;
+ diff_h = cur_h - pos_stack[pos_stack_used].pos_h;
+ diff_v = cur_v - pos_stack[pos_stack_used].pos_v;
+ if (diff_h != 0 || diff_v != 0) {
+ pdftex_warn("Misplaced \\pdfrestore by (%usp, %usp)", diff_h, diff_v);
+ }
+ if (page_mode) {
+ matrix_stack_used = pos_stack[pos_stack_used].matrix_stack;
+ }
+}
+
+void pdfshipoutbegin(boolean shipping_page)
+{
+ pos_stack_used = 0; /* start with empty stack */
+
+ page_mode = shipping_page;
+ if (shipping_page) {
+ colorstackpagestart();
+ }
+}
+
+void pdfshipoutend(boolean shipping_page)
+{
+ if (pos_stack_used > 0) {
+ pdftex_warn("%u unmatched \\pdfsave after %s shipout",
+ (unsigned int) pos_stack_used,
+ ((shipping_page) ? "page" : "form"));
+ }
+}
+
+/*
+ \pdfsetmatrix{a b c d}
+ e := cur_h
+ f := cur_v
+ M_top: current active matrix at the top of
+ the matrix stack
+
+ The origin of \pdfsetmatrix is the current point.
+ The annotation coordinate system is the original
+ page coordinate system. When pdfTeX calculates
+ annotation rectangles it does not take into
+ account this transformations, it uses the original
+ coordinate system. To get the corrected values,
+ first we go back to the origin, perform the
+ transformation and go back:
+
+ ( 1 0 0 ) ( a b 0 ) ( 1 0 0 )
+ ( 0 1 0 ) x ( c d 0 ) x ( 0 1 0 ) x M_top
+ ( -e -f 1 ) ( 0 0 1 ) ( e f 1 )
+
+ ( 1 0 0 ) ( a b 0 )
+ = ( 0 1 0 ) x ( c d 0 ) x M_top
+ ( e f 1 ) ( -e -f 1 )
+
+ ( a b 0 )
+ = ( c d 0 ) x M_top
+ ( e(1-a)-fc f(1-d)-eb 1 )
+
+*/
+
+void pdfsetmatrix(poolpointer in, scaled cur_h, scaled cur_v)
+{
+ /* Argument of \pdfsetmatrix starts with str_pool[in] and ends
+ before str_pool[pool_ptr]. */
+
+ matrix_entry x, *y, *z;
+
+ if (page_mode) {
+ if (sscanf((const char *) &str_pool[in], " %lf %lf %lf %lf ",
+ &x.a, &x.b, &x.c, &x.d) != 4) {
+ pdftex_warn("Unrecognized format of \\pdfsetmatrix{%s}",
+ &str_pool[pool_ptr]);
+ return;
+ }
+ /* calculate this transformation matrix */
+ x.e = (double) cur_h *(1.0 - x.a) - (double) cur_v *x.c;
+ x.f = (double) cur_v *(1.0 - x.d) - (double) cur_h *x.b;
+ matrix_stack_room();
+ z = &matrix_stack[matrix_stack_used];
+ if (matrix_stack_used > 0) {
+ y = &matrix_stack[matrix_stack_used - 1];
+ z->a = x.a * y->a + x.b * y->c;
+ z->b = x.a * y->b + x.b * y->d;
+ z->c = x.c * y->a + x.d * y->c;
+ z->d = x.c * y->b + x.d * y->d;
+ z->e = x.e * y->a + x.f * y->c + y->e;
+ z->f = x.e * y->b + x.f * y->d + y->f;
+ } else {
+ z->a = x.a;
+ z->b = x.b;
+ z->c = x.c;
+ z->d = x.d;
+ z->e = x.e;
+ z->f = x.f;
+ }
+ matrix_stack_used++;
+ }
+}
+
+/* Apply matrix to point (x,y)
+
+ ( a b 0 )
+ ( x y 1 ) x ( c d 0 ) = ( xa+yc+e xb+yd+f 1 )
+ ( e f 1 )
+
+ If \pdfsetmatrix wasn't used, then return the value unchanged.
+*/
+
+/* Return valeus for matrix tranform functions */
+static scaled ret_llx;
+static scaled ret_lly;
+static scaled ret_urx;
+static scaled ret_ury;
+
+scaled getllx()
+{
+ return ret_llx;
+}
+
+scaled getlly()
+{
+ return ret_lly;
+}
+
+scaled geturx()
+{
+ return ret_urx;
+}
+
+scaled getury()
+{
+ return ret_ury;
+}
+
+static int last_llx;
+static int last_lly;
+static int last_urx;
+static int last_ury;
+
+#define DO_ROUND(x) ((x > 0) ? (x + .5) : (x - .5))
+#define DO_MIN(a, b) ((a < b) ? a : b)
+#define DO_MAX(a, b) ((a > b) ? a : b)
+
+void do_matrixtransform(scaled x, scaled y, scaled * retx, scaled * rety)
+{
+ matrix_entry *m = &matrix_stack[matrix_stack_used - 1];
+ double x_old = x;
+ double y_old = y;
+ double x_new = x_old * m->a + y_old * m->c + m->e;
+ double y_new = x_old * m->b + y_old * m->d + m->f;
+ *retx = (scaled) DO_ROUND(x_new);
+ *rety = (scaled) DO_ROUND(y_new);
+}
+
+void matrixtransformrect(scaled llx, scaled lly, scaled urx, scaled ury)
+{
+ scaled x1, x2, x3, x4, y1, y2, y3, y4;
+
+ if (page_mode && matrix_stack_used > 0) {
+ last_llx = llx;
+ last_lly = lly;
+ last_urx = urx;
+ last_ury = ury;
+ do_matrixtransform(llx, lly, &x1, &y1);
+ do_matrixtransform(llx, ury, &x2, &y2);
+ do_matrixtransform(urx, lly, &x3, &y3);
+ do_matrixtransform(urx, ury, &x4, &y4);
+ ret_llx = DO_MIN(DO_MIN(x1, x2), DO_MIN(x3, x4));
+ ret_lly = DO_MIN(DO_MIN(y1, y2), DO_MIN(y3, y4));
+ ret_urx = DO_MAX(DO_MAX(x1, x2), DO_MAX(x3, x4));
+ ret_ury = DO_MAX(DO_MAX(y1, y2), DO_MAX(y3, y4));
+ } else {
+ ret_llx = llx;
+ ret_lly = lly;
+ ret_urx = urx;
+ ret_ury = ury;
+ }
+}
+
+void matrixtransformpoint(scaled x, scaled y)
+{
+ if (page_mode && matrix_stack_used > 0) {
+ do_matrixtransform(x, y, &ret_llx, &ret_lly);
+ } else {
+ ret_llx = x;
+ ret_lly = y;
+ }
+}
+
+void matrixrecalculate(scaled urx)
+{
+ matrixtransformrect(last_llx, last_lly, urx, last_ury);
+}
+
+void
+check_buffer_overflow (int wsize) {
+ int nsize;
+ if (wsize>buf_size) {
+ nsize = buf_size + buf_size/5+5;
+ if (nsize<wsize) {
+ nsize = wsize+5;
+ }
+ buffer = (unsigned char *)xreallocarray (buffer, char, nsize);
+ buf_size = nsize;
+ }
+}
+
+#define EXTRA_STRING 500
+
+void
+check_pool_overflow (int wsize) {
+ int nsize ;
+ if ((wsize-1)>pool_size) {
+ nsize = pool_size + pool_size/5+EXTRA_STRING;
+ if (nsize<wsize) {
+ nsize = wsize+EXTRA_STRING;
+ }
+ str_pool = (unsigned char *)xreallocarray (str_pool, char, nsize);
+ pool_size = nsize;
+ }
+}
+
+#define max_integer 0x7FFFFFFF
+
+/* the return value is a decimal number with the point |dd| places from the back,
+ |scaled_out| is the number of scaled points corresponding to that.
+*/
+
+scaled divide_scaled (scaled s, scaled m, integer dd) {
+ register scaled q;
+ register scaled r;
+ int i;
+ int sign = 1;
+ if (s < 0) {
+ sign = -sign;
+ s = -s;
+ }
+ if (m < 0) {
+ sign = -sign;
+ m = -m;
+ }
+ if (m == 0) {
+ pdf_error(maketexstring("arithmetic"), maketexstring("divided by zero"));
+ } else if (m >= (max_integer / 10)) {
+ pdf_error(maketexstring("arithmetic"), maketexstring("number too big"));
+ }
+ q = s / m;
+ r = s % m;
+ for (i = 1;i<=(int)dd;i++) {
+ q = 10*q + (10*r) / m;
+ r = (10*r) % m;
+ }
+ /* rounding */
+ if (2*r >= m) {
+ q++;
+ r -= m;
+ }
+ /* set up the value of q, in scaled points */
+ switch(dd) {
+ case 0: scaled_out = sign*(s - r); break;
+ case 1: scaled_out = sign*(s - (r/10)); break;
+ case 2: scaled_out = sign*(s - (r/100)); break;
+ case 3: scaled_out = sign*(s - (r/1000)); break;
+ case 4: scaled_out = sign*(s - (r/10000)); break;
+ case 5: scaled_out = sign*(s - (r/100000)); break;
+ case 6: scaled_out = sign*(s - (r/1000000)); break;
+ case 7: scaled_out = sign*(s - (r/10000000)); break;
+ case 8: scaled_out = sign*(s - (r/100000000)); break;
+ case 9: scaled_out = sign*(s - (r/1000000000)); break;
+ }
+ return sign*q;
+}
+
+
+/* Sometimes there is one sp of difference in |scaled_out|
+ * compared to the 'perfect' answer given above, but this
+ * routine is only used by the pdf backend, not for typesetting.
+ */
+
+scaled
+divide_scaled_n (double sd, double md, double n) {
+ int d = (int)(sd/md*n+0.5);
+ scaled_out = (int)(d/n*md);
+ return d;
+}
+
+
+/* C print interface */
+
+void tprint (char *s) {
+ while (*s)
+ print_char(*s++);
+}
+
+void tprint_nl (char *s) {
+ print_nlp();
+ tprint(s);
+}
+
+#define escape_char_code 45 /* escape character for token output */
+#define int_par(a) zeqtb[static_int_base+(a)].cint /* an integer parameter */
+#define escape_char int_par(escape_char_code)
+
+void tprint_esc(char *s) { /* prints escape character, then |s| */
+ int c=-1; /* the escape character code */
+ if (zeqtb!=NULL) {
+ c=escape_char;
+ if (c>=0)
+ print_char(c);
+ }
+ tprint(s);
+}
+
+void tconfusion(char *s) {
+ confusion(maketexstring(s));
+}
+
diff --git a/Build/source/texk/web2c/luatexdir/writezip.c b/Build/source/texk/web2c/luatexdir/writezip.c
new file mode 100644
index 00000000000..b915413ccfe
--- /dev/null
+++ b/Build/source/texk/web2c/luatexdir/writezip.c
@@ -0,0 +1,98 @@
+/*
+Copyright (c) 1996-2007 Han The Thanh, <thanh@pdftex.org>
+
+This file is part of pdfTeX.
+
+pdfTeX is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+pdfTeX is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with pdfTeX; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+$Id $
+*/
+
+#include "ptexlib.h"
+#include "zlib.h"
+#include <assert.h>
+
+#define ZIP_BUF_SIZE 32768
+
+#define check_err(f, fn) \
+ if (f != Z_OK) \
+ pdftex_fail("zlib: %s() failed (error code %d)", fn, f)
+
+static char *zipbuf = NULL;
+static z_stream c_stream; /* compression stream */
+
+void write_zip(boolean finish)
+{
+ int err;
+ static int level_old = 0;
+ int level = get_pdf_compress_level();
+ assert(level > 0);
+ cur_file_name = NULL;
+ if (pdf_stream_length == 0) {
+ if (zipbuf == NULL) {
+ zipbuf = xtalloc(ZIP_BUF_SIZE, char);
+ c_stream.zalloc = (alloc_func) 0;
+ c_stream.zfree = (free_func) 0;
+ c_stream.opaque = (voidpf) 0;
+ check_err(deflateInit(&c_stream, level), "deflateInit");
+ } else {
+ if (level != level_old) { /* \pdfcompresslevel change in mid document */
+ check_err(deflateEnd(&c_stream), "deflateEnd");
+ c_stream.zalloc = (alloc_func) 0; /* these 3 lines no need, just to be safe */
+ c_stream.zfree = (free_func) 0;
+ c_stream.opaque = (voidpf) 0;
+ check_err(deflateInit(&c_stream, level), "deflateInit");
+ } else
+ check_err(deflateReset(&c_stream), "deflateReset");
+ }
+ level_old = level;
+ c_stream.next_out = (Bytef *) zipbuf;
+ c_stream.avail_out = ZIP_BUF_SIZE;
+ }
+ assert(zipbuf != NULL);
+ c_stream.next_in = pdf_buf;
+ c_stream.avail_in = pdf_ptr;
+ for (;;) {
+ if (c_stream.avail_out == 0) {
+ pdf_gone += xfwrite(zipbuf, 1, ZIP_BUF_SIZE, pdf_file);
+ pdf_last_byte = zipbuf[ZIP_BUF_SIZE - 1]; /* not needed */
+ c_stream.next_out = (Bytef *) zipbuf;
+ c_stream.avail_out = ZIP_BUF_SIZE;
+ }
+ err = deflate(&c_stream, finish ? Z_FINISH : Z_NO_FLUSH);
+ if (finish && err == Z_STREAM_END)
+ break;
+ check_err(err, "deflate");
+ if (!finish && c_stream.avail_in == 0)
+ break;
+ }
+ if (finish) {
+ if (c_stream.avail_out < ZIP_BUF_SIZE) { /* at least one byte has been output */
+ pdf_gone +=
+ xfwrite(zipbuf, 1, ZIP_BUF_SIZE - c_stream.avail_out, pdf_file);
+ pdf_last_byte = zipbuf[ZIP_BUF_SIZE - c_stream.avail_out - 1];
+ }
+ xfflush(pdf_file);
+ }
+ pdf_stream_length = c_stream.total_out;
+}
+
+void zip_free(void)
+{
+ if (zipbuf != NULL) {
+ check_err(deflateEnd(&c_stream), "deflateEnd");
+ free(zipbuf);
+ }
+}
diff --git a/Build/source/texk/web2c/web2c/coerce.h b/Build/source/texk/web2c/web2c/coerce.h
index 204fce17767..7f5bfa2cd79 100644
--- a/Build/source/texk/web2c/web2c/coerce.h
+++ b/Build/source/texk/web2c/web2c/coerce.h
@@ -1,5 +1,6 @@
/* Some definitions that get appended to the `coerce.h' file that web2c
outputs. */
+/* $Id$ */
/* The C compiler ignores most unnecessary casts (i.e., casts of
something to its own type). However, for structures, it doesn't.
@@ -49,6 +50,10 @@ extern poolpointer makesrcspecial P2H(strnumber, int);
extern void remembersourceinfo P2H(strnumber, int);
#endif
+#ifdef luaTeX
+#include <luatexdir/luatex.h>
+#endif /* luaTeX */
+
#ifdef pdfTeX
#include <pdftexdir/pdftex.h>
#endif /* pdfTeX */
diff --git a/Build/source/texk/web2c/web2c/splitup.c b/Build/source/texk/web2c/web2c/splitup.c
index bb3c471efac..f92933c52ba 100644
--- a/Build/source/texk/web2c/web2c/splitup.c
+++ b/Build/source/texk/web2c/web2c/splitup.c
@@ -2,6 +2,8 @@
and it produces several .c and .h files in the current directory
as its output.
+ $Id$
+
Tim Morgan September 19, 1987. */
#include "config.h"
@@ -110,6 +112,9 @@ main P2C(int, argc, string *, argv)
} else if (STREQ (output_name, "pdftex")) {
fputs ("#define INITEX\n#define TeX\n#define pdfTeX\n", out);
coerce = "pdftexcoerce.h";
+ } else if (STREQ (output_name, "luatex")) {
+ fputs ("#define INITEX\n#define TeX\n#define luaTeX\n", out);
+ coerce = "luatexcoerce.h";
} else if (STREQ (output_name, "pdfetex")) {
fputs ("#define INITEX\n#define TeX\n#define pdfeTeX\n", out);
coerce = "pdfetexcoerce.h";
@@ -120,7 +125,7 @@ main P2C(int, argc, string *, argv)
fputs ("#define INIMP\n#define MP\n", out);
coerce = "mpcoerce.h";
} else
- FATAL1 ("Can only split mf, mp, tex, etex, omega, eomega, aleph, pdf[e]tex, or xetex,\n not %s", output_name);
+ FATAL1 ("Can only split mf, mp, tex, etex, omega, eomega, aleph, luatex, pdf[e]tex, or xetex,\n not %s", output_name);
coerce_len = strlen (coerce);