summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Breitenlohner <peb@mppmu.mpg.de>2009-05-25 13:57:51 +0000
committerPeter Breitenlohner <peb@mppmu.mpg.de>2009-05-25 13:57:51 +0000
commitd8a3e1e0ee206a616a1e7f09f17b1b039a272bc4 (patch)
treee92a17253daea37906a3bfb1611fde2679d0ac02
parentb50e8d78f4b4b86177863a60bc85f5cd393ba04b (diff)
remove mpware/ and old (Pascal Web) mpost and dvitomp
git-svn-id: svn://tug.org/texlive/trunk@13458 c570f23f-e606-0410-a88d-b1316a301751
Diffstat
-rw-r--r--Build/source/texk/web2c/ChangeLog7
-rw-r--r--Build/source/texk/web2c/Makefile.am5
-rw-r--r--Build/source/texk/web2c/Makefile.in465
-rw-r--r--Build/source/texk/web2c/am/web.am13
-rwxr-xr-xBuild/source/texk/web2c/configure3
-rw-r--r--Build/source/texk/web2c/configure.ac3
-rw-r--r--Build/source/texk/web2c/dvitomp.ch837
-rw-r--r--Build/source/texk/web2c/dvitomp.mk27
-rw-r--r--Build/source/texk/web2c/dvitomp.web1680
-rw-r--r--Build/source/texk/web2c/man/Makefile.am9
-rw-r--r--Build/source/texk/web2c/man/Makefile.in16
-rw-r--r--Build/source/texk/web2c/mp.ch2100
-rw-r--r--Build/source/texk/web2c/mp.web24680
-rw-r--r--Build/source/texk/web2c/mplibdir/ChangeLog5
-rw-r--r--Build/source/texk/web2c/mplibdir/am/mplib.am4
-rwxr-xr-xBuild/source/texk/web2c/mplibdir/dvitomp.test (renamed from Build/source/texk/web2c/dvitomp.test)4
16 files changed, 122 insertions, 29736 deletions
diff --git a/Build/source/texk/web2c/ChangeLog b/Build/source/texk/web2c/ChangeLog
index 638fb42bfd0..068e5b09b8c 100644
--- a/Build/source/texk/web2c/ChangeLog
+++ b/Build/source/texk/web2c/ChangeLog
@@ -1,3 +1,10 @@
+2009-05-25 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mp.ch, mp.web, mpdir/, mpware/: removed (old MetaPost).
+ * Makefile.am, configure.ac: removed old MetaPost and mpware.
+ * dvitomp.ch, dvitomp.test, dvitomp.web: removed.
+ * am/web.am: removed dvitomp.
+
2009-05-23 Karl Berry <karl@tug.org>
* tex.ch (pool_size): increase default to 200000, so pdftex -ini
diff --git a/Build/source/texk/web2c/Makefile.am b/Build/source/texk/web2c/Makefile.am
index 1b8169e1378..0cba816c221 100644
--- a/Build/source/texk/web2c/Makefile.am
+++ b/Build/source/texk/web2c/Makefile.am
@@ -9,7 +9,7 @@ INCLUDES = -I$(top_builddir)/.. $(KPATHSEA_INCLUDES)
version = $(WEB2CVERSION)
-SUBDIRS = doc lib man mpware web2c . window
+SUBDIRS = doc lib man web2c . window
if OMFONTS
SUBDIRS += omegafonts
endif OMFONTS
@@ -131,9 +131,6 @@ include $(srcdir)/am/cweb.am
## TeX and MF
include $(srcdir)/am/texmf.am
-## old MetaPost
-include $(srcdir)/mpdir/am/mp.am
-
## MetaPost
include $(srcdir)/mplibdir/am/mplib.am
diff --git a/Build/source/texk/web2c/Makefile.in b/Build/source/texk/web2c/Makefile.in
index 6ee32a2dad9..09a6989af48 100644
--- a/Build/source/texk/web2c/Makefile.in
+++ b/Build/source/texk/web2c/Makefile.in
@@ -36,10 +36,10 @@ build_triplet = @build@
host_triplet = @host@
@OMFONTS_TRUE@am__append_1 = omegafonts
EXTRA_PROGRAMS = $(am__EXEEXT_1) tex$(EXEEXT) mf$(EXEEXT) \
- mf-nowin$(EXEEXT) oldmpost$(EXEEXT) mpost$(EXEEXT) \
- etex$(EXEEXT) pdftex$(EXEEXT) ttf2afm$(EXEEXT) \
- pdftosrc$(EXEEXT) luatex$(EXEEXT) luatangle$(EXEEXT) \
- xetex$(EXEEXT) $(am__EXEEXT_4) aleph$(EXEEXT)
+ mf-nowin$(EXEEXT) mpost$(EXEEXT) etex$(EXEEXT) pdftex$(EXEEXT) \
+ ttf2afm$(EXEEXT) pdftosrc$(EXEEXT) luatex$(EXEEXT) \
+ luatangle$(EXEEXT) xetex$(EXEEXT) $(am__EXEEXT_4) \
+ aleph$(EXEEXT)
bin_PROGRAMS = tangle$(EXEEXT) ctangle$(EXEEXT) $(am__EXEEXT_5) \
ctie$(EXEEXT) cweave$(EXEEXT) tie$(EXEEXT) $(am__EXEEXT_6) \
$(am__EXEEXT_7) $(am__EXEEXT_8) $(am__EXEEXT_9) \
@@ -72,7 +72,7 @@ DIST_COMMON = README $(am__configure_deps) $(dist_man_MANS) \
$(srcdir)/luatexdir/am/luamisc.am \
$(srcdir)/luatexdir/am/luasocket.am \
$(srcdir)/luatexdir/am/luatangle.am \
- $(srcdir)/luatexdir/am/luatex.am $(srcdir)/mpdir/am/mp.am \
+ $(srcdir)/luatexdir/am/luatex.am \
$(srcdir)/mplibdir/am/libmplib.am \
$(srcdir)/mplibdir/am/mplib.am \
$(srcdir)/omegaware/am/omegaware.am \
@@ -97,7 +97,7 @@ DIST_COMMON = README $(am__configure_deps) $(dist_man_MANS) \
@MFN_TRUE@@MF_TRUE@am__append_8 = mf-nowin
@MF_TRUE@am__append_9 = $(mf_tests)
@MF_TRUE@am__append_10 = gftype tftopl
-@MP_TRUE@am__append_11 = oldmpost mpost
+@MP_TRUE@am__append_11 = mpost
@MP_TRUE@am__append_12 = $(mp_tests)
@MP_TRUE@am__append_13 = pltotf tftopl
@ETEX_TRUE@am__append_14 = etex
@@ -346,16 +346,6 @@ nodist_libmplib_a_OBJECTS = libmplib_a-memio.$(OBJEXT) \
$(am__objects_4)
libmplib_a_OBJECTS = $(am_libmplib_a_OBJECTS) \
$(nodist_libmplib_a_OBJECTS)
-liboldmpost_a_AR = $(AR) $(ARFLAGS)
-liboldmpost_a_LIBADD =
-am_liboldmpost_a_OBJECTS = liboldmpost_a-avl.$(OBJEXT) \
- liboldmpost_a-avlstuff.$(OBJEXT) \
- liboldmpost_a-mapfile.$(OBJEXT) \
- liboldmpost_a-turningnumber.$(OBJEXT) \
- liboldmpost_a-utils.$(OBJEXT) liboldmpost_a-writeenc.$(OBJEXT) \
- liboldmpost_a-writefont.$(OBJEXT) \
- liboldmpost_a-writet1.$(OBJEXT)
-liboldmpost_a_OBJECTS = $(am_liboldmpost_a_OBJECTS)
libpdftex_a_AR = $(AR) $(ARFLAGS)
libpdftex_a_LIBADD =
am__libpdftex_a_SOURCES_DIST = pdftexdir/avl.c pdftexdir/avl.h \
@@ -445,11 +435,11 @@ am_libzzip_a_OBJECTS = libzzip_a-dir.$(OBJEXT) libzzip_a-err.$(OBJEXT) \
libzzip_a-stat.$(OBJEXT) libzzip_a-write.$(OBJEXT) \
libzzip_a-zip.$(OBJEXT)
libzzip_a_OBJECTS = $(am_libzzip_a_OBJECTS)
-am__EXEEXT_1 = bibtex$(EXEEXT) dvicopy$(EXEEXT) dvitomp$(EXEEXT) \
- dvitype$(EXEEXT) gftodvi$(EXEEXT) gftopk$(EXEEXT) \
- gftype$(EXEEXT) mft$(EXEEXT) patgen$(EXEEXT) pktogf$(EXEEXT) \
- pktype$(EXEEXT) pltotf$(EXEEXT) pooltype$(EXEEXT) \
- tftopl$(EXEEXT) vftovp$(EXEEXT) vptovf$(EXEEXT) weave$(EXEEXT)
+am__EXEEXT_1 = bibtex$(EXEEXT) dvicopy$(EXEEXT) dvitype$(EXEEXT) \
+ gftodvi$(EXEEXT) gftopk$(EXEEXT) gftype$(EXEEXT) mft$(EXEEXT) \
+ patgen$(EXEEXT) pktogf$(EXEEXT) pktype$(EXEEXT) \
+ pltotf$(EXEEXT) pooltype$(EXEEXT) tftopl$(EXEEXT) \
+ vftovp$(EXEEXT) vptovf$(EXEEXT) weave$(EXEEXT)
am__EXEEXT_2 = odvicopy$(EXEEXT) odvitype$(EXEEXT) otangle$(EXEEXT)
am__EXEEXT_3 = ofm2opl$(EXEEXT) opl2ofm$(EXEEXT) ovf2ovp$(EXEEXT) \
ovp2ovf$(EXEEXT)
@@ -458,7 +448,7 @@ am__EXEEXT_4 = $(am__EXEEXT_2) $(am__EXEEXT_3)
@TEX_TRUE@am__EXEEXT_6 = tex$(EXEEXT)
@MF_TRUE@am__EXEEXT_7 = mf$(EXEEXT)
@MFN_TRUE@@MF_TRUE@am__EXEEXT_8 = mf-nowin$(EXEEXT)
-@MP_TRUE@am__EXEEXT_9 = oldmpost$(EXEEXT) mpost$(EXEEXT)
+@MP_TRUE@am__EXEEXT_9 = mpost$(EXEEXT)
@ETEX_TRUE@am__EXEEXT_10 = etex$(EXEEXT)
@PDFTEX_TRUE@am__EXEEXT_11 = pdftex$(EXEEXT) ttf2afm$(EXEEXT) \
@PDFTEX_TRUE@ pdftosrc$(EXEEXT)
@@ -510,10 +500,6 @@ nodist_dvicopy_OBJECTS = dvicopy.$(OBJEXT)
dvicopy_OBJECTS = $(nodist_dvicopy_OBJECTS)
dvicopy_LDADD = $(LDADD)
dvicopy_DEPENDENCIES = $(proglib) $(am__DEPENDENCIES_1)
-nodist_dvitomp_OBJECTS = dvitomp.$(OBJEXT)
-dvitomp_OBJECTS = $(nodist_dvitomp_OBJECTS)
-dvitomp_LDADD = $(LDADD)
-dvitomp_DEPENDENCIES = $(proglib) $(am__DEPENDENCIES_1)
nodist_dvitype_OBJECTS = dvitype.$(OBJEXT)
dvitype_OBJECTS = $(nodist_dvitype_OBJECTS)
dvitype_LDADD = $(LDADD)
@@ -588,12 +574,6 @@ nodist_ofm2opl_OBJECTS = ofm2opl.$(OBJEXT)
ofm2opl_OBJECTS = $(nodist_ofm2opl_OBJECTS)
ofm2opl_LDADD = $(LDADD)
ofm2opl_DEPENDENCIES = $(proglib) $(am__DEPENDENCIES_1)
-am__objects_14 = oldmpost-mpini.$(OBJEXT) oldmpost-mp0.$(OBJEXT) \
- oldmpost-mp1.$(OBJEXT) oldmpost-mp2.$(OBJEXT)
-nodist_oldmpost_OBJECTS = $(am__objects_14) oldmpost-mp-pool.$(OBJEXT) \
- oldmpost-mpextra.$(OBJEXT)
-oldmpost_OBJECTS = $(nodist_oldmpost_OBJECTS)
-oldmpost_DEPENDENCIES = liboldmpost.a $(am__DEPENDENCIES_2)
nodist_opl2ofm_OBJECTS = opl2ofm.$(OBJEXT)
opl2ofm_OBJECTS = $(nodist_opl2ofm_OBJECTS)
opl2ofm_LDADD = $(LDADD)
@@ -617,12 +597,12 @@ patgen_DEPENDENCIES = $(proglib) $(am__DEPENDENCIES_1)
am__dist_pdftex_SOURCES_DIST = synctexdir/synctex.h \
synctexdir/synctex-common.h synctexdir/synctex-pdftex.h
dist_pdftex_OBJECTS =
-am__objects_15 = pdftex-pdftexini.$(OBJEXT) pdftex-pdftex0.$(OBJEXT) \
+am__objects_14 = pdftex-pdftexini.$(OBJEXT) pdftex-pdftex0.$(OBJEXT) \
pdftex-pdftex1.$(OBJEXT) pdftex-pdftex2.$(OBJEXT) \
pdftex-pdftex3.$(OBJEXT)
-@PDFTEX_SYNCTEX_TRUE@am__objects_16 = pdftex-synctex-pdf.$(OBJEXT)
-nodist_pdftex_OBJECTS = $(am__objects_15) pdftex-pdftex-pool.$(OBJEXT) \
- pdftex-pdftexextra.$(OBJEXT) $(am__objects_16)
+@PDFTEX_SYNCTEX_TRUE@am__objects_15 = pdftex-synctex-pdf.$(OBJEXT)
+nodist_pdftex_OBJECTS = $(am__objects_14) pdftex-pdftex-pool.$(OBJEXT) \
+ pdftex-pdftexextra.$(OBJEXT) $(am__objects_15)
pdftex_OBJECTS = $(dist_pdftex_OBJECTS) $(nodist_pdftex_OBJECTS)
am__DEPENDENCIES_6 = libpdftex.a $(am__DEPENDENCIES_1) \
$(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) \
@@ -659,11 +639,11 @@ tangleboot_DEPENDENCIES = $(proglib) $(am__DEPENDENCIES_1)
am__dist_tex_SOURCES_DIST = synctexdir/synctex.h \
synctexdir/synctex-common.h synctexdir/synctex-tex.h
dist_tex_OBJECTS =
-am__objects_17 = tex-texini.$(OBJEXT) tex-tex0.$(OBJEXT) \
+am__objects_16 = tex-texini.$(OBJEXT) tex-tex0.$(OBJEXT) \
tex-tex1.$(OBJEXT) tex-tex2.$(OBJEXT)
-@TEX_SYNCTEX_TRUE@am__objects_18 = tex-synctex.$(OBJEXT)
-nodist_tex_OBJECTS = $(am__objects_17) tex-tex-pool.$(OBJEXT) \
- tex-texextra.$(OBJEXT) $(am__objects_18)
+@TEX_SYNCTEX_TRUE@am__objects_17 = tex-synctex.$(OBJEXT)
+nodist_tex_OBJECTS = $(am__objects_16) tex-tex-pool.$(OBJEXT) \
+ tex-texextra.$(OBJEXT) $(am__objects_17)
tex_OBJECTS = $(dist_tex_OBJECTS) $(nodist_tex_OBJECTS)
@TEX_SYNCTEX_TRUE@am__DEPENDENCIES_7 = $(am__DEPENDENCIES_1)
tex_DEPENDENCIES = $(am__DEPENDENCIES_2) $(am__DEPENDENCIES_1) \
@@ -695,11 +675,11 @@ weave_DEPENDENCIES = $(proglib) $(am__DEPENDENCIES_1)
am__dist_xetex_SOURCES_DIST = synctexdir/synctex.h \
synctexdir/synctex-common.h synctexdir/synctex-xetex.h
dist_xetex_OBJECTS =
-am__objects_19 = xetex-xetexini.$(OBJEXT) xetex-xetex0.$(OBJEXT) \
+am__objects_18 = xetex-xetexini.$(OBJEXT) xetex-xetex0.$(OBJEXT) \
xetex-xetex1.$(OBJEXT) xetex-xetex2.$(OBJEXT)
-@XETEX_SYNCTEX_TRUE@am__objects_20 = xetex-synctex-xe.$(OBJEXT)
-nodist_xetex_OBJECTS = $(am__objects_19) xetex-xetex_pool.$(OBJEXT) \
- xetex-xetexextra.$(OBJEXT) $(am__objects_20)
+@XETEX_SYNCTEX_TRUE@am__objects_19 = xetex-synctex-xe.$(OBJEXT)
+nodist_xetex_OBJECTS = $(am__objects_18) xetex-xetex_pool.$(OBJEXT) \
+ xetex-xetexextra.$(OBJEXT) $(am__objects_19)
xetex_OBJECTS = $(dist_xetex_OBJECTS) $(nodist_xetex_OBJECTS)
@XETEX_MACOSX_FALSE@am__DEPENDENCIES_8 = $(am__DEPENDENCIES_1) \
@XETEX_MACOSX_FALSE@ $(am__DEPENDENCIES_1) \
@@ -738,14 +718,13 @@ SOURCES = $(libff_a_SOURCES) $(liblua51_a_SOURCES) \
$(libluasocket_a_SOURCES) $(libluatex_a_SOURCES) \
$(EXTRA_libluatex_a_SOURCES) $(libmd5_a_SOURCES) \
$(nodist_libmf_a_SOURCES) $(libmplib_a_SOURCES) \
- $(nodist_libmplib_a_SOURCES) $(liboldmpost_a_SOURCES) \
- $(libpdftex_a_SOURCES) $(EXTRA_libpdftex_a_SOURCES) \
- $(libxetex_a_SOURCES) $(libxetexmm_a_SOURCES) \
- $(libzzip_a_SOURCES) $(aleph_SOURCES) $(nodist_aleph_SOURCES) \
- $(nodist_bibtex_SOURCES) $(nodist_ctangle_SOURCES) \
- $(nodist_ctangleboot_SOURCES) $(nodist_ctie_SOURCES) \
- $(nodist_cweave_SOURCES) $(nodist_dvicopy_SOURCES) \
- $(nodist_dvitomp_SOURCES) $(nodist_dvitype_SOURCES) \
+ $(nodist_libmplib_a_SOURCES) $(libpdftex_a_SOURCES) \
+ $(EXTRA_libpdftex_a_SOURCES) $(libxetex_a_SOURCES) \
+ $(libxetexmm_a_SOURCES) $(libzzip_a_SOURCES) $(aleph_SOURCES) \
+ $(nodist_aleph_SOURCES) $(nodist_bibtex_SOURCES) \
+ $(nodist_ctangle_SOURCES) $(nodist_ctangleboot_SOURCES) \
+ $(nodist_ctie_SOURCES) $(nodist_cweave_SOURCES) \
+ $(nodist_dvicopy_SOURCES) $(nodist_dvitype_SOURCES) \
$(dist_etex_SOURCES) $(nodist_etex_SOURCES) $(gftodvi_SOURCES) \
$(nodist_gftodvi_SOURCES) $(nodist_gftopk_SOURCES) \
$(nodist_gftype_SOURCES) $(nodist_luatangle_SOURCES) \
@@ -754,29 +733,28 @@ SOURCES = $(libff_a_SOURCES) $(liblua51_a_SOURCES) \
$(nodist_mf_nowin_SOURCES) $(nodist_mft_SOURCES) \
$(nodist_mpost_SOURCES) $(nodist_odvicopy_SOURCES) \
$(nodist_odvitype_SOURCES) $(nodist_ofm2opl_SOURCES) \
- $(nodist_oldmpost_SOURCES) $(nodist_opl2ofm_SOURCES) \
- $(nodist_otangle_SOURCES) $(nodist_ovf2ovp_SOURCES) \
- $(nodist_ovp2ovf_SOURCES) $(nodist_patgen_SOURCES) \
- $(dist_pdftex_SOURCES) $(nodist_pdftex_SOURCES) \
- $(nodist_EXTRA_pdftex_SOURCES) $(pdftosrc_SOURCES) \
- $(nodist_EXTRA_pdftosrc_SOURCES) $(nodist_pktogf_SOURCES) \
- $(nodist_pktype_SOURCES) $(nodist_pltotf_SOURCES) \
- $(nodist_pooltype_SOURCES) $(synctex_SOURCES) \
- $(nodist_tangle_SOURCES) $(nodist_tangleboot_SOURCES) \
- $(dist_tex_SOURCES) $(nodist_tex_SOURCES) \
- $(nodist_tftopl_SOURCES) $(nodist_tie_SOURCES) \
- $(ttf2afm_SOURCES) $(EXTRA_ttf2afm_SOURCES) \
- $(nodist_vftovp_SOURCES) $(nodist_vptovf_SOURCES) \
- $(nodist_weave_SOURCES) $(dist_xetex_SOURCES) \
- $(nodist_xetex_SOURCES) $(nodist_EXTRA_xetex_SOURCES)
+ $(nodist_opl2ofm_SOURCES) $(nodist_otangle_SOURCES) \
+ $(nodist_ovf2ovp_SOURCES) $(nodist_ovp2ovf_SOURCES) \
+ $(nodist_patgen_SOURCES) $(dist_pdftex_SOURCES) \
+ $(nodist_pdftex_SOURCES) $(nodist_EXTRA_pdftex_SOURCES) \
+ $(pdftosrc_SOURCES) $(nodist_EXTRA_pdftosrc_SOURCES) \
+ $(nodist_pktogf_SOURCES) $(nodist_pktype_SOURCES) \
+ $(nodist_pltotf_SOURCES) $(nodist_pooltype_SOURCES) \
+ $(synctex_SOURCES) $(nodist_tangle_SOURCES) \
+ $(nodist_tangleboot_SOURCES) $(dist_tex_SOURCES) \
+ $(nodist_tex_SOURCES) $(nodist_tftopl_SOURCES) \
+ $(nodist_tie_SOURCES) $(ttf2afm_SOURCES) \
+ $(EXTRA_ttf2afm_SOURCES) $(nodist_vftovp_SOURCES) \
+ $(nodist_vptovf_SOURCES) $(nodist_weave_SOURCES) \
+ $(dist_xetex_SOURCES) $(nodist_xetex_SOURCES) \
+ $(nodist_EXTRA_xetex_SOURCES)
DIST_SOURCES = $(libff_a_SOURCES) $(liblua51_a_SOURCES) \
$(libluamisc_a_SOURCES) $(EXTRA_libluamisc_a_SOURCES) \
$(libluasocket_a_SOURCES) $(libluatex_a_SOURCES) \
$(EXTRA_libluatex_a_SOURCES) $(libmd5_a_SOURCES) \
- $(libmplib_a_SOURCES) $(liboldmpost_a_SOURCES) \
- $(am__libpdftex_a_SOURCES_DIST) $(EXTRA_libpdftex_a_SOURCES) \
- $(am__libxetex_a_SOURCES_DIST) $(libxetexmm_a_SOURCES) \
- $(libzzip_a_SOURCES) $(aleph_SOURCES) \
+ $(libmplib_a_SOURCES) $(am__libpdftex_a_SOURCES_DIST) \
+ $(EXTRA_libpdftex_a_SOURCES) $(am__libxetex_a_SOURCES_DIST) \
+ $(libxetexmm_a_SOURCES) $(libzzip_a_SOURCES) $(aleph_SOURCES) \
$(am__dist_etex_SOURCES_DIST) $(gftodvi_SOURCES) \
$(md5main_SOURCES) $(am__dist_pdftex_SOURCES_DIST) \
$(pdftosrc_SOURCES) $(synctex_SOURCES) \
@@ -823,13 +801,13 @@ ETAGS = etags
CTAGS = ctags
am__tty_colors = \
red=; grn=; lgn=; blu=; std=
-am__EXEEXT_21 = bibtex.test dvicopy.test dvitomp.test dvitype.test \
- gftodvi.test gftopk.test gftype.test mft.test patgen.test \
- pktogf.test pktype.test pltotf.test pooltype.test tftopl.test \
- vftovp.test vptovf.test weave.test
+am__EXEEXT_21 = bibtex.test dvicopy.test dvitype.test gftodvi.test \
+ gftopk.test gftype.test mft.test patgen.test pktogf.test \
+ pktype.test pltotf.test pooltype.test tftopl.test vftovp.test \
+ vptovf.test weave.test
am__EXEEXT_22 = $(am__EXEEXT_21)
@WEB_TRUE@am__EXEEXT_23 = $(am__EXEEXT_22)
-DIST_SUBDIRS = doc lib man mpware web2c . window omegafonts otps
+DIST_SUBDIRS = doc lib man web2c . window omegafonts otps
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
distdir = $(PACKAGE)-$(VERSION)
top_distdir = $(distdir)
@@ -1045,13 +1023,13 @@ x_tool_libs = @x_tool_libs@
ACLOCAL_AMFLAGS = -I ../../m4
INCLUDES = -I$(top_builddir)/.. $(KPATHSEA_INCLUDES)
version = $(WEB2CVERSION)
-SUBDIRS = doc lib man mpware web2c . window $(am__append_1) otps
+SUBDIRS = doc lib man web2c . window $(am__append_1) otps
proglib = lib/lib.a
dist_man_MANS = synctexdir/man1/synctex.1 synctexdir/man5/synctex.5
nodist_man_MANS = ctiedir/ctie.1 tiedir/tie.1
-EXTRA_LIBRARIES = libmf.a liboldmpost.a libmplib.a libpdftex.a \
- liblua51.a libzzip.a libluasocket.a libluamisc.a libff.a \
- libluatex.a libxetex.a libxetexmm.a libmd5.a
+EXTRA_LIBRARIES = libmf.a libmplib.a libpdftex.a liblua51.a libzzip.a \
+ libluasocket.a libluamisc.a libff.a libluatex.a libxetex.a \
+ libxetexmm.a libmd5.a
EXTRA_DIST = PROJECTS cftests config.h cpascal.h help.h tangle.web \
tangle.ch tangleboot.p cwebdir ctangleboot.c cwebboot.c \
tangle.test $(web_programs:=.web) $(web_programs:=.ch) \
@@ -1092,22 +1070,20 @@ EXTRA_DIST = PROJECTS cftests config.h cpascal.h help.h tangle.web \
triptrap/trip.fot triptrap/trip.log triptrap/trip.pl \
triptrap/trip.tex triptrap/trip.typ triptrap/trip1.in \
triptrap/trip2.in triptrap/tripin.log triptrap/tripman.tex \
- triptrap/tripos.tex triptrap/writeo triptrap/writeo.2 mp.web \
- mp.ch lib/texmfmp.c mpdir/mp.defines mpdir/mplib.h metapost.mk \
- mpdir/Makefile.in.orig mpdir/mpostlib.mk mplibdir/ChangeLog \
- $(mpost_web) $(mp_tests) $(libmplib_web) mplibdir/lmplib.c \
- $(etex_web_srcs) $(etex_ch_srcs) etexdir/etexextra.in \
- lib/texmfmp.c tmf-pool.h etexdir/ChangeLog etexdir/INSTALL \
- etexdir/README etexdir/etex_gen.tex $(etex_tests) \
- etexdir/etrip/etrip.diffs etexdir/etrip/etrip.fot \
- etexdir/etrip/etrip.log etexdir/etrip/etrip.out \
- etexdir/etrip/etrip.pl etexdir/etrip/etrip.tex \
- etexdir/etrip/etrip.typ etexdir/etrip/etrip1.in \
- etexdir/etrip/etrip2.in etexdir/etrip/etrip3.in \
- etexdir/etrip/etripin.log etexdir/etrip/etripman.tex \
- etexdir/etrip/texmf.cnf etexdir/etrip/trip2.in \
- etexdir/etex.mak etexdir/etex.mk $(pdftex_ch_srcs) \
- pdftexdir/pdftex.defines pdftexdir/pdftex.h \
+ triptrap/tripos.tex triptrap/writeo triptrap/writeo.2 \
+ mplibdir/ChangeLog $(mpost_web) $(mp_tests) $(libmplib_web) \
+ mplibdir/lmplib.c $(etex_web_srcs) $(etex_ch_srcs) \
+ etexdir/etexextra.in lib/texmfmp.c tmf-pool.h \
+ etexdir/ChangeLog etexdir/INSTALL etexdir/README \
+ etexdir/etex_gen.tex $(etex_tests) etexdir/etrip/etrip.diffs \
+ etexdir/etrip/etrip.fot etexdir/etrip/etrip.log \
+ etexdir/etrip/etrip.out etexdir/etrip/etrip.pl \
+ etexdir/etrip/etrip.tex etexdir/etrip/etrip.typ \
+ etexdir/etrip/etrip1.in etexdir/etrip/etrip2.in \
+ etexdir/etrip/etrip3.in etexdir/etrip/etripin.log \
+ etexdir/etrip/etripman.tex etexdir/etrip/texmf.cnf \
+ etexdir/etrip/trip2.in etexdir/etex.mak etexdir/etex.mk \
+ $(pdftex_ch_srcs) pdftexdir/pdftex.defines pdftexdir/pdftex.h \
pdftexdir/pdftexextra.in pdftexdir/ChangeLog pdftexdir/NEWS \
pdftexdir/README pdftexdir/change-files.txt \
pdftexdir/pdftex.mak pdftexdir/Makefile.in.orig \
@@ -1266,20 +1242,19 @@ DISTCLEANFILES = $(EXTRA_LIBRARIES) tangle.c tangle.h tangle.p \
cweb.c stamp-ctangle cftest.p $(web_programs:=.c) \
$(web_programs:=.h) $(web_programs:=.p) \
$(web_programs:=-web2c) tests/xexampl.aux tests/xexampl.bbl \
- tests/xexampl.blg tests/xstory.dvi tests/xpplr.dvi ptmr.mpx \
- tests/xptmr.mpx tests/xstory.mpx tests/xstory.dvityp \
- tests/xpagenum.typ cmr10.dvi tests/xcmr10.dvi cmr10.pk \
- tests/xcmr10.pk tests/xcmr10.gft1 tests/xcmr10.gft2 io.tex \
- tests/io.tex tests/xpatout pattmp.4 cmr10.gf \
- tests/xcmr10.600gf tests/xcmr10.pktyp tests/xcmr10.tfm \
- tests/xtexpool.typ tests/xcmr10.pl tests/xptmr.vpl \
- tests/xptmr.tfm tests/xptmr.vf pooltype.tex ctie.c cweave.c \
- tie.c ctie.outc ctie.outm common.tex common.scn common.idx \
- tie.outc tie.outm $(nodist_tex_SOURCES) tex-final.ch tex-web2c \
- tex.p tex.pool tex-tangle $(nodist_libmf_a_SOURCES) mfextra.c \
- mf-final.ch mf-web2c mf.p mf.pool mf-tangle \
- $(nodist_oldmpost_SOURCES) mp-web2c mp.p mp.pool mp-tangle \
- $(nodist_mpost_SOURCES) mpxout-ctangle \
+ tests/xexampl.blg tests/xstory.dvi tests/xpplr.dvi \
+ tests/xstory.dvityp tests/xpagenum.typ cmr10.dvi \
+ tests/xcmr10.dvi cmr10.pk tests/xcmr10.pk tests/xcmr10.gft1 \
+ tests/xcmr10.gft2 io.tex tests/io.tex tests/xpatout pattmp.4 \
+ cmr10.gf tests/xcmr10.600gf tests/xcmr10.pktyp \
+ tests/xcmr10.tfm tests/xtexpool.typ tests/xcmr10.pl \
+ tests/xptmr.vpl tests/xptmr.tfm tests/xptmr.vf pooltype.tex \
+ ctie.c cweave.c tie.c ctie.outc ctie.outm common.tex \
+ common.scn common.idx tie.outc tie.outm $(nodist_tex_SOURCES) \
+ tex-final.ch tex-web2c tex.p tex.pool tex-tangle \
+ $(nodist_libmf_a_SOURCES) mfextra.c mf-final.ch mf-web2c mf.p \
+ mf.pool mf-tangle $(nodist_mpost_SOURCES) mpxout-ctangle \
+ ptmr.mpx tests/xptmr.mpx tests/xstory.mpx \
$(nodist_libmplib_a_SOURCES) mp-ctangle psout-ctangle \
svgout-ctangle $(nodist_etex_SOURCES) etex.web etex.ch \
etex-web2c etex.p etex.pool etex-tangle etexdir/etex.version \
@@ -1322,12 +1297,11 @@ nodist_tangle_SOURCES = tangle.c tangle.h
nodist_tangleboot_SOURCES = tangleboot.c tangleboot.h
nodist_ctangle_SOURCES = ctangle.c cweb.c
nodist_ctangleboot_SOURCES = ctangleboot.c cwebboot.c
-web_programs = bibtex dvicopy dvitomp dvitype gftodvi gftopk gftype mft \
+web_programs = bibtex dvicopy dvitype gftodvi gftopk gftype mft \
patgen pktogf pktype pltotf pooltype tftopl vftovp vptovf weave
nodist_bibtex_SOURCES = bibtex.c bibtex.h
nodist_dvicopy_SOURCES = dvicopy.c dvicopy.h
-nodist_dvitomp_SOURCES = dvitomp.c dvitomp.h
nodist_dvitype_SOURCES = dvitype.c dvitype.h
nodist_gftodvi_SOURCES = gftodvi.c gftodvi.h
gftodvi_SOURCES = gftodmem.h
@@ -1376,24 +1350,6 @@ mf_c_h = mfini.c mf0.c mf1.c mfcoerce.h mfd.h
nodist_libmf_a_SOURCES = $(mf_c_h) mf-pool.c
libmf_a_CPPFLAGS = -DMETA_FONT
mf_tests = trap.test
-oldmpost_CPPFLAGS = -I$(srcdir)/mpdir
-oldmpost_LDADD = liboldmpost.a $(LDADD)
-oldmpost_c_h = mpini.c mp0.c mp1.c mp2.c mpcoerce.h mpd.h
-nodist_oldmpost_SOURCES = $(oldmpost_c_h) mp-pool.c mpextra.c
-liboldmpost_a_CPPFLAGS = -I$(srcdir)/mpdir
-liboldmpost_a_SOURCES = \
- mpdir/avl.c \
- mpdir/avl.h \
- mpdir/avlstuff.c \
- mpdir/avlstuff.h \
- mpdir/mapfile.c \
- mpdir/mpmac.h \
- mpdir/turningnumber.c \
- mpdir/utils.c \
- mpdir/writeenc.c \
- mpdir/writefont.c \
- mpdir/writet1.c
-
mp_ctangle = CWEBINPUTS=$(srcdir)/mplibdir $(ctangle)
mpost_CPPFLAGS = -I$(srcdir)/mplibdir
mpost_DEPENDENCIES = libmplib.a
@@ -1401,7 +1357,7 @@ mpost_LDADD = libmplib.a $(KPATHSEA_LIBS) -lm
nodist_mpost_SOURCES = mpost.c $(mpxout_c_h)
mpxout_c_h = mpxout.c mpxout.h
mpost_web = mplibdir/mpost.w mplibdir/mpxout.w
-mp_tests = mplibdir/mptrap.test
+mp_tests = mplibdir/dvitomp.test mplibdir/mptrap.test
libmplib_a_CPPFLAGS = -I$(srcdir)/mplibdir
libmplib_a_SOURCES = mplibdir/avl.h mplibdir/avl.c
nodist_libmplib_a_SOURCES = memio.c tfmin.c $(mp_c_h) $(psout_c_h) \
@@ -2086,7 +2042,7 @@ all: c-auto.h ff-config.h
.SUFFIXES: .c .cc .cpp .cxx .lo .o .obj
am--refresh:
@:
-$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(srcdir)/am/bootstrap.am $(srcdir)/am/web.am $(srcdir)/am/cweb.am $(srcdir)/am/texmf.am $(srcdir)/mpdir/am/mp.am $(srcdir)/mplibdir/am/mplib.am $(srcdir)/mplibdir/am/libmplib.am $(srcdir)/etexdir/am/etex.am $(srcdir)/pdftexdir/am/pdftex.am $(srcdir)/pdftexdir/am/libpdftex.am $(srcdir)/pdftexdir/am/ttf2afm.am $(srcdir)/pdftexdir/am/pdftosrc.am $(srcdir)/luatexdir/am/luatex.am $(srcdir)/luatexdir/am/luatangle.am $(srcdir)/luatexdir/am/liblua51.am $(srcdir)/luatexdir/am/libzzip.am $(srcdir)/luatexdir/am/luasocket.am $(srcdir)/luatexdir/am/luamisc.am $(srcdir)/luatexdir/am/luafontforge.am $(srcdir)/luatexdir/am/libluatex.am $(srcdir)/xetexdir/am/xetex.am $(srcdir)/omegaware/am/omegaware.am $(srcdir)/alephdir/am/aleph.am $(srcdir)/synctexdir/am/synctex.am $(srcdir)/libmd5/am/md5.am $(am__configure_deps)
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(srcdir)/am/bootstrap.am $(srcdir)/am/web.am $(srcdir)/am/cweb.am $(srcdir)/am/texmf.am $(srcdir)/mplibdir/am/mplib.am $(srcdir)/mplibdir/am/libmplib.am $(srcdir)/etexdir/am/etex.am $(srcdir)/pdftexdir/am/pdftex.am $(srcdir)/pdftexdir/am/libpdftex.am $(srcdir)/pdftexdir/am/ttf2afm.am $(srcdir)/pdftexdir/am/pdftosrc.am $(srcdir)/luatexdir/am/luatex.am $(srcdir)/luatexdir/am/luatangle.am $(srcdir)/luatexdir/am/liblua51.am $(srcdir)/luatexdir/am/libzzip.am $(srcdir)/luatexdir/am/luasocket.am $(srcdir)/luatexdir/am/luamisc.am $(srcdir)/luatexdir/am/luafontforge.am $(srcdir)/luatexdir/am/libluatex.am $(srcdir)/xetexdir/am/xetex.am $(srcdir)/omegaware/am/omegaware.am $(srcdir)/alephdir/am/aleph.am $(srcdir)/synctexdir/am/synctex.am $(srcdir)/libmd5/am/md5.am $(am__configure_deps)
@for dep in $?; do \
case '$(am__configure_deps)' in \
*$$dep*) \
@@ -2178,10 +2134,6 @@ libmplib.a: $(libmplib_a_OBJECTS) $(libmplib_a_DEPENDENCIES)
-rm -f libmplib.a
$(libmplib_a_AR) libmplib.a $(libmplib_a_OBJECTS) $(libmplib_a_LIBADD)
$(RANLIB) libmplib.a
-liboldmpost.a: $(liboldmpost_a_OBJECTS) $(liboldmpost_a_DEPENDENCIES)
- -rm -f liboldmpost.a
- $(liboldmpost_a_AR) liboldmpost.a $(liboldmpost_a_OBJECTS) $(liboldmpost_a_LIBADD)
- $(RANLIB) liboldmpost.a
libpdftex.a: $(libpdftex_a_OBJECTS) $(libpdftex_a_DEPENDENCIES)
-rm -f libpdftex.a
$(libpdftex_a_AR) libpdftex.a $(libpdftex_a_OBJECTS) $(libpdftex_a_LIBADD)
@@ -2280,9 +2232,6 @@ cweave$(EXEEXT): $(cweave_OBJECTS) $(cweave_DEPENDENCIES)
dvicopy$(EXEEXT): $(dvicopy_OBJECTS) $(dvicopy_DEPENDENCIES)
@rm -f dvicopy$(EXEEXT)
$(LINK) $(dvicopy_OBJECTS) $(dvicopy_LDADD) $(LIBS)
-dvitomp$(EXEEXT): $(dvitomp_OBJECTS) $(dvitomp_DEPENDENCIES)
- @rm -f dvitomp$(EXEEXT)
- $(LINK) $(dvitomp_OBJECTS) $(dvitomp_LDADD) $(LIBS)
dvitype$(EXEEXT): $(dvitype_OBJECTS) $(dvitype_DEPENDENCIES)
@rm -f dvitype$(EXEEXT)
$(LINK) $(dvitype_OBJECTS) $(dvitype_LDADD) $(LIBS)
@@ -2328,9 +2277,6 @@ odvitype$(EXEEXT): $(odvitype_OBJECTS) $(odvitype_DEPENDENCIES)
ofm2opl$(EXEEXT): $(ofm2opl_OBJECTS) $(ofm2opl_DEPENDENCIES)
@rm -f ofm2opl$(EXEEXT)
$(LINK) $(ofm2opl_OBJECTS) $(ofm2opl_LDADD) $(LIBS)
-oldmpost$(EXEEXT): $(oldmpost_OBJECTS) $(oldmpost_DEPENDENCIES)
- @rm -f oldmpost$(EXEEXT)
- $(LINK) $(oldmpost_OBJECTS) $(oldmpost_LDADD) $(LIBS)
opl2ofm$(EXEEXT): $(opl2ofm_OBJECTS) $(opl2ofm_DEPENDENCIES)
@rm -f opl2ofm$(EXEEXT)
$(LINK) $(opl2ofm_OBJECTS) $(opl2ofm_LDADD) $(LIBS)
@@ -2421,7 +2367,6 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cweb.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cwebboot.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/dvicopy.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/dvitomp.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/dvitype.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/etex-etex-pool.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/etex-etex0.Po@am__quote@
@@ -2632,14 +2577,6 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libmplib_a-psout.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libmplib_a-svgout.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libmplib_a-tfmin.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-avl.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-avlstuff.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-mapfile.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-turningnumber.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-utils.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-writeenc.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-writefont.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/liboldmpost_a-writet1.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libpdftex_a-avl.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libpdftex_a-avlstuff.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libpdftex_a-epdf.Po@am__quote@
@@ -2713,12 +2650,6 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/odvicopy.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/odvitype.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ofm2opl.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/oldmpost-mp-pool.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/oldmpost-mp0.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/oldmpost-mp1.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/oldmpost-mp2.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/oldmpost-mpextra.Po@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/oldmpost-mpini.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/opl2ofm.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/otangle.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ovf2ovp.Po@am__quote@
@@ -5559,118 +5490,6 @@ libmplib_a-svgout.obj: svgout.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libmplib_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libmplib_a-svgout.obj `if test -f 'svgout.c'; then $(CYGPATH_W) 'svgout.c'; else $(CYGPATH_W) '$(srcdir)/svgout.c'; fi`
-liboldmpost_a-avl.o: mpdir/avl.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-avl.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-avl.Tpo -c -o liboldmpost_a-avl.o `test -f 'mpdir/avl.c' || echo '$(srcdir)/'`mpdir/avl.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-avl.Tpo $(DEPDIR)/liboldmpost_a-avl.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/avl.c' object='liboldmpost_a-avl.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-avl.o `test -f 'mpdir/avl.c' || echo '$(srcdir)/'`mpdir/avl.c
-
-liboldmpost_a-avl.obj: mpdir/avl.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-avl.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-avl.Tpo -c -o liboldmpost_a-avl.obj `if test -f 'mpdir/avl.c'; then $(CYGPATH_W) 'mpdir/avl.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/avl.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-avl.Tpo $(DEPDIR)/liboldmpost_a-avl.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/avl.c' object='liboldmpost_a-avl.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-avl.obj `if test -f 'mpdir/avl.c'; then $(CYGPATH_W) 'mpdir/avl.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/avl.c'; fi`
-
-liboldmpost_a-avlstuff.o: mpdir/avlstuff.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-avlstuff.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-avlstuff.Tpo -c -o liboldmpost_a-avlstuff.o `test -f 'mpdir/avlstuff.c' || echo '$(srcdir)/'`mpdir/avlstuff.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-avlstuff.Tpo $(DEPDIR)/liboldmpost_a-avlstuff.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/avlstuff.c' object='liboldmpost_a-avlstuff.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-avlstuff.o `test -f 'mpdir/avlstuff.c' || echo '$(srcdir)/'`mpdir/avlstuff.c
-
-liboldmpost_a-avlstuff.obj: mpdir/avlstuff.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-avlstuff.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-avlstuff.Tpo -c -o liboldmpost_a-avlstuff.obj `if test -f 'mpdir/avlstuff.c'; then $(CYGPATH_W) 'mpdir/avlstuff.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/avlstuff.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-avlstuff.Tpo $(DEPDIR)/liboldmpost_a-avlstuff.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/avlstuff.c' object='liboldmpost_a-avlstuff.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-avlstuff.obj `if test -f 'mpdir/avlstuff.c'; then $(CYGPATH_W) 'mpdir/avlstuff.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/avlstuff.c'; fi`
-
-liboldmpost_a-mapfile.o: mpdir/mapfile.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-mapfile.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-mapfile.Tpo -c -o liboldmpost_a-mapfile.o `test -f 'mpdir/mapfile.c' || echo '$(srcdir)/'`mpdir/mapfile.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-mapfile.Tpo $(DEPDIR)/liboldmpost_a-mapfile.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/mapfile.c' object='liboldmpost_a-mapfile.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-mapfile.o `test -f 'mpdir/mapfile.c' || echo '$(srcdir)/'`mpdir/mapfile.c
-
-liboldmpost_a-mapfile.obj: mpdir/mapfile.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-mapfile.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-mapfile.Tpo -c -o liboldmpost_a-mapfile.obj `if test -f 'mpdir/mapfile.c'; then $(CYGPATH_W) 'mpdir/mapfile.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/mapfile.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-mapfile.Tpo $(DEPDIR)/liboldmpost_a-mapfile.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/mapfile.c' object='liboldmpost_a-mapfile.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-mapfile.obj `if test -f 'mpdir/mapfile.c'; then $(CYGPATH_W) 'mpdir/mapfile.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/mapfile.c'; fi`
-
-liboldmpost_a-turningnumber.o: mpdir/turningnumber.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-turningnumber.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-turningnumber.Tpo -c -o liboldmpost_a-turningnumber.o `test -f 'mpdir/turningnumber.c' || echo '$(srcdir)/'`mpdir/turningnumber.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-turningnumber.Tpo $(DEPDIR)/liboldmpost_a-turningnumber.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/turningnumber.c' object='liboldmpost_a-turningnumber.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-turningnumber.o `test -f 'mpdir/turningnumber.c' || echo '$(srcdir)/'`mpdir/turningnumber.c
-
-liboldmpost_a-turningnumber.obj: mpdir/turningnumber.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-turningnumber.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-turningnumber.Tpo -c -o liboldmpost_a-turningnumber.obj `if test -f 'mpdir/turningnumber.c'; then $(CYGPATH_W) 'mpdir/turningnumber.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/turningnumber.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-turningnumber.Tpo $(DEPDIR)/liboldmpost_a-turningnumber.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/turningnumber.c' object='liboldmpost_a-turningnumber.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-turningnumber.obj `if test -f 'mpdir/turningnumber.c'; then $(CYGPATH_W) 'mpdir/turningnumber.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/turningnumber.c'; fi`
-
-liboldmpost_a-utils.o: mpdir/utils.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-utils.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-utils.Tpo -c -o liboldmpost_a-utils.o `test -f 'mpdir/utils.c' || echo '$(srcdir)/'`mpdir/utils.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-utils.Tpo $(DEPDIR)/liboldmpost_a-utils.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/utils.c' object='liboldmpost_a-utils.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-utils.o `test -f 'mpdir/utils.c' || echo '$(srcdir)/'`mpdir/utils.c
-
-liboldmpost_a-utils.obj: mpdir/utils.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-utils.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-utils.Tpo -c -o liboldmpost_a-utils.obj `if test -f 'mpdir/utils.c'; then $(CYGPATH_W) 'mpdir/utils.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/utils.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-utils.Tpo $(DEPDIR)/liboldmpost_a-utils.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/utils.c' object='liboldmpost_a-utils.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-utils.obj `if test -f 'mpdir/utils.c'; then $(CYGPATH_W) 'mpdir/utils.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/utils.c'; fi`
-
-liboldmpost_a-writeenc.o: mpdir/writeenc.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-writeenc.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-writeenc.Tpo -c -o liboldmpost_a-writeenc.o `test -f 'mpdir/writeenc.c' || echo '$(srcdir)/'`mpdir/writeenc.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-writeenc.Tpo $(DEPDIR)/liboldmpost_a-writeenc.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/writeenc.c' object='liboldmpost_a-writeenc.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-writeenc.o `test -f 'mpdir/writeenc.c' || echo '$(srcdir)/'`mpdir/writeenc.c
-
-liboldmpost_a-writeenc.obj: mpdir/writeenc.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-writeenc.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-writeenc.Tpo -c -o liboldmpost_a-writeenc.obj `if test -f 'mpdir/writeenc.c'; then $(CYGPATH_W) 'mpdir/writeenc.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/writeenc.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-writeenc.Tpo $(DEPDIR)/liboldmpost_a-writeenc.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/writeenc.c' object='liboldmpost_a-writeenc.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-writeenc.obj `if test -f 'mpdir/writeenc.c'; then $(CYGPATH_W) 'mpdir/writeenc.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/writeenc.c'; fi`
-
-liboldmpost_a-writefont.o: mpdir/writefont.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-writefont.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-writefont.Tpo -c -o liboldmpost_a-writefont.o `test -f 'mpdir/writefont.c' || echo '$(srcdir)/'`mpdir/writefont.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-writefont.Tpo $(DEPDIR)/liboldmpost_a-writefont.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/writefont.c' object='liboldmpost_a-writefont.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-writefont.o `test -f 'mpdir/writefont.c' || echo '$(srcdir)/'`mpdir/writefont.c
-
-liboldmpost_a-writefont.obj: mpdir/writefont.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-writefont.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-writefont.Tpo -c -o liboldmpost_a-writefont.obj `if test -f 'mpdir/writefont.c'; then $(CYGPATH_W) 'mpdir/writefont.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/writefont.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-writefont.Tpo $(DEPDIR)/liboldmpost_a-writefont.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/writefont.c' object='liboldmpost_a-writefont.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-writefont.obj `if test -f 'mpdir/writefont.c'; then $(CYGPATH_W) 'mpdir/writefont.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/writefont.c'; fi`
-
-liboldmpost_a-writet1.o: mpdir/writet1.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-writet1.o -MD -MP -MF $(DEPDIR)/liboldmpost_a-writet1.Tpo -c -o liboldmpost_a-writet1.o `test -f 'mpdir/writet1.c' || echo '$(srcdir)/'`mpdir/writet1.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-writet1.Tpo $(DEPDIR)/liboldmpost_a-writet1.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/writet1.c' object='liboldmpost_a-writet1.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-writet1.o `test -f 'mpdir/writet1.c' || echo '$(srcdir)/'`mpdir/writet1.c
-
-liboldmpost_a-writet1.obj: mpdir/writet1.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT liboldmpost_a-writet1.obj -MD -MP -MF $(DEPDIR)/liboldmpost_a-writet1.Tpo -c -o liboldmpost_a-writet1.obj `if test -f 'mpdir/writet1.c'; then $(CYGPATH_W) 'mpdir/writet1.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/writet1.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/liboldmpost_a-writet1.Tpo $(DEPDIR)/liboldmpost_a-writet1.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpdir/writet1.c' object='liboldmpost_a-writet1.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(liboldmpost_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o liboldmpost_a-writet1.obj `if test -f 'mpdir/writet1.c'; then $(CYGPATH_W) 'mpdir/writet1.c'; else $(CYGPATH_W) '$(srcdir)/mpdir/writet1.c'; fi`
-
libpdftex_a-avl.o: pdftexdir/avl.c
@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libpdftex_a_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libpdftex_a-avl.o -MD -MP -MF $(DEPDIR)/libpdftex_a-avl.Tpo -c -o libpdftex_a-avl.o `test -f 'pdftexdir/avl.c' || echo '$(srcdir)/'`pdftexdir/avl.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/libpdftex_a-avl.Tpo $(DEPDIR)/libpdftex_a-avl.Po
@@ -6637,90 +6456,6 @@ mpost-mpxout.obj: mpxout.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(mpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mpost-mpxout.obj `if test -f 'mpxout.c'; then $(CYGPATH_W) 'mpxout.c'; else $(CYGPATH_W) '$(srcdir)/mpxout.c'; fi`
-oldmpost-mpini.o: mpini.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mpini.o -MD -MP -MF $(DEPDIR)/oldmpost-mpini.Tpo -c -o oldmpost-mpini.o `test -f 'mpini.c' || echo '$(srcdir)/'`mpini.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mpini.Tpo $(DEPDIR)/oldmpost-mpini.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpini.c' object='oldmpost-mpini.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mpini.o `test -f 'mpini.c' || echo '$(srcdir)/'`mpini.c
-
-oldmpost-mpini.obj: mpini.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mpini.obj -MD -MP -MF $(DEPDIR)/oldmpost-mpini.Tpo -c -o oldmpost-mpini.obj `if test -f 'mpini.c'; then $(CYGPATH_W) 'mpini.c'; else $(CYGPATH_W) '$(srcdir)/mpini.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mpini.Tpo $(DEPDIR)/oldmpost-mpini.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpini.c' object='oldmpost-mpini.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mpini.obj `if test -f 'mpini.c'; then $(CYGPATH_W) 'mpini.c'; else $(CYGPATH_W) '$(srcdir)/mpini.c'; fi`
-
-oldmpost-mp0.o: mp0.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp0.o -MD -MP -MF $(DEPDIR)/oldmpost-mp0.Tpo -c -o oldmpost-mp0.o `test -f 'mp0.c' || echo '$(srcdir)/'`mp0.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp0.Tpo $(DEPDIR)/oldmpost-mp0.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp0.c' object='oldmpost-mp0.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp0.o `test -f 'mp0.c' || echo '$(srcdir)/'`mp0.c
-
-oldmpost-mp0.obj: mp0.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp0.obj -MD -MP -MF $(DEPDIR)/oldmpost-mp0.Tpo -c -o oldmpost-mp0.obj `if test -f 'mp0.c'; then $(CYGPATH_W) 'mp0.c'; else $(CYGPATH_W) '$(srcdir)/mp0.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp0.Tpo $(DEPDIR)/oldmpost-mp0.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp0.c' object='oldmpost-mp0.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp0.obj `if test -f 'mp0.c'; then $(CYGPATH_W) 'mp0.c'; else $(CYGPATH_W) '$(srcdir)/mp0.c'; fi`
-
-oldmpost-mp1.o: mp1.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp1.o -MD -MP -MF $(DEPDIR)/oldmpost-mp1.Tpo -c -o oldmpost-mp1.o `test -f 'mp1.c' || echo '$(srcdir)/'`mp1.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp1.Tpo $(DEPDIR)/oldmpost-mp1.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp1.c' object='oldmpost-mp1.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp1.o `test -f 'mp1.c' || echo '$(srcdir)/'`mp1.c
-
-oldmpost-mp1.obj: mp1.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp1.obj -MD -MP -MF $(DEPDIR)/oldmpost-mp1.Tpo -c -o oldmpost-mp1.obj `if test -f 'mp1.c'; then $(CYGPATH_W) 'mp1.c'; else $(CYGPATH_W) '$(srcdir)/mp1.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp1.Tpo $(DEPDIR)/oldmpost-mp1.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp1.c' object='oldmpost-mp1.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp1.obj `if test -f 'mp1.c'; then $(CYGPATH_W) 'mp1.c'; else $(CYGPATH_W) '$(srcdir)/mp1.c'; fi`
-
-oldmpost-mp2.o: mp2.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp2.o -MD -MP -MF $(DEPDIR)/oldmpost-mp2.Tpo -c -o oldmpost-mp2.o `test -f 'mp2.c' || echo '$(srcdir)/'`mp2.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp2.Tpo $(DEPDIR)/oldmpost-mp2.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp2.c' object='oldmpost-mp2.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp2.o `test -f 'mp2.c' || echo '$(srcdir)/'`mp2.c
-
-oldmpost-mp2.obj: mp2.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp2.obj -MD -MP -MF $(DEPDIR)/oldmpost-mp2.Tpo -c -o oldmpost-mp2.obj `if test -f 'mp2.c'; then $(CYGPATH_W) 'mp2.c'; else $(CYGPATH_W) '$(srcdir)/mp2.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp2.Tpo $(DEPDIR)/oldmpost-mp2.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp2.c' object='oldmpost-mp2.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp2.obj `if test -f 'mp2.c'; then $(CYGPATH_W) 'mp2.c'; else $(CYGPATH_W) '$(srcdir)/mp2.c'; fi`
-
-oldmpost-mp-pool.o: mp-pool.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp-pool.o -MD -MP -MF $(DEPDIR)/oldmpost-mp-pool.Tpo -c -o oldmpost-mp-pool.o `test -f 'mp-pool.c' || echo '$(srcdir)/'`mp-pool.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp-pool.Tpo $(DEPDIR)/oldmpost-mp-pool.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp-pool.c' object='oldmpost-mp-pool.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp-pool.o `test -f 'mp-pool.c' || echo '$(srcdir)/'`mp-pool.c
-
-oldmpost-mp-pool.obj: mp-pool.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mp-pool.obj -MD -MP -MF $(DEPDIR)/oldmpost-mp-pool.Tpo -c -o oldmpost-mp-pool.obj `if test -f 'mp-pool.c'; then $(CYGPATH_W) 'mp-pool.c'; else $(CYGPATH_W) '$(srcdir)/mp-pool.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mp-pool.Tpo $(DEPDIR)/oldmpost-mp-pool.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mp-pool.c' object='oldmpost-mp-pool.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mp-pool.obj `if test -f 'mp-pool.c'; then $(CYGPATH_W) 'mp-pool.c'; else $(CYGPATH_W) '$(srcdir)/mp-pool.c'; fi`
-
-oldmpost-mpextra.o: mpextra.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mpextra.o -MD -MP -MF $(DEPDIR)/oldmpost-mpextra.Tpo -c -o oldmpost-mpextra.o `test -f 'mpextra.c' || echo '$(srcdir)/'`mpextra.c
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mpextra.Tpo $(DEPDIR)/oldmpost-mpextra.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpextra.c' object='oldmpost-mpextra.o' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mpextra.o `test -f 'mpextra.c' || echo '$(srcdir)/'`mpextra.c
-
-oldmpost-mpextra.obj: mpextra.c
-@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT oldmpost-mpextra.obj -MD -MP -MF $(DEPDIR)/oldmpost-mpextra.Tpo -c -o oldmpost-mpextra.obj `if test -f 'mpextra.c'; then $(CYGPATH_W) 'mpextra.c'; else $(CYGPATH_W) '$(srcdir)/mpextra.c'; fi`
-@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/oldmpost-mpextra.Tpo $(DEPDIR)/oldmpost-mpextra.Po
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='mpextra.c' object='oldmpost-mpextra.obj' libtool=no @AMDEPBACKSLASH@
-@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
-@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(oldmpost_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o oldmpost-mpextra.obj `if test -f 'mpextra.c'; then $(CYGPATH_W) 'mpextra.c'; else $(CYGPATH_W) '$(srcdir)/mpextra.c'; fi`
-
pdftex-pdftexini.o: pdftexini.c
@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(pdftex_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pdftex-pdftexini.o -MD -MP -MF $(DEPDIR)/pdftex-pdftexini.Tpo -c -o pdftex-pdftexini.o `test -f 'pdftexini.c' || echo '$(srcdir)/'`pdftexini.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/pdftex-pdftexini.Tpo $(DEPDIR)/pdftex-pdftexini.Po
@@ -8188,13 +7923,6 @@ dvicopy-web2c: $(web2c_depend) dvicopy.p
touch dvicopy.c dvicopy.h
dvicopy.p: tangle$(EXEEXT) dvicopy.web dvicopy.ch
$(tangle) dvicopy dvicopy
-dvitomp.c dvitomp.h: dvitomp-web2c
-dvitomp-web2c: $(web2c_depend) dvitomp.p
- $(web2c) dvitomp
- echo timestamp >$@
- touch dvitomp.c dvitomp.h
-dvitomp.p: tangle$(EXEEXT) dvitomp.web dvitomp.ch
- $(tangle) dvitomp dvitomp
dvitype.c dvitype.h: dvitype-web2c
dvitype-web2c: $(web2c_depend) dvitype.p
$(web2c) dvitype
@@ -8368,23 +8096,6 @@ trap-clean:
rm -f mftrapin.fot mftrapin.log
rm -f mftrap.fot mftrap.log mftrap.tfm
rm -f mftrap.pl trap.72270gf trap.typ
-$(oldmpost_c_h): mp-web2c
-mp-web2c: mp.p $(web2c_texmf) mpdir/mp.defines web2c/cvtmf1.sed web2c/cvtmf2.sed
- $(web2c) mp
- echo timestamp >$@
- touch $(oldmpost_c_h)
-mpextra.c: lib/texmfmp.c mpd.h
- sed s/TEX-OR-MF-OR-MP/mp/ $(srcdir)/lib/texmfmp.c >$@
-mp.p mp.pool: mp-tangle
-mp-tangle: tangle$(EXEEXT) mp.web mp.ch
- $(tangle) mp mp
- echo timestamp >$@
- touch mp.p mp.pool
-mp-pool.c: mp.pool $(makecpool_stamp) mpdir/mplib.h
- $(makecpool) mp.pool $(srcdir)/mpdir/mplib.h >$@ || rm -f $@
-
-# We must create mpd.h before building the liboldmpost_a_OBJECTS.
-$(liboldmpost_a_OBJECTS): mpd.h
mpost.c: ctangle$(EXEEXT) mplibdir/mpost.w
$(mp_ctangle) mpost.w
diff --git a/Build/source/texk/web2c/am/web.am b/Build/source/texk/web2c/am/web.am
index 6f9dc8f8f45..12ca5a72739 100644
--- a/Build/source/texk/web2c/am/web.am
+++ b/Build/source/texk/web2c/am/web.am
@@ -3,7 +3,7 @@
## Copyright (C) 2009 Peter Breitenlohner <tex-live@tug.org>
## You may freely use, modify and/or distribute this file.
-web_programs = bibtex dvicopy dvitomp dvitype gftodvi gftopk gftype mft \
+web_programs = bibtex dvicopy dvitype gftodvi gftopk gftype mft \
patgen pktogf pktype pltotf pooltype tftopl vftovp vptovf weave
if WEB
@@ -33,15 +33,6 @@ dvicopy-web2c: $(web2c_depend) dvicopy.p
dvicopy.p: tangle$(EXEEXT) dvicopy.web dvicopy.ch
$(tangle) dvicopy dvicopy
-nodist_dvitomp_SOURCES = dvitomp.c dvitomp.h
-dvitomp.c dvitomp.h: dvitomp-web2c
-dvitomp-web2c: $(web2c_depend) dvitomp.p
- $(web2c) dvitomp
- echo timestamp >$@
- touch dvitomp.c dvitomp.h
-dvitomp.p: tangle$(EXEEXT) dvitomp.web dvitomp.ch
- $(tangle) dvitomp dvitomp
-
nodist_dvitype_SOURCES = dvitype.c dvitype.h
dvitype.c dvitype.h: dvitype-web2c
dvitype-web2c: $(web2c_depend) dvitype.p
@@ -184,8 +175,6 @@ endif WEB
DISTCLEANFILES += tests/xexampl.aux tests/xexampl.bbl tests/xexampl.blg
## dvicopy.test
DISTCLEANFILES += tests/xstory.dvi tests/xpplr.dvi
-## dvitomp.test
-DISTCLEANFILES += ptmr.mpx tests/xptmr.mpx tests/xstory.mpx
## dvitype.test
DISTCLEANFILES += tests/xstory.dvityp tests/xpagenum.typ
## gftodvi.test
diff --git a/Build/source/texk/web2c/configure b/Build/source/texk/web2c/configure
index 3a3026d240b..442d6f60122 100755
--- a/Build/source/texk/web2c/configure
+++ b/Build/source/texk/web2c/configure
@@ -24705,7 +24705,7 @@ fi
subdirs="$subdirs web2c"
-ac_config_files="$ac_config_files Makefile doc/Makefile lib/Makefile man/Makefile mpware/Makefile omegafonts/Makefile otps/Makefile window/Makefile"
+ac_config_files="$ac_config_files Makefile doc/Makefile lib/Makefile man/Makefile omegafonts/Makefile otps/Makefile window/Makefile"
@@ -25881,7 +25881,6 @@ do
"doc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;;
"lib/Makefile") CONFIG_FILES="$CONFIG_FILES lib/Makefile" ;;
"man/Makefile") CONFIG_FILES="$CONFIG_FILES man/Makefile" ;;
- "mpware/Makefile") CONFIG_FILES="$CONFIG_FILES mpware/Makefile" ;;
"omegafonts/Makefile") CONFIG_FILES="$CONFIG_FILES omegafonts/Makefile" ;;
"otps/Makefile") CONFIG_FILES="$CONFIG_FILES otps/Makefile" ;;
"window/Makefile") CONFIG_FILES="$CONFIG_FILES window/Makefile" ;;
diff --git a/Build/source/texk/web2c/configure.ac b/Build/source/texk/web2c/configure.ac
index c073f774413..bd50318ab8e 100644
--- a/Build/source/texk/web2c/configure.ac
+++ b/Build/source/texk/web2c/configure.ac
@@ -348,8 +348,7 @@ fi
AC_CONFIG_SUBDIRS([web2c])
AC_CONFIG_FILES([Makefile doc/Makefile lib/Makefile man/Makefile
- mpware/Makefile omegafonts/Makefile otps/Makefile
- window/Makefile])
+ omegafonts/Makefile otps/Makefile window/Makefile])
dnl The subdirectory web2c must be configured for the build system.
dnl Can not share the cache file with the subdirectory!
diff --git a/Build/source/texk/web2c/dvitomp.ch b/Build/source/texk/web2c/dvitomp.ch
deleted file mode 100644
index b3393dfc2fe..00000000000
--- a/Build/source/texk/web2c/dvitomp.ch
+++ /dev/null
@@ -1,837 +0,0 @@
-% $Id: dvitomp.ch,v 1.7 2005/04/28 06:45:21 taco Exp $
-% dvitomp.ch for C compilation with web2c. Public domain.
-%
-% Change file for the DVItoMP processor, for use with WEB to C
-% This file was created by John Hobby. It is loosely based on the
-% change file for the WEB to C version of dvitype (due to Howard
-% Trickey and Pavel Curtis).
-%
-% 3/11/90 (JDH) Original version.
-% 4/30/90 (JDH) Update to handle virtual fonts
-% 4/16/93 (JDH) Make output go to standard output and require mpx file
-% to be a command line argument.
-%
-% 1/18/95 (UV) Update based on dvitype.ch for web2c-6.1
-% 4/13/95 (UV) Cosmetic changes for release of web2c-mp
-% 10/08/95 (UV) Bug fix: need to replace abs() with floating-point arg
-% by fabs() because of different definition in cpascal.h
-% as reported by Dane Dwyer <dwyer@geisel.csl.uiuc.edu>.
-
-@x [0] WEAVE: print changes only.
-\pageno=\contentspagenumber \advance\pageno by 1
-@y
-\pageno=\contentspagenumber \advance\pageno by 1
-\let\maybe=\iffalse
-\def\title{DVI$\,$\lowercase{to}MP changes for C}
-@z
-
-@x [1] Duplicate banner line for use in |print_version_and_exit|.
-@d banner=='% Written by DVItoMP, Version 1.003'
- {the first line of the output file}
-@y
-@d banner=='% Written by DVItoMP, Version 1.003/color'
- {the first line of the output file}
-@d term_banner=='This is DVItoMP, Version 1.003/color'
- {the same in the usual format, as it would be shown on a terminal}
-@z
-
-@x [3] Set up kpathsea.
-procedure initialize; {this procedure gets things started properly}
- var i:integer; {loop index for initializations}
- begin @<Set initial values@>@/
-@y
-@<Define |parse_arguments|@>
-procedure initialize; {this procedure gets things started properly}
- var i:integer; {loop index for initializations}
- begin
- kpse_set_progname (argv[0]); {initialize for the filename searches}
- parse_arguments;
- @<Set initial values@>@/
-@z
-
-@x [7] Remove non-local goto.
-@d abort(#)==begin err_print_ln('DVItoMP abort: ',#);
- history:=fatal_error; jump_out;
- end
-@d bad_dvi(#)==abort('Bad DVI file: ',#,'!')
-@.Bad DVI file@>
-@d warn(#)==begin err_print_ln('DVItoMP warning: ',#);
- history:=warning_given;
- end
-
-@p procedure jump_out;
-begin goto final_end;
-end;
-@y
-@d jump_out==uexit(history)
-@d abort(#)==begin err_print_ln('DVItoMP abort: ',#);
- history:=fatal_error; jump_out;
- end
-@d bad_dvi(#)==abort('Bad DVI file: ',#,'!')
-@.Bad DVI file@>
-@d warn(#)==begin err_print_ln('DVItoMP warning: ',#);
- history:=warning_given;
- end
-@z
-
-@x [11] Permissive input.
-@!ASCII_code=" ".."~"; {a subrange of the integers}
-@y
-@!ASCII_code=0..255; {a subrange of the integers}
-@z
-
-% [12] 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}
-@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
-@d last_text_char=127 {ordinal number of the largest element of |text_char|}
-@y
-@d text_char == ASCII_code {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|}
-@z
-
-@x [14] Fix up opening the files.
-@p procedure open_mpx_file; {prepares to write text on |mpx_file|}
-begin rewrite(mpx_file);
-end;
-@y
-@p procedure open_mpx_file; {prepares to write text on |mpx_file|}
-begin
- cur_name := extend_filename (mpx_name, 'mpx');
- rewrite (mpx_file, cur_name);
-end;
-@z
-
-@x [19] More file opening.
-@p procedure open_dvi_file; {prepares to read packed bytes in |dvi_file|}
-begin reset(dvi_file);
-if eof(dvi_file) then abort('DVI file not found');
-end;
-@#
-function open_tfm_file:boolean; {prepares to read packed bytes in |tfm_file|}
-begin reset(tfm_file,cur_name);
-open_tfm_file:=(not eof(tfm_file));
-end;
-@#
-function open_vf_file:boolean; {prepares to read packed bytes in |vf_file|}
-begin reset(vf_file,cur_name);
-open_vf_file:=(not eof(vf_file));
-end;
-@y
-@p procedure open_dvi_file; {prepares to read packed bytes in |dvi_file|}
-begin
- cur_name := extend_filename (dvi_name, 'dvi');
- resetbin(dvi_file, cur_name);
-end;
-@#
-function open_tfm_file:boolean; {prepares to read packed bytes in |tfm_file|}
-begin
- tfm_file := kpse_open_file (cur_name, kpse_tfm_format);
- free (cur_name); {We |xmalloc|'d this before we got called.}
- open_tfm_file := true; {If we get here, we succeeded.}
-end;
-@#
-function open_vf_file:boolean; {prepares to read packed bytes in |tfm_file|}
-var @!full_name:^char;
-begin
- {It's ok if the \.{VF} file doesn't exist.}
- full_name := kpse_find_vf (cur_name);
- if full_name then begin
- resetbin (vf_file, full_name);
- free (cur_name);
- free (full_name);
- open_vf_file := true;
- end else
- open_vf_file := false;
-end;
-@z
-
-@x [24] No arbitrary limit on filename length.
-@!cur_name:packed array[1..name_length] of char; {external name,
- with no lower case letters}
-@y
-@!cur_name:^char; {external name}
-@z
-
-@x [26] Make get_n_bytes routines work with 16-bit math.
-get_two_bytes:=a*256+b;
-@y
-get_two_bytes:=a*intcast(256)+b;
-@z
-@x
-get_three_bytes:=(a*256+b)*256+c;
-@y
-get_three_bytes:=(a*intcast(256)+b)*256+c;
-@z
-@x
-if a<128 then signed_trio:=(a*256+b)*256+c
-else signed_trio:=((a-256)*256+b)*256+c;
-@y
-if a<128 then signed_trio:=(a*intcast(256)+b)*256+c
-else signed_trio:=((a-intcast(256))*256+b)*256+c;
-@z
-@x
-if a<128 then signed_quad:=((a*256+b)*256+c)*256+d
-else signed_quad:=(((a-256)*256+b)*256+c)*256+d;
-@y
-if a<128 then signed_quad:=((a*intcast(256)+b)*256+c)*256+d
-else signed_quad:=(((a-256)*intcast(256)+b)*256+c)*256+d;
-@z
-
-@x [32] l.672 Bugfix: local_only is indexed by internal font numbers.
-@!local_only:array [0..max_fonts] of boolean; {|font_num| meaningless?}
-@y
-@!local_only:array [0..max_fnums] of boolean; {|font_num| meaningless?}
-@z
-
-@x [41] Fix abs() with floating-point arg.
- begin if abs(font_scaled_size[f]-font_scaled_size[ff])
-@y
- begin if fabs(font_scaled_size[f]-font_scaled_size[ff])
-@z
-
-@x [43] Fix abs() with floating-point arg.
-if abs(font_design_size[f]-font_design_size[ff]) > font_tolerance then
-@y
-if fabs(font_design_size[f]-font_design_size[ff]) > font_tolerance then
-@z
-
-@x [43] Checksum warning: set history to cksum_trouble, not warning_given.
- font_warn('Checksum mismatch for ')(ff)
-@.Checksum mismatch@>
-@y
- begin err_print('DVItoMP warning: Checksum mismatch for ');
-@.Checksum mismatch@>
- err_print_font(ff);
- if history=spotless then history:=cksum_trouble;
- end
-@z
-
-@x [46] Make 16-bit TFM calculations work.
-read_tfm_word; lh:=b2*256+b3;
-read_tfm_word; font_bc[f]:=b0*256+b1; font_ec[f]:=b2*256+b3;
-@y
-read_tfm_word; lh:=b2*intcast(256)+b3;
-read_tfm_word; font_bc[f]:=b0*intcast(256)+b1; font_ec[f]:=b2*intcast(256)+b3;
-@z
-@x
- if b0<128 then tfm_check_sum:=((b0*256+b1)*256+b2)*256+b3
- else tfm_check_sum:=(((b0-256)*256+b1)*256+b2)*256+b3;
-@y
- if b0<128 then tfm_check_sum:=((b0*intcast(256)+b1)*256+b2)*256+b3
- else tfm_check_sum:=(((b0-256)*intcast(256)+b1)*256+b2)*256+b3;
-@z
-
-% For the code to work, Hobby notes that we need |round|(|x| - 0.5)
-% to be equal to $\lfloor x\rfloor$. For Pascal's |round| function
-% this is emphatically not true.
-@x [49] We need floor, not round.
-round(dvi_scale*font_scaled_size[f]*char_width(f)(c)-0.5)
-@y
-floor(dvi_scale*font_scaled_size[f]*char_width(f)(c))
-@z
-
-@x [50] We need floor, not round.
-round(dvi_scale*font_scaled_size[cur_font]*char_width(cur_font)(p)-0.5)
-@y
-floor(dvi_scale*font_scaled_size[cur_font]*char_width(cur_font)(p))
-@z
-
-% [61] Don't set default_directory_name.
-@x
-@d default_directory_name=='TeXfonts:' {change this to the correct name}
-@d default_directory_name_length=9 {change this to the correct length}
-
-@<Glob...@>=
-@!default_directory:packed array[1..default_directory_name_length] of char;
-@y
-There is no single |default_directory| with C.
-@z
-
-@x [62] Remove initialization of default_directory.
-@ @<Set init...@>=
-default_directory:=default_directory_name;
-@y
-@ (No initialization needs to be done. Keep this module to preserve
-numbering.)
-@z
-
-@x [63] Dynamically allocate cur_name, don't add .vf.
-for k:=1 to name_length do cur_name[k]:=' ';
-if area_length[f]=0 then
- begin for k:=1 to default_directory_name_length do
- cur_name[k]:=default_directory[k];
- l:=default_directory_name_length;
- end
-else l:=0;
-for k:=font_name[f] to font_name[f+1]-1 do
- begin incr(l);
- if l+3>name_length then
- abort('DVItoMP capacity exceeded (max font name length=',
- name_length:1,')!');
-@.DVItoMP capacity exceeded...@>
- if (names[k]>="a")and(names[k]<="z") then
- cur_name[l]:=xchr[names[k]-@'40]
- else cur_name[l]:=xchr[names[k]];
- end;
-cur_name[l+1]:='.'; cur_name[l+2]:='V'; cur_name[l+3]:='F'
-@y
-{This amounts to a string copy. }
-cur_name := xmalloc_array (char, font_name[f+1] - font_name[f]);
-for k:=font_name[f] to font_name[f+1]-1 do begin
- cur_name[k - font_name[f]] := xchr[names[k]];
-end;
-cur_name[font_name[f+1] - font_name[f]] := 0;
-@z
-
-@x [64] Since we didn't add .vf, don't need to change it to .tfm.
-l:=area_length[f];
-if l=0 then l:=default_directory_name_length;
-l:=l+font_name[f+1]-font_name[f];
-if l+4>name_length then
- abort('DVItoMP capacity exceeded (max font name length=',
- name_length:1,')!');
-@.DVItoMP capacity exceeded...@>
-cur_name[l+2]:='T'; cur_name[l+3]:='F'; cur_name[l+4]:='M'
-@y
-do_nothing
-@z
-
-@x [75] Handle colored text. (COLOR)
-print_ln('vardef _s(expr _t,_f,_m,_x,_y)=');
-print_ln(' addto _p also _t infont _f scaled _m shifted (_x,_y); enddef;');
-@y
-print_ln('vardef _s(expr _t,_f,_m,_x,_y)(text _c)=');
-print_ln(' addto _p also _t infont _f scaled _m shifted (_x,_y) _c; enddef;');
-@z
-
-@x [78] Fix printing of real numbers, and add color (COLOR).
- if (abs(x)>=4096.0)or(abs(y)>=4096.0)or(m>=4096.0)or(m<0) then
- begin warn('text scaled ',m:1:1,@|
- ' at (',x:1:1,',',y:1:1,') is out of range');
- end_char_string(60);
- end
- else end_char_string(40);
- print_ln(',_n',str_f:1,',',m:1:5,',',x:1:4,',',y:1:4,');');
-@y
- if (fabs(x)>=4096.0)or(fabs(y)>=4096.0)or(m>=4096.0)or(m<0) then
- begin warn('text is out of range');
- end_char_string(60);
- end
- else end_char_string(40);
- print(',_n',str_f:1,',');
- fprint_real(mpx_file, m,1,5); print(',');
- fprint_real(mpx_file, x,1,4); print(',');
- fprint_real(mpx_file, y,1,4); print(',');@/
- @<Print a \.{withcolor} specifier if appropriate@>@/
- print_ln(');');
-@z
-
-@x [79] Fix _r definition (COLOR).
- print_ln('vardef _r(expr _a,_w) =');
- print_ln(' addto _p doublepath _a withpen pencircle scaled _w enddef;');
-@y
- print_ln('vardef _r(expr _a,_w)(text _t) =');
- print_ln(' addto _p doublepath _a withpen pencircle scaled _w _t enddef;');
-@z
-
-@x [79] Another fix for printing of real numbers, plus colors (COLOR).
- if (abs(xx1)>=4096.0)or(abs(yy1)>=4096.0)or@|
- (abs(xx2)>=4096.0)or(abs(yy2)>=4096.0)or(ww>=4096.0) then
- warn('hrule or vrule near (',xx1:1:1,',',yy1:1:1,') is out of range');
- print_ln('_r((',xx1:1:4,',',yy1:1:4,')..(',xx2:1:4,',',yy2:1:4,
- '), ',ww:1:4,');');
-@y
- if (fabs(xx1)>=4096.0)or(fabs(yy1)>=4096.0)or@|
- (fabs(xx2)>=4096.0)or(fabs(yy2)>=4096.0)or(ww>=4096.0) then
- warn('hrule or vrule is out of range');
- print('_r((');
- fprint_real(mpx_file, xx1,1,4); print(',');
- fprint_real(mpx_file, yy1,1,4); print(')..(');
- fprint_real(mpx_file, xx2,1,4); print(',');
- fprint_real(mpx_file, yy2,1,4); print('), ');
- fprint_real(mpx_file, ww,1,4); print(',');
- @<Print a \.{withcolor} specifier if appropriate@>@/
- print_ln(');');
-@z
-
-@x [80] Yet another fix for printing of real numbers.
-print_ln('setbounds _p to (0,',dd:1:4,')--(',w:1:4,',',dd:1:4,')--');
-print_ln(' (',w:1:4,',',h:1:4,')--(0,',h:1:4,')--cycle;')
-@y
-print('setbounds _p to (0,');
-fprint_real(mpx_file, dd,1,4); print(')--(');
-fprint_real(mpx_file, w,1,4); print(',');
-fprint_real(mpx_file, dd,1,4); print_ln(')--');@/
-print(' (');
-fprint_real(mpx_file, w,1,4); print(',');
-fprint_real(mpx_file, h,1,4); print(')--(0,');
-fprint_real(mpx_file, h,1,4); print_ln(')--cycle;')
-@z
-
-@x [88] push and pop commands (COLOR).
-@p procedure do_push;
-@y
-@p @<Declare procedures to handle color commands@>
-procedure do_push;
-@z
-
-@x [94] Additional cases for DVI commands (COLOR).
-four_cases(xxx1): for k:=1 to p do
- down_the_drain:=get_byte;
-@y
-four_cases(xxx1): do_xxx(p);
-@z
-
-@x [98] Main program.
-print_ln(banner);
-@y
-print (banner);
-print_ln (version_string);
-@z
-@x Exit with appropriate status.
-final_end:end.
-@y
-if history<=cksum_trouble then uexit(0)
-else uexit(history);
-end.
-@z
-
-@x [103] System-dependent changes.
-This section should be replaced, if necessary, by changes to the program
-that are necessary to make \.{DVItoMP} 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 printed 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@>
-@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 = 2; {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 ('dvitomp');
-
- end else if argument_is ('help') then begin
- usage_help (DVITOMP_HELP, nil);
-
- end else if argument_is ('version') then begin
- print_version_and_exit (term_banner, 'AT&T Bell Laboraties', 'John Hobby.', 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.
- We must have one or two remaining arguments.}
- if (optind + 1 <> argc) and (optind + 2 <> argc) then begin
- write_ln (stderr, 'dvitomp: Need one or two file arguments.');
- usage ('dvitomp');
- end;
-
- dvi_name := cmdline (optind);
-
- if optind + 2 <= argc then begin
- mpx_name := cmdline (optind + 1); {The user specified the other name.}
- end else begin
- {User did not specify the other name; default it from the first.}
- mpx_name := basename_change_suffix (dvi_name, '.dvi', '.mpx');
- end;
-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);
-
-@ 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.
-
-@<Global...@> =
-@!dvi_name, @!mpx_name:c_string;
-
-
-
-@* Color support.
-These changes support \.{dvips}-style ``\.{color push NAME}'' and
-``\.{color pop}'' specials. We store a list of named colors, sorted by
-name, and decorate the relevant drawing commands with ``\.{withcolor
-(r,g,b)}'' specifiers while a color is defined.
-
-@ A constant bounding the size of the named-color array.
-
-@<Constants...@> =
-@!max_named_colors=100; {maximum number of distinct named colors}
-
-@ Then we declare a record for color types.
-
-@<Types...@> =
-@!named_color_record=record@;@/
- @!name:c_string; {color name}
- @!value:c_string; {text to pass to MetaPost}
- end;
-
-@ Declare the named-color array itself.
-
-@<Globals...@> =
-@!named_colors: array[1..max_named_colors] of named_color_record;
- {stores information about named colors, in sorted order by name}
-@!num_named_colors:integer; {number of elements of |named_colors| that are valid}
-
-@ This function, used only during initialization, defines a named color.
-
-@<Define |parse_arguments|@> =
-procedure def_named_color(n,v: c_string);
- begin
- if num_named_colors = max_named_colors then
- abort('too many named color definitions')
- else if (num_named_colors > 0)
- and (strcmp(n, named_colors[num_named_colors].name) <= 0)
- then
- abort('named colors added out of alphabetical order');
- incr(num_named_colors);
- named_colors[num_named_colors].name := n;
- named_colors[num_named_colors].value := v
- end;
-
-@ During the initialization phase, we define values for all the named
-colors defined in \.{colordvi.tex}. CMYK-to-RGB conversion by GhostScript.
-
-@<Set initial values@> =
-num_named_colors := 0;
-def_named_color('Apricot', '(1.0, 0.680006, 0.480006)');
-def_named_color('Aquamarine', '(0.180006, 1.0, 0.7)');
-def_named_color('Bittersweet', '(0.760012, 0.0100122, 0.0)');
-def_named_color('Black', '(0.0, 0.0, 0.0)');
-def_named_color('Blue', '(0.0, 0.0, 1.0)');
-def_named_color('BlueGreen', '(0.15, 1.0, 0.669994)');
-def_named_color('BlueViolet', '(0.1, 0.05, 0.960012)');
-def_named_color('BrickRed', '(0.719994, 0.0, 0.0)');
-def_named_color('Brown', '(0.4, 0.0, 0.0)');
-def_named_color('BurntOrange', '(1.0, 0.489988, 0.0)');
-def_named_color('CadetBlue', '(0.380006, 0.430006, 0.769994)');
-def_named_color('CarnationPink', '(1.0, 0.369994, 1.0)');
-def_named_color('Cerulean', '(0.0600122, 0.889988, 1.0)');
-def_named_color('CornflowerBlue', '(0.35, 0.869994, 1.0)');
-def_named_color('Cyan', '(0.0, 1.0, 1.0)');
-def_named_color('Dandelion', '(1.0, 0.710012, 0.160012)');
-def_named_color('DarkOrchid', '(0.6, 0.2, 0.8)');
-def_named_color('Emerald', '(0.0, 1.0, 0.5)');
-def_named_color('ForestGreen', '(0.0, 0.880006, 0.0)');
-def_named_color('Fuchsia', '(0.45, 0.00998169, 0.919994)');
-def_named_color('Goldenrod', '(1.0, 0.9, 0.160012)');
-def_named_color('Gray', '(0.5, 0.5, 0.5)');
-def_named_color('Green', '(0.0, 1.0, 0.0)');
-def_named_color('GreenYellow', '(0.85, 1.0, 0.310012)');
-def_named_color('JungleGreen', '(0.0100122, 1.0, 0.480006)');
-def_named_color('Lavender', '(1.0, 0.519994, 1.0)');
-def_named_color('LimeGreen', '(0.5, 1.0, 0.0)');
-def_named_color('Magenta', '(1.0, 0.0, 1.0)');
-def_named_color('Mahogany', '(0.65, 0.0, 0.0)');
-def_named_color('Maroon', '(0.680006, 0.0, 0.0)');
-def_named_color('Melon', '(1.0, 0.539988, 0.5)');
-def_named_color('MidnightBlue', '(0.0, 0.439988, 0.569994)');
-def_named_color('Mulberry', '(0.640018, 0.0800061, 0.980006)');
-def_named_color('NavyBlue', '(0.0600122, 0.460012, 1.0)');
-def_named_color('OliveGreen', '(0.0, 0.6, 0.0)');
-def_named_color('Orange', '(1.0, 0.389988, 0.130006)');
-def_named_color('OrangeRed', '(1.0, 0.0, 0.5)');
-def_named_color('Orchid', '(0.680006, 0.360012, 1.0)');
-def_named_color('Peach', '(1.0, 0.5, 0.3)');
-def_named_color('Periwinkle', '(0.430006, 0.45, 1.0)');
-def_named_color('PineGreen', '(0.0, 0.75, 0.160012)');
-def_named_color('Plum', '(0.5, 0.0, 1.0)');
-def_named_color('ProcessBlue', '(0.0399878, 1.0, 1.0)');
-def_named_color('Purple', '(0.55, 0.139988, 1.0)');
-def_named_color('RawSienna', '(0.55, 0.0, 0.0)');
-def_named_color('Red', '(1.0, 0.0, 0.0)');
-def_named_color('RedOrange', '(1.0, 0.230006, 0.130006)');
-def_named_color('RedViolet', '(0.590018, 0.0, 0.660012)');
-def_named_color('Rhodamine', '(1.0, 0.180006, 1.0)');
-def_named_color('RoyalBlue', '(0.0, 0.5, 1.0)');
-def_named_color('RoyalPurple', '(0.25, 0.1, 1.0)');
-def_named_color('RubineRed', '(1.0, 0.0, 0.869994)');
-def_named_color('Salmon', '(1.0, 0.469994, 0.619994)');
-def_named_color('SeaGreen', '(0.310012, 1.0, 0.5)');
-def_named_color('Sepia', '(0.3, 0.0, 0.0)');
-def_named_color('SkyBlue', '(0.380006, 1.0, 0.880006)');
-def_named_color('SpringGreen', '(0.739988, 1.0, 0.239988)');
-def_named_color('Tan', '(0.860012, 0.580006, 0.439988)');
-def_named_color('TealBlue', '(0.119994, 0.980006, 0.640018)');
-def_named_color('Thistle', '(0.880006, 0.410012, 1.0)');
-def_named_color('Turquoise', '(0.15, 1.0, 0.8)');
-def_named_color('Violet', '(0.210012, 0.119994, 1.0)');
-def_named_color('VioletRed', '(1.0, 0.189988, 1.0)');
-def_named_color('White', '(1.0, 1.0, 1.0)');
-def_named_color('WildStrawberry', '(1.0, 0.0399878, 0.610012)');
-def_named_color('Yellow', '(1.0, 1.0, 0.0)');
-def_named_color('YellowGreen', '(0.560012, 1.0, 0.260012)');
-def_named_color('YellowOrange', '(1.0, 0.580006, 0.0)');
-
-@ Color commands get a separate warning procedure. |warn| sets |history :=
-warning_given|, which causes a nonzero exit status; but color errors are
-trivial and should leave the exit status zero.
-
-@d color_warn(#)==begin err_print_ln('DVItoMP warning: ',#); if history < warning_given then history := cksum_trouble; end
-
-@ The |do_xxx| procedure handles DVI specials (defined with the
-|xxx1...xxx4| commands).
-
-@<Declare procedures to handle color commands@> =
-procedure do_xxx(p: integer);
-label 9999; {exit procedure}
-const bufsiz = 256; {FIXME: Fixed size buffer.}
-var buf: packed array[0..bufsiz] of eight_bits;
- l, r, m, k, len: integer;
- found: boolean;
-begin
- len := 0;
- while (p > 0) and (len < bufsiz) do begin
- buf[len] := get_byte;
- decr(p); incr(len);
- end;
- @<Check whether |buf| contains a color command; if not, |goto 9999|@>
- if p > 0 then begin
- color_warn('long "color" special ignored'); goto 9999; end;
- if @<|buf| contains a color pop command@> then begin
- @<Handle a color pop command@>
- end else if @<|buf| contains a color push command@> then begin
- @<Handle a color push command@>
- end else begin
- color_warn('unknown "color" special ignored'); goto 9999; end;
-9999: for k := 1 to p do down_the_drain := get_byte;
-end;
-
-@
-
-@<Check whether |buf| contains a color command; if not, |goto 9999|@> =
-if (len <= 5)
- or (buf[0] <> "c")
- or (buf[1] <> "o")
- or (buf[2] <> "l")
- or (buf[3] <> "o")
- or (buf[4] <> "r")
- or (buf[5] <> " ")
- then goto 9999;
-
-@
-
-@<|buf| contains a color push command@> =
-(len >= 11) and (buf[6] = "p") and (buf[7] = "u") and (buf[8] = "s") and (buf[9] = "h") and (buf[10] = " ")
-
-@
-
-@<|buf| contains a color pop command@> =
-(len = 9) and (buf[6] = "p") and (buf[7] = "o") and (buf[8] = "p")
-
-@ The \.{color push} and \.{pop} commands imply a color stack, so we need a
-global variable to hold that stack.
-
-@<Constants...@> =
-max_color_stack_depth=10; {maximum depth of saved color stack}
-
-@ Here's the actual stack variables.
-
-@<Globals...@> =
-color_stack_depth: integer; {current depth of saved color stack}
-color_stack: array[1..max_color_stack_depth] of c_string; {saved color stack}
-
-@ Initialize the stack to empty.
-
-@<Set initial values@> =
-color_stack_depth := 0;
-
-@ \.{color pop} just pops the stack.
-
-@<Handle a color pop command@> =
-finish_last_char;
-if color_stack_depth > 0 then begin
- free(color_stack[color_stack_depth]);
- decr(color_stack_depth)
-end
-else begin
- color_warn('color stack underflow')
-end;
-
-@ \.{color push} pushes a color onto the stack.
-
-@<Handle a color push command@> =
-finish_last_char;
-if color_stack_depth >= max_color_stack_depth then
- abort('color stack overflow');
-incr(color_stack_depth);
-{ I don't know how to do string operations in Pascal. }
-{ Skip over extra spaces after 'color push'. }
-l := 11;
-while (l < len - 1) and (buf[l] = " ") do incr(l);
-if @<|buf[l]| contains an rgb command@> then begin
- @<Handle a color push rgb command@>
-end else if @<|buf[l]| contains a cmyk command@> then begin
- @<Handle a color push cmyk command@>
-end else if @<|buf[l]| contains a gray command@> then begin
- @<Handle a color push gray command@>
-end else begin
- @<Handle a named color push command@>
-end;
-
-@
-
-@<|buf[l]| contains an rgb command@> =
-(l + 4 < len)
-and (buf[l] = "r")
-and (buf[l+1] = "g")
-and (buf[l+2] = "b")
-and (buf[l+3] = " ")
-
-@
-
-@<Handle a color push rgb command@> =
-l := l + 4;
-while (l < len) and (buf[l] = " ") do incr(l);
-{ Remove spaces at end of buf }
-while (len > l) and (buf[len - 1] = " ") do decr(len);
-color_stack[color_stack_depth]:=xmalloc_array(char,len-l+3);
-k := 0;
-@<Copy |buf[l]| to |color_stack[color_stack_depth][k]| in tuple form@>
-
-@
-
-@<|buf[l]| contains a gray command@> =
-(l + 5 < len)
-and (buf[l] = "g")
-and (buf[l+1] = "r")
-and (buf[l+2] = "a")
-and (buf[l+3] = "y")
-and (buf[l+4] = " ")
-
-@
-
-@<Handle a color push gray command@> =
-l := l + 5;
-while (l < len) and (buf[l] = " ") do incr(l);
-{ Remove spaces at end of buf }
-while (len > l) and (buf[len - 1] = " ") do decr(len);
-color_stack[color_stack_depth]:=xmalloc_array(char,len-l+9);
-strcpy(color_stack[color_stack_depth],'white*');
-k := 6;
-@<Copy |buf[l]| to |color_stack[color_stack_depth][k]| in tuple form@>
-
-@
-
-@<|buf[l]| contains a cmyk command@> =
-(l + 5 < len)
-and (buf[l] = "c")
-and (buf[l+1] = "m")
-and (buf[l+2] = "y")
-and (buf[l+3] = "k")
-and (buf[l+4] = " ")
-
-@
-
-@<Handle a color push cmyk command@> =
-l := l + 5;
-while (l < len) and (buf[l] = " ") do incr(l);
-{ Remove spaces at end of buf }
-while (len > l) and (buf[len - 1] = " ") do decr(len);
-color_stack[color_stack_depth]:=xmalloc_array(char,len-l+7);
-strcpy(color_stack[color_stack_depth],'cmyk');
-k := 4;
-@<Copy |buf[l]| to |color_stack[color_stack_depth][k]| in tuple form@>
-
-@
-
-@<Copy |buf[l]| to |color_stack[color_stack_depth][k]| in tuple form@> =
-color_stack[color_stack_depth][k] := "(";
-incr(k);
-while l < len do
- if buf[l] = " " then begin
- color_stack[color_stack_depth][k] := ",";
- while (l < len) and (buf[l] = " ") do incr(l);
- incr(k);
- end else begin
- color_stack[color_stack_depth][k] := buf[l];
- incr(l);
- incr(k);
- end;
-color_stack[color_stack_depth][k] := ")";
-color_stack[color_stack_depth][k+1] := chr(0)
-
-@ Binary-search the |named_colors| array, then push the found color onto
-the stack.
-
-@<Handle a named color push command@> =
-for k := l to len - 1 do begin
- buf[k - l] := xchr[buf[k]];
-end;
-buf[len - l] := 0;
-len := len - l;
-l := 1; r := num_named_colors;
-found := false;
-while (l <= r) and not found do begin
- m := (l + r) / 2;
- k := strcmp(stringcast(buf), named_colors[m].name);
- if k = 0 then begin
- color_stack[color_stack_depth]:=xstrdup(named_colors[m].value);
- found := true;
- end else if k < 0 then
- r := m - 1
- else
- l := m + 1;
-end;
-if not found then begin
- color_warn('non-hardcoded color "',stringcast(buf),'" in "color push" command');
- color_stack[color_stack_depth]:=xstrdup(stringcast(buf));
-end;
-
-@ Last but not least, this code snippet prints a \.{withcolor} specifier
-for the top of the color stack, if the stack is nonempty.
-
-@<Print a \.{withcolor} specifier if appropriate@> =
-if color_stack_depth > 0 then begin
- print(' withcolor ');
- fputs(color_stack[color_stack_depth], mpx_file);
-end;
-
-@z
diff --git a/Build/source/texk/web2c/dvitomp.mk b/Build/source/texk/web2c/dvitomp.mk
deleted file mode 100644
index 9a7efd5f0a1..00000000000
--- a/Build/source/texk/web2c/dvitomp.mk
+++ /dev/null
@@ -1,27 +0,0 @@
-# Makefile fragment for DVItoMP.
-# $Id: dvitomp.mk,v 1.1 2005/06/21 16:03:15 olaf Exp $
-#
-# Public domain.
-#
-# This facilitates a separate development track for DVItoMP.
-
-Makefile: dvitomp.mk
-
-dvitomp: dvitomp.o
- $(kpathsea_link) dvitomp.o $(LOADLIBES)
-dvitomp.c dvitomp.h: $(web2c_common) $(web2c_programs) dvitomp.p
- $(web2c) dvitomp
-dvitomp.p: tangle dvitomp.web dvitomp.ch
- $(tangle) dvitomp dvitomp
-check: dvitomp-check
-dvitomp-check: dvitomp
- TEXMFCNF=../kpathsea \
- ./dvitomp $(srcdir)/tests/story.dvi tests/xstory.mpx
- TFMFONTS=$(srcdir)/tests VFFONTS=$(srcdir)/tests: \
- ./dvitomp $(srcdir)/tests/ptmr
- mv ptmr.mpx tests/xptmr.mpx
-clean:: dvitomp-clean
-dvitomp-clean:
- $(LIBTOOL) --mode=clean rm -f dvitomp
- rm -f dvitomp.o dvitomp.c dvitomp.h dvitomp.p
- rm -f tests/xstory.mpx tests/xptmr.mpx
diff --git a/Build/source/texk/web2c/dvitomp.web b/Build/source/texk/web2c/dvitomp.web
deleted file mode 100644
index da6ce104e44..00000000000
--- a/Build/source/texk/web2c/dvitomp.web
+++ /dev/null
@@ -1,1680 +0,0 @@
-% $Id: dvitomp.web,v 1.3 2005/04/28 06:45:21 taco Exp $
-% DVItoMP, by John Hobby. Public domain.
-
-% Version 0 was prepared (March 1990).
-% Version 0.1 implemented virtual fonts. (May 1990)
-% Version 0.30 outputs setbounds statments, ignores rules 1sp wide (May 1991)
-% Version 0.60 outputs rules as penstrokes with butt ends
-% Version 0.62 makes the output more robust when used in a macro definition
-% Version 0.63 new version number only (Unix change file has // path searching)
-% Version 0.632 outputs a setbounds path even if no 1sp vrule appears (Jan 1997)
-% Version 0.64 avoids outputting wrong fonts, improves error handling (Jan 1998)
-
-% Although considerable effort has been expended to make the DVItoMP program
-% correct and reliable, no warranty is implied; the author disclaims 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 program is loosely based on DVItype Version 3.0
-% It converts a DVI file into a sequence of MetaPost picture expressions.
-
-% TeX is a trademark of the American Mathematical Society.
-
-% Here is TeX material that gets inserted after \input webmac
-\def\hang{\hangindent 3em\indent\ignorespaces}
-\font\ninerm=cmr9
-\font\sc=cmcsc10
-\let\mc=\ninerm % medium caps for names like SAIL
-\def\MP{MetaPost}
-\def\LaTeX{{\rm L\kern-.36em\raise.3ex\hbox{\sc a}\kern-.15em
- T\kern-.1667em\lower.7ex\hbox{E}\kern-.125emX}}
-\def\PASCAL{Pascal}
-
-\def\(#1){} % this is used to make section names sort themselves better
-\def\9#1{} % this is used for sort keys in the index
-
-\def\title{DVI$\,$\lowercase{to}MP}
-\def\contentspagenumber{1}
-\def\topofcontents{\null
- \def\titlepage{F} % include headline on the contents page
- \def\rheader{\mainfont\hfil \contentspagenumber}
- \vfill
- \centerline{\titlefont The {\ttitlefont DVItoMP} processor}
- \vskip 15pt
- \centerline{(Version 0.64, January 1998)}
- \vfill}
-\pageno=\contentspagenumber \advance\pageno by 1
-
-@* Introduction.
-The \.{DVItoMP} program reads binary device-independent (``\.{DVI}'')
-files that are produced by document compilers such as \TeX, and converts them
-into a symbolic form understood by \MP. It is loosely based on the \.{DVItype}
-utility program that produces a more faithful symbolic form of a \.{DVI} file.
-
-The output file is a sequence of \MP\ picture expressions, one for every page
-in the \.{DVI} file. It makes no difference to \.{DVItoMP} where the \.{DVI}
-file comes from, but it is intended to process the result of running \TeX\
-or \LaTeX\ on the output of \.{MPtoTEX}. Such a \.{DVI} file will contain
-one page for every \.{btex}$\ldots$\.{etex} block in the original input.
-Processing in with \.{DVItoMP} creates a corresponding sequence of \MP\ picture
-expressions for use as an auxiliary input file. Since \MP\ expects such files
-to have the extension \.{.MPX}, the output of \.{DVItoMP} is sometimes called
-an ``\.{MPX}'' file.
-
-The |banner| string defined here should be changed whenever \.{DVItoMP}
-gets modified.
-
-@d banner=='% Written by DVItoMP, Version 1.003'
- {the first line of the output file}
-
-@ This program is written in standard \PASCAL, except where it is necessary
-to use extensions; for example, \.{DVItoMP} must read files whose names
-are dynamically specified, and that would be impossible in pure \PASCAL.
-All places where nonstandard constructions are used have been listed in
-the index under ``system dependencies.''
-@!@^system dependencies@>
-
-Many \.{DVI}-reading programs need the ability to move to a random place
-in a binary file. \.{DVItoMP} does not need to do this, but it does use
-a default |case| as in \.{TANGLE}, \.{WEAVE}, etc.
-
-@ The binary input comes from |dvi_file|, and the symbolic output goes to
-|mpx_file|. \PASCAL's standard |output| file is used only to print an error
-message if the \.{DVI} file is bad. The term |print| is used instead of
-|write| when this program writes on |mpx_file| just in case this helps
-some installations deal with system dependencies.
-@^system dependencies@>
-
-@d print(#)==write(mpx_file,#)
-@d print_ln(#)==write_ln(mpx_file,#)
-@d err_print(#)==write(#)
-@d err_print_ln(#)==write_ln(#)
-
-@p program DVI_to_MP(@!dvi_file,@!mpx_file,@!output);
-label @<Labels in the outer block@>@/
-const @<Constants in the outer block@>@/
-type @<Types in the outer block@>@/
-var @<Globals in the outer block@>@/
-procedure initialize; {this procedure gets things started properly}
- var i:integer; {loop index for initializations}
- begin @<Set initial values@>@/
- end;
-
-@ If the program has to stop prematurely, it goes to the
-`|final_end|'. Another label, |done|, is used when stopping normally.
-
-@d final_end=9999 {label for the end of it all}
-@d done=30 {go here when finished with a subtask}
-
-@<Labels...@>=final_end,done;
-
-@ The following parameters can be changed at compile time to extend or
-reduce \.{DVItoMP}'s capacity.
-
-@<Constants...@>=
-@!max_fonts=1000; {maximum number of distinct fonts per \.{DVI} file}
-@!max_fnums=3000; {maximum number of fonts plus fonts local to virtual fonts}
-@!max_widths=256*max_fonts; {maximum number of different characters among all fonts}
-@!virtual_space=1000000;
- {maximum total bytes of typesetting commands for virtual fonts}
-@!line_length=79; {maximum output line length (must be at least 60)}
-@!stack_size=100; {\.{DVI} files shouldn't |push| beyond this depth}
-@!name_size=100000; {total length of all font file names}
-@!name_length=250; {a file name shouldn't be longer than this}
-
-@ There is one more parameter that is a little harder to change because
-it is of type |real|.
-
-@d font_tolerance==0.00001
- {font sizes should match to within this multiple of $2^{20}$ \.{DVI} units}
-
-@ 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 do_nothing == {empty statement}
-
-@ A global variable |history| keeps track of what type of errors have
-occurred with the hope that that \MP\ can be warned of any problems.
-
-@d spotless=0 {|history| value when no problems have been found}
-@d cksum_trouble=1 {|history| value there have been font checksum mismatches}
-@d warning_given=2 {|history| value after a recoverable error}
-@d fatal_error=3 {|history| value if processing had to be aborted}
-
-@<Glob...@>=
-history:spotless..fatal_error;
-
-@ @<Set init...@>=
-history:=spotless;
-
-@ If the \.{DVI} file is badly malformed, the whole process must be aborted;
-\.{DVItoMP} will give up, after issuing an error message about the symptoms
-that were noticed.
-
-Such errors might be discovered inside of subroutines inside of subroutines,
-so a procedure called |jump_out| has been introduced. This procedure, which
-simply transfers control to the label |final_end| at the end of the program,
-contains the only non-local |goto| statement in \.{DVItoMP}.
-@^system dependencies@>
-
-@d abort(#)==begin err_print_ln('DVItoMP abort: ',#);
- history:=fatal_error; jump_out;
- end
-@d bad_dvi(#)==abort('Bad DVI file: ',#,'!')
-@.Bad DVI file@>
-@d warn(#)==begin err_print_ln('DVItoMP warning: ',#);
- history:=warning_given;
- end
-
-@p procedure jump_out;
-begin goto final_end;
-end;
-
-@* The character set.
-Like all programs written with the \.{WEB} system, \.{DVItoMP} can be
-used with any character set. But it uses ASCII code internally, because
-the programming for portable input-output is easier when a fixed internal
-code is used, and because \.{DVI} files use ASCII code for file names.
-
-The next few sections of \.{DVItoMP} have therefore been copied from the
-analogous ones in the \.{WEB} system routines. They have been considerably
-simplified, since \.{DVItoMP} need not deal with the controversial
-ASCII codes less than @'40 or greater than @'176.
-If such codes appear in the font names,
-they will be printed as question marks.
-
-@<Types...@>=
-@!ASCII_code=" ".."~"; {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 lower case
-letters. Nowadays, of course, we need to deal with both upper and lower case
-alphabets in a convenient way, especially in a program like \.{DVItoMP}.
-So we shall assume that the \PASCAL\ system being used for \.{DVItoMP}
-has a character set containing at least the standard visible characters
-of ASCII code (|"!"| through |"~"|).
-
-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
-output file. 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=127 {ordinal number of the largest element of |text_char|}
-
-@<Types...@>=
-@!text_file=packed file of text_char;
-
-@ The \.{DVItoMP} processor converts from ASCII code to
-the user's external character set by means of an array |xchr|
-that is analogous to \PASCAL's |chr| function.
-
-@<Globals...@>=
-@!mpx_file:text_file; {destination for printed output}
-@!xchr: array [0..255] of text_char;
- {specifies conversion of output characters}
-
-@ To prepare the |mpx_file| for output, we |rewrite| it.
-@^system dependencies@>
-
-@p procedure open_mpx_file; {prepares to write text on |mpx_file|}
-begin rewrite(mpx_file);
-end;
-
-@ Under our assumption that the visible characters of standard ASCII are
-all present, the following assignment statements initialize the
-|xchr| array properly, without needing any system-dependent changes.
-
-@<Set init...@>=
-for i:=0 to @'37 do xchr[i]:='?';
-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]:='~';
-for i:=@'177 to 255 do xchr[i]:='?';
-
-@* Device-independent file format.
-The format of \.{DVI} files is described in many places including
-\.{dvitype.web} and Volume~B of D.~E. Knuth's {\sl Computers and Typesetting}.
-This program refers to the following command codes.
-
-@d id_byte=2 {identifies the kind of \.{DVI} files described here}
-@#
-@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}
-@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 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 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}
-@d undefined_commands==250,251,252,253,254,255
-
-@* Input from binary files.
-We have seen that a \.{DVI} file is a sequence of 8-bit bytes. The bytes
-appear physically in what is called a `|packed file of 0..255|'
-in \PASCAL\ lingo.
-
-Packing is system dependent, and many \PASCAL\ systems fail to implement
-such files in a sensible way (at least, from the viewpoint of producing
-good production software). For example, some systems treat all
-byte-oriented files as text, looking for end-of-line marks and such
-things. Therefore some system-dependent code is often needed to deal with
-binary files, even though most of the program in this section of
-\.{DVItoMP} is written in standard \PASCAL.
-@^system dependencies@>
-
-One common way to solve the problem is to consider files of |integer|
-numbers, and to convert an integer in the range $-2^{31}\L x<2^{31}$ to
-a sequence of four bytes $(a,b,c,d)$ using the following code, which
-avoids the controversial integer division of negative numbers:
-$$\vbox{\halign{#\hfil\cr
-|if x>=0 then a:=x div @'100000000|\cr
-|else begin x:=(x+@'10000000000)+@'10000000000; a:=x div @'100000000+128;|\cr
-\quad|end|\cr
-|x:=x mod @'100000000;|\cr
-|b:=x div @'200000; x:=x mod @'200000;|\cr
-|c:=x div @'400; d:=x mod @'400;|\cr}}$$
-The four bytes are then kept in a buffer and output one by one. (On 36-bit
-computers, an additional division by 16 is necessary at the beginning.
-Another way to separate an integer into four bytes is to use/abuse
-\PASCAL's variant records, storing an integer and retrieving bytes that are
-packed in the same place; {\sl caveat implementor!\/}) It is also desirable
-in some cases to read a hundred or so integers at a time, maintaining a
-larger buffer.
-
-We shall stick to simple \PASCAL\ in this program, for reasons of clarity,
-even if such simplicity is sometimes unrealistic.
-
-@<Types...@>=
-@!eight_bits=0..255; {unsigned one-byte quantity}
-@!byte_file=packed file of eight_bits; {files that contain binary data}
-
-@ The program deals with two binary file variables: |dvi_file| is the main
-input file that we are translating into symbolic form, and |tfm_file| is
-the current font metric file from which character-width information is
-being read. It is convenient to have a throw-away variable for function
-results when reading parts of the files that are being skipped.
-
-@<Glob...@>=
-@!dvi_file:byte_file; {the input file}
-@!tfm_file:byte_file; {a font metric file}
-@!vf_file:byte_file; {a virtual font file}
-@!down_the_drain:integer; {a ``write-only'' variable}
-
-@ To prepare these files for input, we |reset| them. An extension of
-\PASCAL\ is needed in the case of |tfm_file|, since we want to associate
-it with external files whose names are specified dynamically (i.e., not
-known at compile time). The following code assumes that `|reset(f,s)|'
-does this, when |f| is a file variable and |s| is a string variable that
-specifies the file name. If |eof(f)| is true immediately after |reset(f,s)|
-has acted, these routines assume that no file named |s| is accessible.
-@^system dependencies@>
-
-@p procedure open_dvi_file; {prepares to read packed bytes in |dvi_file|}
-begin reset(dvi_file);
-if eof(dvi_file) then abort('DVI file not found');
-end;
-@#
-function open_tfm_file:boolean; {prepares to read packed bytes in |tfm_file|}
-begin reset(tfm_file,cur_name);
-open_tfm_file:=(not eof(tfm_file));
-end;
-@#
-function open_vf_file:boolean; {prepares to read packed bytes in |vf_file|}
-begin reset(vf_file,cur_name);
-open_vf_file:=(not eof(vf_file));
-end;
-
-@ If you looked carefully at the preceding code, you probably asked,
-``What is |cur_name|?'' Good question. It's a global
-variable: |cur_name| is a string variable that will be set to the
-current font metric file name before |open_tfm_file| is called.
-
-@<Glob...@>=
-@!cur_name:packed array[1..name_length] of char; {external name,
- with no lower case letters}
-
-@ It turns out to be convenient to read four bytes at a time, when we are
-inputting from \.{TFM} files. The input goes into global variables
-|b0|, |b1|, |b2|, and |b3|, with |b0| getting the first byte and |b3|
-the fourth.
-
-@<Glob...@>=
-@!b0,@!b1,@!b2,@!b3: eight_bits; {four bytes input at once}
-
-@ The |read_tfm_word| procedure sets |b0| through |b3| to the next
-four bytes in the current \.{TFM} file.
-@^system dependencies@>
-
-@p procedure read_tfm_word;
-begin read(tfm_file,b0); read(tfm_file,b1);
-read(tfm_file,b2); read(tfm_file,b3);
-end;
-
-@ Input can come from from three different sources depending on the settings
-of global variables. When |vf_reading| is true, we read from the \.{VF} file.
-Otherwise, input can either come directly from |dvi_file| or from a buffer
-|cmd_buf|. The latter case applies whenever |buf_ptr<virtual_space|.
-
-@<Glob...@>=
-@!vf_reading:boolean; {should input come from |vf_file|?}
-@!cmd_buf:packed array [0..virtual_space] of quarter_word;
- {commands for virtual characters}
-@!buf_ptr:0..virtual_space; {|cmd_buf| index for the next byte}
-
-@ @<Set init...@>=
-vf_reading:=false; buf_ptr:=virtual_space;
-
-@ It is probably not critical that |cmd_buf| be packed as efficiently as possible,
-but we define a new type just in case it is necessary to for |cmd_buf| entries
-to be in the range |-128..127|.
-@^system dependencies@>
-
-@d qi(#)==# {convert from |eight_bits| to |quarter_word|}
-@d qo(#)==# {convert from |quarter_word| to |eight_bits|}
-
-@<Types...@>=
-quarter_word=0..255; {a one byte quantity as stored in |cmd_buf|}
-
-@ We shall use a set of simple functions to read the next byte or bytes from the
-current input source. There are seven possibilities, each of which is treated
-as a separate function in order to minimize the overhead for subroutine calls.
-
-@p function get_byte:integer; {returns the next byte, unsigned}
-var b:eight_bits;
-begin @<Read one byte into |b|@>;
-get_byte:=b;
-end;
-@#
-function signed_byte:integer; {returns the next byte, signed}
-var b:eight_bits;
-begin @<Read one byte into |b|@>;
-if b<128 then signed_byte:=b @+ else signed_byte:=b-256;
-end;
-@#
-function get_two_bytes:integer; {returns the next two bytes, unsigned}
-var a,@!b:eight_bits;
-begin a:=0;b:=0; {for compiler warnings}
-@<Read two bytes into |a| and |b|@>;
-get_two_bytes:=a*256+b;
-end;
-@#
-function signed_pair:integer; {returns the next two bytes, signed}
-var a,@!b:eight_bits;
-begin a:=0;b:=0; {for compiler warnings}
-@<Read two bytes into |a| and |b|@>;
-if a<128 then signed_pair:=a*256+b
-else signed_pair:=(a-256)*256+b;
-end;
-@#
-function get_three_bytes:integer; {returns the next three bytes, unsigned}
-var a,@!b,@!c:eight_bits;
-begin a:=0;b:=0;c:=0; {for compiler warnings}
-@<Read three bytes into |a|, |b|, and~|c|@>;
-get_three_bytes:=(a*256+b)*256+c;
-end;
-@#
-function signed_trio:integer; {returns the next three bytes, signed}
-var a,@!b,@!c:eight_bits;
-begin a:=0;b:=0;c:=0; {for compiler warnings}
-@<Read three bytes into |a|, |b|, and~|c|@>;
-if a<128 then signed_trio:=(a*256+b)*256+c
-else signed_trio:=((a-256)*256+b)*256+c;
-end;
-@#
-function signed_quad:integer; {returns the next four bytes, signed}
-var a,@!b,@!c,@!d:eight_bits;
-begin a:=0;b:=0;c:=0;d:=0; {for compiler warnings}
-@<Read four bytes into |a|, |b|, |c|, and~|d|@>;
-if a<128 then signed_quad:=((a*256+b)*256+c)*256+d
-else signed_quad:=(((a-256)*256+b)*256+c)*256+d;
-end;
-
-@ @<Read one byte into |b|@>=
-if vf_reading then read(vf_file,b)
-else if buf_ptr=virtual_space then read(dvi_file,b)
-else begin b:=qo(cmd_buf[buf_ptr]);
- incr(buf_ptr);
- end
-
-@ @<Read two bytes into |a| and |b|@>=
-if vf_reading then
- begin read(vf_file,a); read(vf_file,b);
- end
-else if buf_ptr=virtual_space then
- begin read(dvi_file,a); read(dvi_file,b);
- end
-else if buf_ptr+2>n_cmds then
- abort('Error detected while interpreting a virtual font')
-@.Error detected while...@>
-else begin a:=qo(cmd_buf[buf_ptr]);
- b:=qo(cmd_buf[buf_ptr+1]);
- buf_ptr:=buf_ptr+2;
- end
-
-@ @<Read three bytes into |a|, |b|, and~|c|@>=
-if vf_reading then
- begin read(vf_file,a); read(vf_file,b); read(vf_file,c);
- end
-else if buf_ptr=virtual_space then
- begin read(dvi_file,a); read(dvi_file,b); read(dvi_file,c);
- end
-else if buf_ptr+3>n_cmds then
- abort('Error detected while interpreting a virtual font')
-@.Error detected while...@>
-else begin a:=qo(cmd_buf[buf_ptr]);
- b:=qo(cmd_buf[buf_ptr+1]);
- c:=qo(cmd_buf[buf_ptr+2]);
- buf_ptr:=buf_ptr+3;
- end
-
-@ @<Read four bytes into |a|, |b|, |c|, and~|d|@>=
-if vf_reading then
- begin read(vf_file,a); read(vf_file,b); read(vf_file,c); read(vf_file,d);
- end
-else if buf_ptr=virtual_space then
- begin read(dvi_file,a); read(dvi_file,b); read(dvi_file,c); read(dvi_file,d);
- end
-else if buf_ptr+4>n_cmds then
- abort('Error detected while interpreting a virtual font')
-@.Error detected while...@>
-else begin a:=qo(cmd_buf[buf_ptr]);
- b:=qo(cmd_buf[buf_ptr+1]);
- c:=qo(cmd_buf[buf_ptr+2]);
- d:=qo(cmd_buf[buf_ptr+3]);
- buf_ptr:=buf_ptr+4;
- end
-
-@* Data structures for fonts.
-\.{DVI} file format does not include information about character widths, since
-that would tend to make the files a lot longer. But a program that reads
-a \.{DVI} file is supposed to know the widths of the characters that appear
-in \\{set\_char} commands. Therefore \.{DVItoMP} looks at the font metric
-(\.{TFM}) files for the fonts that are involved.
-@.TFM {\rm files}@>
-
-@ For purposes of this program, the only thing we need to know about a
-given character |c| in a non-virtual font |f| is the width. For the font as
-a whole, all we need is the symbolic name to use in the \.{MPX} file.
-
-This information appears implicitly in the following data
-structures. The current number of fonts defined is |nf|. Each such font has
-an internal number |f|, where |0<=f<nf|. There is also an external number
-that identifies the font in the \.{DVI} file. The correspondence is
-maintained in arrays |font_num| and |internal_num| so that |font_num[i]|
-is the external number for |f=internal_num[i]|.
-The external name of this font is the string that
-occupies positions |font_name[f]| through |font_name[f+1]-1| of the array
-|names|. The latter array consists of |ASCII_code| characters, and
-|font_name[nf]| is its first unoccupied position. The
-legal characters run from |font_bc[f]| to |font_ec[f]|, inclusive.
-The \.{TFM} file can specify that some of these are invalid, but this doesn't
-concern \.{DVItoMP} because it does not do extensive error checking.
-The width of character~|c| in font~|f| is given by
-|char_width(f)(c)=width[info_base[f]+c]|, and |info_ptr| is the
-first unused position of the |width| array.
-
-If font~|f| is a virtual font, there is a list of \.{DVI} commands for each
-character. These occupy consecutive positions in the |cmd_buf| array with
-the commands for character~|c| starting at
-|start_cmd(f)(c)=cmd_ptr[info_base[f]+c]| and ending just before
-|start_cmd(f)(c+1)|. Font numbers used when interpreting these \.{DVI}
-commands occupy positions |fbase[f]| through |ftop[f]-1| in the |font_num|
-table and the |internal_num| array gives the corresponding internal font
-numbers. If such an internal font number~|i| does not correspond to
-some font occuring in the \.{DVI} file, then |font_num[i]| has not been
-assigned a meaningful value; this is indicated by |local_only[i]=true|.
-
-If font~|f| is not virtual, then |fbase[f]=0| and |ftop[f]=0|. The |start_cmd|
-values are ignored in this case.
-
-@d char_width_end(#)==#]
-@d char_width(#)==width[info_base[#]+char_width_end
-@d start_cmd(#)==cmd_ptr[info_base[#]+start_cmd_end
-@d start_cmd_end(#)==#]
-
-@<Glob...@>=
-@!font_num:array [0..max_fnums] of integer; {external font numbers}
-@!internal_num:array [0..max_fnums] of integer; {internal font numbers}
-@!local_only:array [0..max_fonts] of boolean; {|font_num| meaningless?}
-@!font_name:array [0..max_fonts] of 0..name_size; {starting positions
- of external font names}
-@!names:array [0..name_size] of ASCII_code; {characters of names}
-@!area_length:array [0..max_fonts] of integer;
- {length of area part of font name}
-@!font_scaled_size:array [0..max_fonts] of real; {scale factors over $2^{20}$}
-@!font_design_size:array [0..max_fonts] of real; {design sizes over $2^{20}$}
-@!font_check_sum:array [0..max_fonts] of integer;
- {check sum from the |font_def|}
-@!font_bc:array [0..max_fonts] of integer; {beginning characters in fonts}
-@!font_ec:array [0..max_fonts] of integer; {ending characters in fonts}
-@!info_base:array [0..max_fonts] of integer;
- {index into |width| and |cmd_ptr| tables}
-@!width:array [0..max_widths] of integer;
- {character widths, in units $2^{-20}$ of design size}
-@!fbase:array [0..max_fonts] of integer; {index into |font_num| for local fonts}
-@!ftop:array [0..max_fonts] of integer;
- {|font_num| index where local fonts stop}
-@!cmd_ptr:array [0..max_widths] of integer; {starting positions in |cmd_buf|}
-@!nf:0..max_fonts; {the number of known fonts}
-@!vf_ptr:max_fonts..max_fnums;
- {next |font_num| entry for virtual font font tables}
-@!info_ptr:0..max_widths; {allocation pointer for |width| and |cmd_ptr| tables}
-@!n_cmds:0..virtual_space; {number of occupied cells in |cmd_buf|}
-@!cur_fbase,@!cur_ftop:0..max_fnums;
- {currently applicable part of the |font_num| table}
-
-@ @<Set init...@>=
-nf:=0; info_ptr:=0; font_name[0]:=0;
-vf_ptr:=max_fnums;
-cur_fbase:=0; cur_ftop:=0;
-
-@ Printing the name of a given font is easy except that a procedure |print_char|
-is needed to actually send an |ASCII_code| to the \.{MPX} file.
-
-@p @<Declare subroutines for printing strings@>@;
-procedure print_font(@!f:integer); {|f| is an internal font number}
-var k:0..name_size; {index into |names|}
-begin if (f<0)or(f>=nf) then bad_dvi('Undefined font')
-else begin for k:=font_name[f] to font_name[f+1]-1 do
- print_char(names[k]);
- end;
-end;
-
-@ Sometimes a font name is needed as part of an error message.
-
-@d font_warn(#)==begin err_print('DVItoMP warning: ',#); font_warn_end
-@d font_warn_end(#)==err_print_font(#);
- history:=warning_given;
- end
-@d font_abort(#)==begin err_print('DVItoMP abort: ',#); font_abort_end
-@d font_abort_end(#)==err_print_font(#);
- history:=fatal_error; jump_out;
- end
-
-@p procedure err_print_font(@!f:integer); {|f| is an internal font number}
-var k:0..name_size; {index into |names|}
-begin for k:=font_name[f] to font_name[f+1]-1 do
- err_print(xchr[names[k]]);
- err_print_ln(' ');
-end;
-
-@ When we encounter a font definition, we save the name, checksum, and size
-information, but we don't actually read the \.{TFM} or \.{VF} file until we
-are about to use the font. If a matching font is not already defined, we then
-allocate a new internal font number.
-
-The following subroutine does the necessary things when a \\{fnt\_def} command
-is encountered in the \.{DVI} file or in a \.{VF} file. It assumes that the
-first argument has already been parsed and is given by the parameter~|e|.
-
-@p @<Declare a function called |match_font|@>@;
-procedure define_font(@!e:integer); {|e| is an external font number}
-var @!i:integer; {index into |font_num| and |internal_num|}
-@!n:integer; {length of the font name and area}
-@!k:integer; {general purpose loop counter}
-@!x:integer; {a temporary value for scaled size computation}
-begin if nf=max_fonts then abort('DVItoMP capacity exceeded (max fonts=',
- max_fonts:1,')!');
-@.DVItoMP capacity exceeded...@>
-@<Allocate an index |i| into the |font_num| and |internal_num| tables@>;
-@<Read the font parameters into position for font |nf|@>;
-internal_num[i]:=match_font(nf,true);
-if internal_num[i]=nf then
- begin info_base[nf]:=max_widths; {indicate that the info isn't loaded yet}
- local_only[nf]:=vf_reading; incr(nf);
- end;
-end;
-
-@ @<Allocate an index |i| into the |font_num| and |internal_num| tables@>=
-if vf_ptr=nf then abort('DVItoMP capacity exceeded (max font numbers=',
- max_fnums:1,')');
-@.DVItoMP capacity exceeded...@>
-if vf_reading then
- begin font_num[nf]:=0; i:=vf_ptr; decr(vf_ptr);
- end
-else i:=nf;
-font_num[i]:=e
-
-@ @<Read the font parameters into position for font |nf|@>=
-font_check_sum[nf]:=signed_quad;
-@<Read |font_scaled_size[nf]| and |font_design_size[nf]|@>;
-n:=get_byte; area_length[nf]:=n;
-n:=n+get_byte;
-if font_name[nf]+n>name_size then
- abort('DVItoMP capacity exceeded (name size=',name_size:1,')!');
-@.DVItoMP capacity exceeded...@>
-font_name[nf+1]:=font_name[nf]+n;
-for k:=font_name[nf] to font_name[nf+1]-1 do names[k]:=get_byte
-
-@ The scaled size and design size are stored in \.{DVI} units divided by $2^{20}$.
-The units for scaled size are a little different if we are reading a virtual
-font, but this will be corrected when the scaled size is used. The scaled size
-also needs to be truncated to at most 23 significant bits in order to make
-the character width calculation match what \TeX\ does.
-
-@<Read |font_scaled_size[nf]| and |font_design_size[nf]|@>=
-x:=signed_quad;
-k:=1;
-while x>@'40000000 do
- begin x:=x div 2; k:=k+k;
- end;
-font_scaled_size[nf]:=x*k/1048576.0;
-if vf_reading then
- font_design_size[nf]:=signed_quad*dvi_per_fix/1048576.0
-else font_design_size[nf]:=signed_quad/1048576.0;
-
-@ @<Glob...@>=
-@!dvi_per_fix:real; {converts points scaled $2^{20}$ to \.{DVI} units}
-
-@ The |match_font| function tries to find a match for the font with internal
-number~|ff|, returning |nf| or the number of the matching font. If
-|exact=true|, the name and scaled size should match. Otherwise the scaled
-size need not match but the font found must be already loaded, not just
-defined.
-
-@<Declare a function called |match_font|@>=
-function match_font(ff:integer; exact:boolean):integer;
-label done, 99;
-var @!f:0..max_fonts; {font number being tested}
-@!ss,@!ll:0..name_size; {starting point and length of name of font |ff|}
-@!k,@!s:0..name_size; {registers for comparing font names}
-begin ss:=font_name[ff]; ll:=font_name[ff+1]-ss;
-f:=0;
-while f<nf do
- begin if f<>ff then
- begin @<Compare the names of fonts |f| and |ff|; |goto 99| if they differ@>;
- if exact then
- begin if abs(font_scaled_size[f]-font_scaled_size[ff])
- <= font_tolerance then
- begin if not vf_reading then begin
- if local_only[f] then
- begin font_num[f]:=font_num[ff]; local_only[f]:=false;
- end
- else if font_num[f]<>font_num[ff] then goto 99;
- end;
- goto done;
- end;
- end
- else if info_base[f]<>max_widths then goto done;
- end;
- 99:incr(f);
- end;
-done:if f<nf then begin
- @<Make sure fonts |f| and |ff| have matching design sizes and checksums@>;
- end;
-match_font:=f;
-end;
-
-@ @<Compare the names of fonts |f| and |ff|; |goto 99| if they differ@>=
-if (area_length[f]<area_length[ff]) or (ll<>font_name[f+1]-font_name[f]) then
- goto 99;
-s:=font_name[f];
-k:=ll;
-while k>0 do
- begin decr(k);
- if names[s+k]<>names[ss+k] then goto 99;
- end
-
-@ @<Make sure fonts |f| and |ff| have matching design sizes and checksums@>=
-if abs(font_design_size[f]-font_design_size[ff]) > font_tolerance then
- font_warn('Inconsistent design sizes given for ')(ff)
-@.Inconsistent design sizes@>
-else if font_check_sum[f]<>font_check_sum[ff] then
- font_warn('Checksum mismatch for ')(ff)
-@.Checksum mismatch@>
-
-@* Reading ordinary fonts.
-An auxiliary array |in_width| is used to hold the widths as they are
-input. The global variable |tfm_check_sum| is set to the check sum that
-appears in the current \.{TFM} file.
-
-@<Glob...@>=
-@!in_width:array[0..255] of integer; {\.{TFM} width data in \.{DVI} units}
-@!tfm_check_sum:integer; {check sum found in |tfm_file|}
-
-@ Here is a procedure that absorbs the necessary information from a
-\.{TFM} file, assuming that the file has just been successfully reset
-so that we are ready to read its first byte. (A complete description of
-\.{TFM} file format appears in the documentation of \.{TFtoPL} and will
-not be repeated here.) The procedure does not check the \.{TFM} file
-for validity, nor does it give explicit information about what is
-wrong with a \.{TFM} file that proves to be invalid. The procedure simply
-aborts the program if it detects anything amiss in the \.{TFM} data.
-
-@p procedure in_TFM(@!f:integer);
- {input \.{TFM} data for font |f| or abort}
-label 9997, {go here when the format is bad}
- 9999; {go here to exit}
-var k:integer; {index for loops}
-@!lh:integer; {length of the header data, in four-byte words}
-@!nw:integer; {number of words in the width table}
-@!wp:0..max_widths; {new value of |info_ptr| after successful input}
-begin @<Read past the header data; |goto 9997| if there is a problem@>;
-@<Store character-width indices at the end of the |width| table@>;
-@<Read the width values into the |in_width| table@>;
-@<Move the widths from |in_width| to |width|@>;
-fbase[f]:=0; ftop[f]:=0;
-info_ptr:=wp; goto 9999;
-9997: font_abort('Bad TFM file for ')(f);
-@.Bad TFM file@>
-9999: end;
-
-@ @<Read past the header...@>=
-read_tfm_word; lh:=b2*256+b3;
-read_tfm_word; font_bc[f]:=b0*256+b1; font_ec[f]:=b2*256+b3;
-if font_ec[f]<font_bc[f] then font_bc[f]:=font_ec[f]+1;
-if info_ptr+font_ec[f]-font_bc[f]+1>max_widths then
- abort('DVItoMP capacity exceeded (width table size=',max_widths:1,')!');
-@.DVItoMP capacity exceeded...@>
-wp:=info_ptr+font_ec[f]-font_bc[f]+1;
-read_tfm_word; nw:=b0*256+b1;
-if (nw=0)or(nw>256) then goto 9997;
-for k:=1 to 3+lh do
- begin if eof(tfm_file) then goto 9997;
- read_tfm_word;
- if k=4 then begin
- if b0<128 then tfm_check_sum:=((b0*256+b1)*256+b2)*256+b3
- else tfm_check_sum:=(((b0-256)*256+b1)*256+b2)*256+b3;
- end;
- end;
-
-@ @<Store character-width indices...@>=
-if wp>0 then for k:=info_ptr to wp-1 do
- begin read_tfm_word;
- if b0>nw then goto 9997;
- width[k]:=b0;
- end;
-
-@ No fancy width calculation is needed here because \.{DVItoMP} stores
-widths in their raw form as multiples of the design size scaled by $2^{20}$.
-The |font_scaled_size| entries have been computed so that the final width
-compution can be done in floating point if enough precision is available.
-
-@<Read the width values into the |in_width| table@>=
-for k:=0 to nw-1 do
- begin read_tfm_word;
- if b0>127 then b0:=b0-256;
- in_width[k]:=((b0*@'400+b1)*@'400+b2)*@'400+b3;
- end
-
-@ The width compution uses a scale factor |dvi_scale| that will be introduced
-later. It is equal to one when not typesetting a character from a virtual
-font. In that case, the following expressions do the width computation that is
-so important in \.{DVItype}. It is less important here because it is impractical
-to guarantee precise character positioning in \MP\ output. Nevertheless, the
-width compution will be precise if reals have at least 46-bit mantissas and
-|round(x-.5)| is equivalent to $\lfloor x\rfloor$. It may be a good idea to
-modify this computation if these conditions are not met.
-@^system dependencies@>
-
-@<Width of character |c| in font |f|@>=
-round(dvi_scale*font_scaled_size[f]*char_width(f)(c)-0.5)
-
-@ @<Width of character |p| in font |cur_font|@>=
-round(dvi_scale*font_scaled_size[cur_font]*char_width(cur_font)(p)-0.5)
-
-@ @<Move the widths from |in_width| to |width|@>=
-if in_width[0]<>0 then goto 9997; {the first width should be zero}
-info_base[f]:=info_ptr-font_bc[f];
-if wp>0 then for k:=info_ptr to wp-1 do
- width[k]:=in_width[width[k]]
-
-
-@* Reading virtual fonts.
-The |in_VF| procedure absorbs the necessary information from a \.{VF} file that
-has just been reset so that we are ready to read the first byte. (A complete
-description of \.{VF} file format appears in the documention of \.{VFtoVP}).
-Like |in_TFM|, this procedure simply aborts the program if it detects anything
-wrong with the \.{VF} file.
-
-@p @<Declare a function called |first_par|@>@;
-procedure in_VF(f:integer);
- {read \.{VF} data for font |f| or abort}
-label 9997, {go here to abort}
- 9999; {go here to exit}
-var @!p:integer; {a byte from the \.{VF} file}
-@!was_vf_reading:boolean; {old value of |vf_reading|}
-@!c:integer; {the current character code}
-@!limit:integer; {space limitations force character codes to be less than this}
-@!w:integer; {a \.{TFM} width being read}
-begin was_vf_reading:=vf_reading; vf_reading:=true;
-@<Start reading the preamble from a \.{VF} file@>;@/
-@<Initialize the data structures for the virtual font@>;@/
-p:=get_byte;
-while p>=fnt_def1 do
- begin if p>fnt_def1+3 then goto 9997;
- define_font(first_par(p));
- p:=get_byte;
- end;
-while p<=242 do
- begin if eof(vf_file) then goto 9997;
- @<Read the packet length, character code, and \.{TFM} width@>;
- @<Store the character packet in |cmd_buf|@>;
- p:=get_byte;
- end;
-if p=post then
- begin @<Finish setting up the data structures for the new virtual font@>;
- goto 9999;
- end;
-9997:font_abort('Bad VF file for ')(f);
-9999: vf_reading:=was_vf_reading;
-end;
-
-@ @<Start reading the preamble from a \.{VF} file@>=
-p:=get_byte;
-if p<>pre then goto 9997;
-p:=get_byte; {fetch the identification byte}
-if p<>202 then goto 9997;
-p:=get_byte; {fetch the length of the introductory comment}
-while p>0 do
- begin decr(p); down_the_drain:=get_byte;
- end;
-tfm_check_sum:=signed_quad;
-down_the_drain:=signed_quad; {skip over the design size}
-
-@ @<Initialize the data structures for the virtual font@>=
-ftop[f]:=vf_ptr;
-if vf_ptr=nf then abort('DVItoMP capacity exceeded (max font numbers=',
- max_fnums:1,')');
-@.DVItoMP capacity exceeded...@>
-decr(vf_ptr);
-info_base[f]:=info_ptr;
-limit:=max_widths-info_base[f];@/
-font_bc[f]:=limit; font_ec[f]:=0
-
-@ @<Read the packet length, character code, and \.{TFM} width@>=
-if p=242 then
- begin p:=signed_quad; c:=signed_quad; w:=signed_quad;
- if c<0 then goto 9997;
- end
-else begin c:=get_byte; w:=get_three_bytes;
- end;
-if c>=limit then
- abort('DVItoMP capacity exceeded (max widths=', max_widths:1,')!');
-@.DVItoMP capacity exceeded...@>
-if c<font_bc[f] then font_bc[f]:=c;
-if c>font_ec[f] then font_ec[f]:=c;
-char_width(f)(c):=w
-
-@ @<Store the character packet in |cmd_buf|@>=
-if n_cmds+p>=virtual_space then
- abort('DVItoMP capacity exceeded (virtual font space=',virtual_space:1,')!');
-@.DVItoMP capacity exceeded...@>
-start_cmd(f)(c):=n_cmds;
-while p>0 do
- begin cmd_buf[n_cmds]:=qi(get_byte);
- incr(n_cmds); decr(p);
- end;
-cmd_buf[n_cmds]:=qi(eop); {add the end-of-packet marker}
-incr(n_cmds)
-
-@ There are unused |width| and |cmd_ptr| entries if |font_bc[f]>0| but it isn't
-worthwhile to slide everything down just to save a little space.
-
-@<Finish setting up the data structures for the new virtual font@>=
-fbase[f]:=vf_ptr+1;
-info_ptr:=info_base[f]+font_ec[f]+1
-
-
-@* Loading fonts.
-The character width information for a font is loaded when the font is selected
-for the first time. This information might already be loaded if the font has
-already been used at a different scale factor. Otherwise, we look for a \.{VF}
-file, or failing that, a \.{TFM} file. All this is done by the |select_font|
-function that takes an external font number~|e| and returns the corresponding
-internal font number with the width information loaded.
-
-@p function select_font(@!e:integer):integer;
-var @!f:0..max_fonts; {the internal font number}
-@!ff:0..max_fonts; {internal font number for an existing version}
-@!k:integer; {general purpose loop counter}
-begin @<Set |f| to the internal font number that corresponds to |e|,
- or |abort| if there is none@>;
-if info_base[f]=max_widths then
- begin ff:=match_font(f,false);
- if ff<nf then @<Make font |f| refer to the width information from font |ff|@>
- else begin @<Move the \.{VF} file name into the |cur_name| string@>;
- if open_vf_file then in_VF(f)
- else begin @<Change \.{.VF} to \.{.TFM} in the |cur_name| string@>;
- if not open_tfm_file then font_abort('No TFM file found for ')(f);
- @.no TFM file found@>
- in_TFM(f);
- end;
- @<Make sure the checksum in the font file matches the one given in the
- |font_def| for font |f|@>;
- end;
- @<Do any other initialization required for the new font |f|@>;
- end;
-select_font:=f;
-end;
-
-@ @<Set |f| to the internal font number that corresponds to |e|,...@>=
-if cur_ftop<=nf then cur_ftop:=nf;
-font_num[cur_ftop]:=e;
-k:=cur_fbase;
-while (font_num[k]<>e)or local_only[k] do incr(k);
-if k=cur_ftop then abort('Undefined font selected');
-f:=internal_num[k]
-
-@ @<Make font |f| refer to the width information from font |ff|@>=
-begin font_bc[f]:=font_bc[ff];
-font_ec[f]:=font_ec[ff];
-info_base[f]:=info_base[ff];
-fbase[f]:=fbase[ff];
-ftop[f]:=ftop[ff];
-end
-
-@ If |area_length[f]=0|, i.e., if no font directory has been specified,
-\.{DVItoMP} is supposed to use the default font directory, which is a
-system-dependent place where the standard fonts are kept.
-The string variable |default_directory| contains the name of this area.
-@^system dependencies@>
-
-@d default_directory_name=='TeXfonts:' {change this to the correct name}
-@d default_directory_name_length=9 {change this to the correct length}
-
-@<Glob...@>=
-@!default_directory:packed array[1..default_directory_name_length] of char;
-
-@ @<Set init...@>=
-default_directory:=default_directory_name;
-
-@ The string |cur_name| is supposed to be set to the external name of the
-\.{VF} file for the current font. This usually means that we need to
-prepend the name of the default directory, and
-to append the suffix `\.{.VF}'. Furthermore, we change lower case letters
-to upper case, since |cur_name| is a \PASCAL\ string.
-@^system dependencies@>
-
-@<Move the \.{VF} file name into the |cur_name| string@>=
-for k:=1 to name_length do cur_name[k]:=' ';
-if area_length[f]=0 then
- begin for k:=1 to default_directory_name_length do
- cur_name[k]:=default_directory[k];
- l:=default_directory_name_length;
- end
-else l:=0;
-for k:=font_name[f] to font_name[f+1]-1 do
- begin incr(l);
- if l+3>name_length then
- abort('DVItoMP capacity exceeded (max font name length=',
- name_length:1,')!');
-@.DVItoMP capacity exceeded...@>
- if (names[k]>="a")and(names[k]<="z") then
- cur_name[l]:=xchr[names[k]-@'40]
- else cur_name[l]:=xchr[names[k]];
- end;
-cur_name[l+1]:='.'; cur_name[l+2]:='V'; cur_name[l+3]:='F'
-
-@ It is fairly simple to change a \.{VF} file name to a \.{TFM} file name.
-@^system dependencies@>
-
-@<Change \.{.VF} to \.{.TFM} in the |cur_name| string@>=
-l:=area_length[f];
-if l=0 then l:=default_directory_name_length;
-l:=l+font_name[f+1]-font_name[f];
-if l+4>name_length then
- abort('DVItoMP capacity exceeded (max font name length=',
- name_length:1,')!');
-@.DVItoMP capacity exceeded...@>
-cur_name[l+2]:='T'; cur_name[l+3]:='F'; cur_name[l+4]:='M'
-
-@ @<Make sure the checksum in the font file matches the one given in the...@>=
-begin if (font_check_sum[f]<>0)and(tfm_check_sum<>0)and@|
- (font_check_sum[f]<>tfm_check_sum) then
- begin err_print('DVItoMP warning: Checksum mismatch for ');
-@.Checksum mismatch@>
- err_print_font(f);
- if history=spotless then history:=cksum_trouble;
- end;
-end
-
-@* Low level output routines.
-One of the basic output operations is to write a \MP\ string expression for
-a sequence of characters to be typeset. The main difficulties are that such
-strings can contain arbitrary eight-bit bytes and there is no fixed limit on
-the length of the string that needs to be produced. In extreme cases this
-can lead to expressions such as
-$$\vcenter{
- \hbox{\.{char7\&char15\&char31\&"?FWayzz"}}
- \hbox{\.{\&"zzaF"\&char15\&char3\&char31}}
- \hbox{\.{\&"Nxzzzzzzzwvtsqo"}}}
-$$
-
-@ A global variable |state| keeps track of the output process.
-When |state=normal| we have begun a quoted string and the next character
-should be a printable character or a closing quote. When |state=special|
-the last thing printed was a ``\.{char}'' construction or a closing quote
-and an ampersand should come next. The starting condition |state=initial|
-is a lot like |state=special|, except no ampersand is required.
-
-@d special=0 {the |state| after printing a ``\.{char}'' expression}
-@d normal=1 {the |state| value in a quoted string}
-@d initial=2 {initial |state|}
-
-@<Glob...@>=
-state:special..initial; {controls the process of printing a string}
-print_col:0..line_length;
- {there are at most this many characters on the current line}
-
-@ To print a string on the \.{MPX} file, initialize |print_col|, ensure that
-|state=initial|, and pass the characters one-at-a-time to |print_char|.
-
-@<Declare subroutines for printing strings@>=
-procedure print_char(@!c:eight_bits);
-var @!printable:boolean; {is it safe to print |xchr[c]|?}
-@!l:integer; {number of characters to print |c| or the \.{char} expression}
-begin printable:=(c>=" ")and(c<="~")and(c<>"""");
-if printable then l:=1
-else if c<10 then l:=5
-else if c<100 then l:=6
-else l:=7;
-if print_col+l>line_length-2 then
- begin if state=normal then
- begin print('"'); state:=special;
- end;
- print_ln(' ');
- print_col:=0;
- end;
-@<Print |c| and update |state| and |print_col|@>;
-end;
-
-@ @<Print |c| and update |state| and |print_col|@>=
-if state=normal then
- if printable then print(xchr[c])
- else begin print('"&char',c:1);
- print_col:=print_col+2;
- end
-else begin if state=special then
- begin print('&'); incr(print_col);
- end;
- if printable then
- begin print('"',xchr[c]); incr(print_col);
- end
- else print('char',c:1);
- end;
-print_col:=print_col+l;
-if printable then state:=normal @+else state:=special
-
-@ The |end_char_string| procedure gets the string ended properly and ensures
-that there is room for |l| more characters on the output line.
-
-@<Declare subroutines for printing strings@>=
-procedure end_char_string(@!l:integer);
-begin while state>special do
- begin print('"');
- incr(print_col);
- decr(state);
- end;
-if print_col+l>line_length then
- begin print_ln(' '); print_col:=0;
- end;
-state:=initial; {get ready to print the next string}
-end;
-
-@ Since |end_char_string| resets |state:=initial|, all we have to do is set
-|state:=initial| once at the beginning.
-
-@<Set init...@>=
-state:=initial;
-
-@ Characters and rules are positioned according to global variables |h| and~|v|
-as will be explained later. We also need scale factors that convert quantities
-to the right units when they are printed in the \.{MPX} file.
-
-Even though all variable names in the \MP\ output are made local via \.{save}
-commands, it is still desirable to preceed them with underscores. This makes
-the output more likely to work when used in a macro definition, since the
-generated variables names must not collide with formal parameters in such
-cases.
-
-@<Glob...@>=
-@!h,@!v:integer; {the current position in \.{DVI} units}
-@!conv:real; {converts \.{DVI} units to \MP\ points}
-@!mag:real; {magnification factor times 1000}
-
-@ @p @<Declare a procedure called |finish_last_char|@>@;
-procedure do_set_char(@!f,@!c:integer);
-begin if (c<font_bc[f])or(c>font_ec[f]) then
- abort('attempt to typeset invalid character ',c:1);
-@.attempt to typeset...@>
-if (h<>str_h2)or(v<>str_v)or(f<>str_f)or(dvi_scale<>str_scale) then
- begin if str_f>=0 then finish_last_char
- else if not fonts_used then
- @<Prepare to output the first character on a page@>;
- if not font_used[f] then
- @<Prepare to use font |f| for the first time on a page@>;
- print('_s('); print_col:=3;@/
- str_scale:=dvi_scale; str_f:=f; str_v:=v; str_h1:=h;
- end;
-print_char(c);
-str_h2:=h+@<Width of character |c| in font |f|@>;
-end;
-
-@ @<Glob...@>=
-@!font_used:array[0..max_fonts] of boolean;
- {has this font been used on this page?}
-@!fonts_used:boolean; {has any font been used on this page?}
-@!rules_used:boolean; {has any rules been set on this page?}
-@!str_h1,str_v:integer; {starting position for current output string}
-@!str_h2:integer; {where the current output string ends}
-@!str_f:integer; {internal font number for the current output string}
-@!str_scale:real; {value of |dvi_scale| for the current output string}
-
-@ The |font_used| array is not initialized until it is actually time to output
-a character.
-
-@<Prepare to output the first character on a page@>=
-begin k:=0;
-while (k<nf) do
- begin font_used[k]:=false; incr(k);
- end;
-fonts_used:=true;
-print_ln('string _n[];');
-print_ln('vardef _s(expr _t,_f,_m,_x,_y)=');
-print_ln(' addto _p also _t infont _f scaled _m shifted (_x,_y); enddef;');
-end
-
-@ @<Do any other initialization required for the new font |f|@>=
-font_used[f]:=false;
-
-@ @<Prepare to use font |f| for the first time on a page@>=
-begin font_used[f]:=true;
-print('_n',f:1,'=');
-print_col:=6;
-print_font(f);
-end_char_string(1);
-print_ln(';');
-end
-
-@ We maintain the invariant that |str_f=-1| when there is no output string
-under construction.
-
-@<Declare a procedure called |finish_last_char|@>=
-procedure finish_last_char;
-var @!m,@!x,@!y:real;
- {font scale factor and \MP\ coordinates of reference point}
-begin if str_f>=0 then
- begin m:=str_scale*font_scaled_size[str_f]*mag/font_design_size[str_f];@/
- x:=conv*str_h1; y:=conv*(-str_v);
- if (abs(x)>=4096.0)or(abs(y)>=4096.0)or(m>=4096.0)or(m<0) then
- begin warn('text scaled ',m:1:1,@|
- ' at (',x:1:1,',',y:1:1,') is out of range');
- end_char_string(60);
- end
- else end_char_string(40);
- print_ln(',_n',str_f:1,',',m:1:5,',',x:1:4,',',y:1:4,');');
- str_f:=-1;
- end;
-end;
-
-@ Setting rules is fairly simple.
-
-@p procedure do_set_rule(@!ht,@!wd:integer);
-var @!xx1,@!yy1,@!xx2,@!yy2,@!ww:real;
- {\MP\ coordinates of lower-left and upper-right corners}
-begin if wd=1 then @<Handle a special rule that determines the box size@>
-else if (ht>0)or(wd>0) then
- begin if str_f>=0 then finish_last_char;
- if not rules_used then
- begin rules_used:=true;@/
- print_ln('interim linecap:=0;');@/
- print_ln('vardef _r(expr _a,_w) =');
- print_ln(' addto _p doublepath _a withpen pencircle scaled _w enddef;');
- end;
- @<Make |(xx1,yy1)| and |(xx2,yy2)| then ends of the desired penstroke
- and |ww| the desired stroke width@>;
- if (abs(xx1)>=4096.0)or(abs(yy1)>=4096.0)or@|
- (abs(xx2)>=4096.0)or(abs(yy2)>=4096.0)or(ww>=4096.0) then
- warn('hrule or vrule near (',xx1:1:1,',',yy1:1:1,') is out of range');
- print_ln('_r((',xx1:1:4,',',yy1:1:4,')..(',xx2:1:4,',',yy2:1:4,
- '), ',ww:1:4,');');
- end;
-end;
-
-@ @<Make |(xx1,yy1)| and |(xx2,yy2)| then ends of the desired penstroke...@>=
-xx1:=conv*h;
-yy1:=conv*(-v);
-if wd>ht then
- begin xx2:=xx1+conv*wd;
- ww:=conv*ht;@/
- yy1:=yy1+0.5*ww;
- yy2:=yy1;
- end
-else begin yy2:=yy1+conv*ht;
- ww:=conv*wd;@/
- xx1:=xx1+0.5*ww;
- xx2:=xx1;
- end
-
-@ Rules of width one dvi unit are not typeset since \.{MPtoTeX} adds an
-extraneous rule of this width in order to allow \.{DVItoMP} to deduce the
-dimensions of the boxes it ships out. The box width is the left edge of the
-last such rule; the height and depth are at the top and bottom of the rule.
-There should be only one special rule per picture but there could be more if
-the user tries to typeset his own one-dvi-unit rules. In this case the
-dimension-determining rule is the last one in the picture.
-
-@<Handle a special rule that determines the box size@>=
-begin pic_wd:=h; pic_dp:=v; pic_ht:=ht-v;
-end
-
-@ @<Glob...@>=
-pic_dp, pic_ht, pic_wd: integer; {picture dimensions from special rule}
-
-@ The following initialization and clean-up is required. We do a little more
-initialization than is absolutely necessary since some compilers might complain
-if the variables are uninitialized when |do_set_char| tests them.
-
-@p procedure start_picture;
-begin fonts_used:=false;
-rules_used:=false;
-str_f:=-1;@/
-str_v:=0; str_h2:=0; str_scale:=1.0; {values don't matter}
-print_ln('begingroup save _p,_r,_s,_n; picture _p; _p=nullpicture;');
-end;
-@#
-procedure stop_picture;
-var @!w,@!h,@!dd:real; {width, height, negative depth in PostScript points}
-begin if str_f>=0 then finish_last_char;
-@<Print a \&{setbounds} command based on picture dimensions@>;
-print_ln('_p endgroup');
-end;
-
-@ @<Print a \&{setbounds} command based on picture dimensions@>=
-dd:=-pic_dp*conv;
-w:=conv*pic_wd; h:=conv*pic_ht;@/
-print_ln('setbounds _p to (0,',dd:1:4,')--(',w:1:4,',',dd:1:4,')--');
-print_ln(' (',w:1:4,',',h:1:4,')--(0,',h:1:4,')--cycle;')
-
-@* Translation to symbolic form.
-The main work of \.{DVItoMP} is accomplished by the |do_dvi_commands|
-procedure, which produces the output for an entire page, assuming that the
-|bop| command for that page has already been processed. This procedure is
-essentially an interpretive routine that reads and acts on the \.{DVI}
-commands. It is also capable of executing the typesetting commands for
-a character in a virtual font.
-
-@ The definition of \.{DVI} files refers to six registers,
-$(h,v,w,x,y,z)$, which hold integer values in \.{DVI} units.
-These units come directly from the input file except they need to be
-rescaled when typesetting characters from a virtual font.
-The stack of $(h,v,w,x,y,z)$ values is represented by six arrays
-called |hstack|, \dots, |zstack|.
-
-@<Glob...@>=
-@!w,@!x,@!y,@!z:integer;
- {current state values (|h| and |v| have already been declared)}
-@!hstack,@!vstack,@!wstack,@!xstack,@!ystack,@!zstack:
- array [0..stack_size] of integer; {pushed down values in \.{DVI} units}
-@!stk_siz:integer; {the current stack size}
-@!dvi_scale:real; {converts units of current input source to \.{DVI} units}
-
-@ @<Do initialization required before starting a new page@>=
-dvi_scale:=1.0;
-stk_siz:=0;
-h:=0; v:=0
-
-@ Next, we need procedures to handle |push| and |pop| commands.
-
-@p procedure do_push;
-begin if stk_siz=stack_size then
- abort('DVItoMP capacity exceeded (stack size=',stack_size:1,')');
-@.DVItoMP capacity exceeded...@>
-hstack[stk_siz]:=h; vstack[stk_siz]:=v; wstack[stk_siz]:=w;
-xstack[stk_siz]:=x; ystack[stk_siz]:=y; zstack[stk_siz]:=z;
-incr(stk_siz);
-end;
-@#
-procedure do_pop;
-begin if stk_siz=0 then bad_dvi('attempt to pop empty stack')
-else begin decr(stk_siz);
- h:=hstack[stk_siz]; v:=vstack[stk_siz]; w:=wstack[stk_siz];
- x:=xstack[stk_siz]; y:=ystack[stk_siz]; z:=zstack[stk_siz];
- end;
-end;
-
-@ We need to define the |set_virtual_char| procedure now because it is
-mutually recursive with |do_dvi_commands|. This is really a supervisory
-@^recursion@>
-procedure that calls |do_set_char| or adjusts the input source to read
-typesetting commands for a character in a virtual font.
-
-@p procedure do_dvi_commands;forward;@t\2@>
-procedure set_virtual_char(@!f,@!c:integer);
-var @!old_scale:real; {original value of |dvi_scale|}
-@!old_buf_ptr:0..virtual_space; {original value of the input pointer |buf_ptr|}
-@!old_fbase,@!old_ftop:0..max_fnums;
- {originally applicable part of the |font_num| table}
-begin if fbase[f]=0 then do_set_char(f,c)
-else begin old_fbase:=cur_fbase; old_ftop:=cur_ftop;
- cur_fbase:=fbase[f]; cur_ftop:=ftop[f];@/
- old_scale:=dvi_scale;
- dvi_scale:=dvi_scale*font_scaled_size[f];
- old_buf_ptr:=buf_ptr;
- buf_ptr:=start_cmd(f)(c);@/
- do_push;
- do_dvi_commands;
- do_pop;@/
- buf_ptr:=old_buf_ptr;
- dvi_scale:=old_scale;
- cur_fbase:=old_fbase; cur_ftop:=old_ftop;
- end;
-end;
-
-@ Before we get into the details of |do_dvi_commands|, it is convenient to
-consider a simpler routine that computes the first parameter of each
-opcode.
-
-@d four_cases(#)==#,#+1,#+2,#+3
-@d eight_cases(#)==four_cases(#),four_cases(#+4)
-@d sixteen_cases(#)==eight_cases(#),eight_cases(#+8)
-@d thirty_two_cases(#)==sixteen_cases(#),sixteen_cases(#+16)
-@d sixty_four_cases(#)==thirty_two_cases(#),thirty_two_cases(#+32)
-
-@<Declare a function called |first_par|@>=
-function first_par(o:eight_bits):integer;
-begin first_par:=0; {for compiler warnings}
-case o of
-sixty_four_cases(set_char_0),sixty_four_cases(set_char_0+64):
- first_par:=o-set_char_0;
-set1,put1,fnt1,xxx1,fnt_def1: first_par:=get_byte;
-set1+1,put1+1,fnt1+1,xxx1+1,fnt_def1+1: first_par:=get_two_bytes;
-set1+2,put1+2,fnt1+2,xxx1+2,fnt_def1+2: first_par:=get_three_bytes;
-right1,w1,x1,down1,y1,z1: first_par:=signed_byte;
-right1+1,w1+1,x1+1,down1+1,y1+1,z1+1: first_par:=signed_pair;
-right1+2,w1+2,x1+2,down1+2,y1+2,z1+2: first_par:=signed_trio;
-set1+3,set_rule,put1+3,put_rule,right1+3,w1+3,x1+3,down1+3,y1+3,z1+3,
- fnt1+3,xxx1+3,fnt_def1+3: first_par:=signed_quad;
-nop,bop,eop,push,pop,pre,post,post_post,undefined_commands: first_par:=0;
-w0: first_par:=w;
-x0: first_par:=x;
-y0: first_par:=y;
-z0: first_par:=z;
-sixty_four_cases(fnt_num_0): first_par:=o-fnt_num_0;
-end;
-end;
-
-@ Here is the |do_dvi_commands| procedure.
-
-@p procedure do_dvi_commands;
-label 9999;
-var o:eight_bits; {operation code of the current command}
-@!p,@!q:integer; {parameters of the current command}
-@!cur_font:integer; {current internal font number}
-begin if (cur_fbase<cur_ftop) and (buf_ptr<virtual_space) then
- cur_font:=select_font(font_num[cur_ftop-1]) {select first local font}
-else cur_font:=max_fnums+1; {current font is undefined}
-w:=0; x:=0; y:=0; z:=0; {initialize the state variables}
-while true do @<Translate the next command in the \.{DVI} file;
- |goto 9999| if it was |eop|@>;
-9999: do_nothing;
-end;
-
-@ The multiway switch in |first_par|, above, was organized by the length
-of each command; the one in |do_dvi_commands| is organized by the semantics.
-
-@ @<Translate the next command...@>=
-begin o:=get_byte; p:=first_par(o);
-if eof(dvi_file) then bad_dvi('the DVI file ended prematurely');
-@.the DVI file ended prematurely@>
-if o<set1+4 then {|set_char_0| through |set_char_127|, |set1| through |set4|}
- begin if cur_font>max_fnums then begin
- if vf_reading then
- abort('no font selected for character ',p:1,' in virtual font')
- else bad_dvi('no font selected for character ',p:1);
- end;
-@.no font selected@>
- set_virtual_char(cur_font,p);
- h:=h+@<Width of character |p| in font |cur_font|@>;
- end
-else case o of
- four_cases(put1): set_virtual_char(cur_font,p);
- set_rule: begin q:=trunc(signed_quad*dvi_scale);
- do_set_rule(trunc(p*dvi_scale),q);
- h:=h+q;
- end;
- put_rule: do_set_rule(trunc(p*dvi_scale),trunc(signed_quad*dvi_scale));
- @t\4@>@<Additional cases for translating \.{DVI} command |o| with
- first paramter |p|@>@;
- undefined_commands:bad_dvi('undefined command ',o:1);
-@.undefined command@>
- end; {all cases have been enumerated}
-end
-
-@ @<Additional cases for translating \.{DVI} command |o|...@>=
-four_cases(xxx1): for k:=1 to p do
- down_the_drain:=get_byte;
-pre,post,post_post: bad_dvi('preamble or postamble within a page!');
-@.preamble or postamble within a page@>
-
-@ @<Additional cases for translating \.{DVI} command |o|...@>=
-nop: do_nothing;
-bop: bad_dvi('bop occurred before eop');
-@.bop occurred before eop@>
-eop: goto 9999;
-push: do_push;
-pop: do_pop;
-
-@ @<Additional cases for translating \.{DVI} command |o|...@>=
-four_cases(right1):h:=h+trunc(p*dvi_scale);
-w0,four_cases(w1):begin w:=trunc(p*dvi_scale); h:=h+w;
- end;
-x0,four_cases(x1):begin x:=trunc(p*dvi_scale); h:=h+x;
- end;
-four_cases(down1):v:=v+trunc(p*dvi_scale);
-y0,four_cases(y1):begin y:=trunc(p*dvi_scale); v:=v+y;
- end;
-z0,four_cases(z1):begin z:=trunc(p*dvi_scale); v:=v+z;
- end;
-
-@ @<Additional cases for translating \.{DVI} command |o|...@>=
-sixty_four_cases(fnt_num_0),four_cases(fnt1):
- cur_font:=select_font(p);
-four_cases(fnt_def1): define_font(p);
-
-@* The main program.
-Now we are ready to put it all together. This is where \.{DVItoMP} starts,
-and where it ends.
-
-@p begin initialize; {get all variables initialized}
-@<Process the preamble@>;
-open_mpx_file;
-print_ln(banner);
-begin while true do
- begin @<Advance to the next |bop| command@>;
- for k:=0 to 10 do down_the_drain:=signed_quad;
- @<Do initialization required before starting a new page@>;
- start_picture;
- do_dvi_commands;
- if stk_siz<>0 then bad_dvi('stack not empty at end of page');
-@.stack not empty...@>
- stop_picture;
- print_ln('mpxbreak');
- end;
-done:end;
-final_end:end.
-
-@ The main program needs a few global variables in order to do its work.
-
-@<Glob...@>=
-@!k,@!p:integer; {general purpose registers}
-@!numerator,@!denominator:integer; {stated conversion ratio}
-
-@ @<Process the preamble@>=
-open_dvi_file;
-p:=get_byte; {fetch the first byte}
-if p<>pre then bad_dvi('First byte isn''t start of preamble!');
-@.First byte isn't...@>
-p:=get_byte; {fetch the identification byte}
-if p<>id_byte then
- warn('identification in byte 1 should be ',id_byte:1,'!');
-@.identification...should be n@>
-@<Compute the conversion factor@>;
-p:=get_byte; {fetch the length of the introductory comment}
-while p>0 do
- begin decr(p); down_the_drain:=get_byte;
- end
-
-@ The conversion factor |conv| is figured as follows: There are exactly
-|n/d| decimicrons per \.{DVI} unit, and 254000 decimicrons per inch,
-and |resolution| pixels per inch. Then we have to adjust this
-by the stated amount of magnification. No such adjustment is needed for
-|dvi_per_fix| since it is used to convert design sizes.
-
-@<Compute the conversion factor@>=
-numerator:=signed_quad; denominator:=signed_quad;
-if (numerator<=0)or(denominator<=0) then
- bad_dvi('bad scale ratio in preamble');
-@.bad scale ratio@>
-mag:=signed_quad/1000.0;
-if mag<=0.0 then bad_dvi('magnification isn''t positive');
-@.magnification isn't positive@>
-conv:=(numerator/254000.0)*(72.0/denominator)*mag;
-dvi_per_fix:=(254000.0/numerator)*(denominator/72.27)/1048576.0;
-
-@ @<Advance to the next |bop| command@>=
-repeat k:=get_byte;
-if (k>=fnt_def1)and(k<fnt_def1+4) then
- begin p:=first_par(k); define_font(p); k:=nop;
- end;
-until k<>nop;
-if k=post then goto done;
-if k<>bop then bad_dvi('missing bop');
-@.missing bop@>
-
-
-@* System-dependent changes.
-This section should be replaced, if necessary, by changes to the program
-that are necessary to make \.{DVItoMP} 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 printed 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@>
-
-@* Index.
-Pointers to error messages appear here together with the section numbers
-where each ident\-i\-fier is used.
diff --git a/Build/source/texk/web2c/man/Makefile.am b/Build/source/texk/web2c/man/Makefile.am
index 73e036b0966..77c1a324b19 100644
--- a/Build/source/texk/web2c/man/Makefile.am
+++ b/Build/source/texk/web2c/man/Makefile.am
@@ -15,7 +15,8 @@ web_man_sources = bibtex.man dvicopy.man dvitomp.man dvitype.man gftodvi.man \
gftopk.man gftype.man mft.man patgen.man pktogf.man pktype.man \
pltotf.man pooltype.man tftopl.man vftovp.man vptovf.man weave.man
-man_sources += $(mpware_man_sources)
+## Obsolete mpware manpages
+## man_sources += $(mpware_man_sources)
EXTRA_DIST += $(mpware_man_sources)
mpware_man_sources = dmp.man makempx.man mpto.man newer.man
@@ -43,10 +44,10 @@ endif ETEX
EXTRA_DIST += etex.man
if PDFTEX
-man_sources += $(pdeftex_man_sources)
+man_sources += $(pdftex_man_sources)
endif PDFTEX
-EXTRA_DIST += $(pdeftex_man_sources)
-pdeftex_man_sources = pdftex.man pdftosrc.man
+EXTRA_DIST += $(pdftex_man_sources)
+pdftex_man_sources = pdftex.man pdftosrc.man
if LUATEX
man_sources +=
diff --git a/Build/source/texk/web2c/man/Makefile.in b/Build/source/texk/web2c/man/Makefile.in
index a7a7d9811e1..860816b90b8 100644
--- a/Build/source/texk/web2c/man/Makefile.in
+++ b/Build/source/texk/web2c/man/Makefile.in
@@ -39,7 +39,7 @@ host_triplet = @host@
@MFN_TRUE@@MF_TRUE@am__append_4 =
@MP_TRUE@am__append_5 = mpost.man
@ETEX_TRUE@am__append_6 = etex.man
-@PDFTEX_TRUE@am__append_7 = $(pdeftex_man_sources)
+@PDFTEX_TRUE@am__append_7 = $(pdftex_man_sources)
@LUATEX_TRUE@am__append_8 =
@XETEX_TRUE@am__append_9 =
@OTANGLE_TRUE@am__append_10 =
@@ -283,14 +283,14 @@ top_srcdir = @top_srcdir@
wlibs = @wlibs@
x_ext_lib = @x_ext_lib@
x_tool_libs = @x_tool_libs@
-man_sources = $(bootstrap_man_sources) $(am__append_1) \
- $(mpware_man_sources) $(am__append_2) $(am__append_3) \
- $(am__append_4) $(am__append_5) $(am__append_6) \
- $(am__append_7) $(am__append_8) $(am__append_9) \
- $(am__append_10) $(am__append_11) $(misc_man_sources)
+man_sources = $(bootstrap_man_sources) $(am__append_1) $(am__append_2) \
+ $(am__append_3) $(am__append_4) $(am__append_5) \
+ $(am__append_6) $(am__append_7) $(am__append_8) \
+ $(am__append_9) $(am__append_10) $(am__append_11) \
+ $(misc_man_sources)
EXTRA_DIST = $(bootstrap_man_sources) $(web_man_sources) \
$(mpware_man_sources) tex.man mf.man mpost.man etex.man \
- $(pdeftex_man_sources) aleph.man $(misc_man_sources) \
+ $(pdftex_man_sources) aleph.man $(misc_man_sources) \
amslatex.min initex.min lamstex.min pdftexman.m4 slitex.min \
spell.add virtex.min
bootstrap_man_sources = cweb.man tangle.man
@@ -299,7 +299,7 @@ web_man_sources = bibtex.man dvicopy.man dvitomp.man dvitype.man gftodvi.man \
pltotf.man pooltype.man tftopl.man vftovp.man vptovf.man weave.man
mpware_man_sources = dmp.man makempx.man mpto.man newer.man
-pdeftex_man_sources = pdftex.man pdftosrc.man
+pdftex_man_sources = pdftex.man pdftosrc.man
misc_man_sources = \
amstex.man \
eplain.man \
diff --git a/Build/source/texk/web2c/mp.ch b/Build/source/texk/web2c/mp.ch
deleted file mode 100644
index 0d914ee9a4f..00000000000
--- a/Build/source/texk/web2c/mp.ch
+++ /dev/null
@@ -1,2100 +0,0 @@
-% $Id: mp.ch,v 1.8 2005/03/18 19:49:05 taco Exp $
-% mp.ch for C compilation with web2c. Public domain.
-%
-% Derived from mf.ch and John Hobby's mp.ch (the change file for the C
-% version of mf).
-%
-% Numbers of the form [pp.nnn] refer to the corresponding part and
-% module number of mp.web as implementors who read this change file are
-% much better advised to use a current WEB listing of MetaPost.
-%
-% (more recent changes in ChangeLog)
-% Revision 0.62 Jan 4 '95 by John Hobby
-% (Changes that only affect the banner line are not listed here)
-%
-% Updated for web2c-6.1/kpathsea-2.6 Jan 29 '95 by Ulrik Vieth
-% according to the current version of mf.ch.
-%
-% - produce separate binaries for INIMP, VIRMF (no '-I' flag!)
-% - make a big version of MP by default (cf. TeX and METAFONT)
-% - allow any input characters (0..255) (cf. TeX and METAFONT)
-% - use web2c/kpathsea routines in file opening and searching
-%
-% Updated for Revision 0.63 Apr 12 '95 by Ulrik Vieth
-%
-% - fixed the parsing routines for ps_tab_file to be able to handle
-% comments and blank lines in dvipsk's version of psfonts.map.
-% - increased max_read_files to 30 to avoid running out of read files
-% when reading stops before reaching EOF. (Better solution: write
-% a 'closefrom' macro that reads to EOF, which causes file closing.)
-
-@x [0] WEAVE: print changes only.
-\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
-@y
-\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
-\let\maybe=\iffalse
-\def\title{\MP\ changes for C}
-\def\glob{13}\def\gglob{20, 25} % these are defined in module 1
-\font\mc=cmr9
-@z
-
-@x [1.7] Convert `debug..gubed' and `stat..tats' into #ifdefs.
-@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 [1.8] Same, for `init..tini'.
-@d init== {change this to `$\\{init}\equiv\.{@@\{}$' in the production version}
-@d tini== {change this to `$\\{tini}\equiv\.{@@\}}$' in the production version}
-@y
-@d init==ifdef('INIMP')
-@d tini==endif('INIMP')
-@z
-
-% [1.11] Compile-time constants. Although we only change a few of
-% these, listing them all makes the patch file for a big MetaPost simpler.
-% 16K for BSD I/O; file_name_size is set from the system constant.
-@x
-@<Constants...@>=
-@!mem_max=30000; {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|}
-@!max_internal=100; {maximum number of internal quantities}
-@!buf_size=500; {maximum number of characters simultaneously present in
- current lines of open files; 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}
-@!emergency_line_length=255;
- {\ps\ output lines can be this long in unusual circumstances}
-@!stack_size=30; {maximum number of simultaneous input sources}
-@!max_read_files=4; {maximum number of simultaneously open \&{readfrom} files}
-@!max_strings=2500; {maximum number of strings; must not exceed |max_halfword|}
-@!string_vacancies=9000; {the minimum number of characters that should be
- available for the user's identifier names and strings,
- after \MP's own error messages are stored}
-@!strings_vacant=1000; {the minimum number of strings that should be available}
-@!pool_size=32000; {maximum number of characters in strings, including all
- error messages and help texts, and the names of all identifiers;
- must exceed |string_vacancies| by the total
- length of \MP's own strings, which is currently about 22000}
-@!font_max=50; {maximum font number for included text fonts}
-@!font_mem_size=10000; {number of words for \.{TFM} information for text fonts}
-@!file_name_size=40; {file names shouldn't be longer than this}
-@!pool_name='MPlib:MP.POOL ';
- {string of length |file_name_size|; tells where the string pool appears}
-@.MPlib@>
-@!ps_tab_name='MPlib:PSFONTS.MAP ';
- {string of length |file_name_size|; locates font name translation table}
-@!path_size=300; {maximum number of knots between breakpoints of a path}
-@!bistack_size=785; {size of stack for bisection algorithms;
- should probably be left at this value}
-@!header_size=100; {maximum number of \.{TFM} header words, times~4}
-@!lig_table_size=5000; {maximum number of ligature/kern steps, must be
- at least 255 and at most 32510}
-@!max_kerns=500; {maximum number of distinct kern amounts}
-@!max_font_dimen=50; {maximum number of \&{fontdimen} parameters}
-@y
-@d file_name_size == maxint
-@d ssup_error_line = 255
-@d ssup_max_strings = 32767 {max value allowed by \.{TANGLE}}
-
-@<Constants...@>=
-@!max_internal=300; {maximum number of internal quantities}
-@!emergency_line_length=255;
- {\ps\ output lines can be this long in unusual circumstances}
-@!stack_size=300; {maximum number of simultaneous input sources}
-@!max_read_files=30; {maximum number of simultaneously open \&{readfrom} files}
-@!strings_vacant=1000; {the minimum number of strings that should be available}
-@!font_max=50; {maximum font number for included text fonts}
-@!font_mem_size=10000; {number of words for \.{TFM} information for text fonts}
-@!pool_name=TEXMF_POOL_NAME;
- {string of length |file_name_size|; tells where the string pool appears}
-@!engine_name=TEXMF_ENGINE_NAME; {the name of this engine}
-@.MPlib@>
-@!ps_tab_name='psfonts.map';
- {string of length |file_name_size|; locates font name translation table}
-@!bistack_size=1500; {size of stack for bisection algorithms;
- should probably be left at this value}
-@!header_size=100; {maximum number of \.{TFM} header words, times~4}
-@!lig_table_size=15000; {maximum number of ligature/kern steps, must be
- at least 255 and at most 32510}
-@!max_kerns=2500; {maximum number of distinct kern amounts}
-@!max_font_dimen=50; {maximum number of \&{fontdimen} parameters}
-@#
-@!inf_main_memory = 3000;
-@!sup_main_memory = 8000000;
-
-@!inf_max_strings = 2500;
-@!sup_max_strings = ssup_max_strings;
-
-@!inf_buf_size = 500;
-@!sup_buf_size = 300000;
-
-@!inf_path_size = 1000;
-@!sup_path_size = 300000;
-
-@!inf_pool_size = 32000;
-@!sup_pool_size = 10000000;
-@!inf_pool_free = 1000;
-@!sup_pool_free = sup_pool_size;
-@!inf_string_vacancies = 8000;
-@!sup_string_vacancies = sup_pool_size - 23000;
-@z
-
-@x [1.12] Constants defined as WEB macros.
-@d mem_min=0 {smallest index in the |mem| array, must not be less
- than |min_halfword|}
-@d mem_top==30000 {largest index in the |mem| array dumped by \.{INIMP};
- must be substantially larger than |mem_min|
- and not greater than |mem_max|}
-@d hash_size=2100 {maximum number of symbolic tokens,
- must be less than |max_halfword-3*param_size|}
-@d hash_prime=1777 {a prime number equal to about 85\pct! of |hash_size|}
-@d max_in_open=6 {maximum number of input files and error insertions that
- can be going on simultaneously}
-@d param_size=150 {maximum number of simultaneous macro parameters}
-@d max_write_files=4 {maximum number of simultaneously open \&{write} files}
-@y
-@d mem_min=0 {smallest index in the |mem| array, must not be less
- than |min_halfword|}
-@d hash_size=9500 {maximum number of symbolic tokens,
- must be less than |max_halfword-3*param_size|}
-@d hash_prime=7919 {a prime number equal to about 85\pct! of |hash_size|}
-@d max_in_open=25 {maximum number of input files and error insertions that
- can be going on simultaneously}
-@d param_size=1500 {maximum number of simultaneous macro parameters}
-@d max_write_files=10 {maximum number of simultaneously open \&{write} files}
-@z
-
-@x [1.13] Global parameters that can be changed in texmf.cnf.
-@<Glob...@>=
-@!bad:integer; {is some ``constant'' wrong?}
-@y
-@<Glob...@>=
-@!bad:integer; {is some ``constant'' wrong?}
-@#
-@!init
-@!ini_version:boolean; {are we \.{INIMP}? Set in \.{lib/texmfmp.c}}
-@!dump_option:boolean; {was the dump name option used?}
-@!dump_line:boolean; {was a \.{\%\AM mem} line seen?}
-tini@/
-@#
-@!bound_default:integer; {temporary for setup}
-@!bound_name:^char; {temporary for setup}
-@#
-@!main_memory:integer; {total memory words allocated in initex}
-@!mem_top:integer; {largest index in the |mem| array dumped by \.{INIMP};
- must be substantially larger than |mem_min|
- and not greater than |mem_max|}
-@!extra_mem_top:integer; {|mem_max:=mem_top+extra_mem_top| except in \.{INIMP}}
-@!mem_max:integer; {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|}
-@!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}
-@!pool_size:integer; {maximum number of characters in strings, including all
- error messages and help texts, and the names of all identifiers;
- must exceed |string_vacancies| by the total
- length of \MP's own strings, which is currently about 22000}
-@!string_vacancies:integer; {the minimum number of characters that should be
- available for the user's identifier names and strings,
- after \MP's own error messages are stored}
-@!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|}
-@!path_size:integer; {maximum number of knots between breakpoints of a path}
-@!pool_free:integer;{minimum pool space free after format loaded}
-@!max_strings:integer; {maximum number of strings; must not exceed |max_halfword|}
-@!parse_first_line_p:c_int_type; {parse the first line for options}
-@!file_line_error_style_p:c_int_type; {file:line:error style messages.}
-@!eight_bit_p:c_int_type; {make all characters printable by default}
-@!halt_on_error_p:c_int_type; {stop at first error}
-@!quoted_filename:boolean; {current filename is quoted}
-@z
-
-@x [1.16] Use C macros for `incr' and `decr'.
-@d incr(#) == #:=#+1 {increase a variable by unity}
-@d decr(#) == #:=#-1 {decrease a variable by unity}
-@y
-@z
-
-% [2.19] 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 [2.22] Allow any character as input.
-@^character set dependencies@>
-@^system dependencies@>
-
-@<Set init...@>=
-for i:=0 to @'37 do xchr[i]:=' ';
-for i:=@'177 to @'377 do xchr[i]:=' ';
-@y
-@^character set dependencies@>
-@^system dependencies@>
-
-@d tab = @'11 { ASCII horizontal tab }
-@d form_feed = @'14 { ASCII form feed }
-
-@<Set init...@>=
-{Initialize |xchr| to the identity mapping.}
-for i:=0 to @'37 do xchr[i]:=i;
-for i:=@'177 to @'377 do xchr[i]:=i;
-@z
-
-@x [2.23]
-for i:=0 to @'176 do xord[xchr[i]]:=i;
-@y
-for i:=0 to @'176 do xord[xchr[i]]:=i;
-{Set |xprn| for printable ASCII, unless |eight_bit_p| is set.}
-for i:=0 to 255 do xprn[i]:=(eight_bit_p or ((i>=" ")and(i<="~")));
-
-{The idea for this dynamic translation comes from the patch by
- Libor Skarvada \.{<libor@@informatics.muni.cz>}
- and Petr Sojka \.{<sojka@@informatics.muni.cz>}. I didn't use any of the
- actual code, though, preferring a more general approach.}
-
-{This sets the |xchr|, |xord|, and |xprn| arrays. We overwrite the
- |xchr| assignments from module 21, just in case someone wants to do strange
- character translations. See the function definition in \.{texmfmp.c} for
- more comments.}
-if translate_filename then read_tcx_file;
-@z
-
-% [3.25] Declare name_of_file as a C string. See comments in tex.ch for
-% why we change the element type to text_char.
-@x
-@!name_of_file:packed array[1..file_name_size] of char;@;@/
- {on some systems this may be a \&{record} variable}
-@y
-@!name_of_file:^text_char;
-@z
-
-@x [3.26] Do file opening in C.
-@ The \ph\ compiler with which the original version of \MF\ was prepared
-extends 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 `\ignorespaces|packed
-array[@t\<\\{any}>@>] of text_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
-\MP\ to undertake appropriate corrective action.
-@:PASCAL H}{\ph@>
-@^system dependencies@>
-
-\MP's file-opening procedures return |false| if no file identified by
-|name_of_file| 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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/O'); w_open_out:=rewrite_OK(f);
-end;
-@y
-@ All of the file opening functions are defined in C.
-@d no_file_path = -1
-@z
-
-@x [3.27] Do file closing in C.
-@ Files can be closed with the \ph\ routine `|close(f)|', which
-@:PASCAL H}{\ph@>
-@^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.
-
-@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 [3.29] l.888 - Array size of input buffer is determined at runtime.
-@!buffer:array[0..buf_size] of ASCII_code; {lines of characters being read}
-@y
-@!buffer:^ASCII_code; {lines of characters being read}
-@z
-
-@x [3.30] Do `input_ln' in C.
-Standard \PASCAL\ says that a file should have |eoln| immediately
-before |eof|, but \MP\ 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).
-
-@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]:=xord[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.
-
-@p @{ @<Report overflow of the input buffer, and abort@> @}
-@z
-
-@x [3.31] `term_in' and `term_out' are standard input and output.
-@<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}
-@z
-
-@x [3.32] We don't need to open the terminal files.
-@ Here is how to open the terminal files
-in \ph. The `\.{/I}' switch suppresses the first |get|.
-@:PASCAL H}{\ph@>
-@^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 [3.33] Flushing output.
-these operations can be specified in \ph:
-@:PASCAL H}{\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| (via the macro |flush|). |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 [3.36] Reading the command line.
-@ 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 write_ln(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;
- write_ln(term_out,'Please type the name of your input file.');
- end;
-exit:end;
-@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;
- loop@+begin
- wake_up_terminal; write(term_out, '**'); update_terminal;
-@.**@>
- if not input_ln(term_in,true) then begin {this shouldn't happen}
- write_ln(term_out);
- write_ln(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;
- write_ln(term_out, 'Please type the name of your input file.');
- end;
-exit:
-end;
-@z
-
-@x [4.38] Dynamically allocate pool arrays.
-@!str_pool:packed array[pool_pointer] of pool_ASCII_code; {the characters}
-@!str_start : array[str_number] of pool_pointer; {the starting pointers}
-@!next_str : array[str_number] of str_number; {for linking strings in order}
-@y
-@!str_pool:^pool_ASCII_code; {the characters}
-@!str_start : ^pool_pointer; {the starting pointers}
-@!next_str : ^str_number; {for linking strings in order}
-@z
-
-@x [4.44] One more array.
-@!str_ref:array[str_number] of 0..max_str_ref;
-@y
-@!str_ref:^str_ref_type; {web2c only does |^identifier|}
-@z
-
-@x [4.64] l.1430 -- Do not hardwire printable ASCII.
- (k<" ")or(k>"~")
-@y
- not xprn[k]
-@z
-
-@x [5.69] error_line is a variable, so can't be a subrange array bound
-@!trick_buf:array[0..error_line] of ASCII_code; {circular buffer for
-@y
-@!trick_buf:array[0..ssup_error_line] of ASCII_code; {circular buffer for
-@z
-
-@x [5.76] Print rest of banner, eliminate misleading `no preloaded'
-@ By popular demand, \MP\ prints the banner line only on the transcript file.
-Thus there is nothing special to be printed here.
-
-@<Initialize the output...@>=
-update_terminal;
-@y
-@ 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 mem_ident>0 then print(mem_ident); print_ln;
-if translate_filename then begin
- wterm('(');
- fputs(translate_filename, stdout);
- wterm_ln(')');
-end;
-update_terminal;
-@z
-
-@x [6.83] l.1815 - Add unspecified_mode.
-@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 [6.83] l.1825 - file:line:error style messages.
- print_nl("! "); print(#);
-@y
- if (file_line_error_style_p and not terminal_input) then
- begin
- print_nl ("");
- print (full_source_filename_stack[in_open]);
- print (":"); print_int (line); print (": ");
- print (#);
- end
- else begin print_nl("! "); print(#) end;
-@z
-
-@x [6.83] l.1822 - Add interaction_option.
-@!interaction:batch_mode..error_stop_mode; {current level of interaction}
-@y
-@!interaction:batch_mode..error_stop_mode; {current level of interaction}
-@!interaction_option:batch_mode..unspecified_mode; {set from command line}
-@z
-
-@x [6.84] l.1824 - Allow override by command line switch.
-@ @<Set init...@>=interaction:=error_stop_mode;
-@y
-@ @<Set init...@>=if interaction_option=unspecified_mode then
- interaction:=error_stop_mode
-else
- interaction:=interaction_option;
-@z
-
-@x [6.90] Eliminate non-local goto.
-@<Error hand...@>=
-procedure jump_out;
-begin goto end_of_MP;
-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 [6.92] l.1956 - halt on error?
-print_char("."); show_context;
-@y
-print_char("."); show_context;
-if (halt_on_error_p) then begin
- history:=fatal_error_stop; jump_out;
-end;
-@z
-
-@x [6.93] Handle the switch-to-editor option.
-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 |call_edit| 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 \MP\ has closed
-its files.
-@^system dependencies@>
-
-There is a secret `\.D' option available when the debugging routines have
-not been commented out.
-@^debugging@>
-@d edit_file==input_stack[file_ptr]
-@z
-@x
-"E": if file_ptr>0 then
- begin print_nl("You want to edit file ");
-@.You want to edit file x@>
- print(input_stack[file_ptr].name_field);
- print(" at line "); print_int(true_line);@/
- interaction:=scroll_mode; jump_out;
-@y
-"E": if file_ptr>0 then
- begin
- edit_name_start:=str_start[edit_file.name_field];
- edit_name_length:=length(edit_file.name_field);
- edit_line:=true_line;
- jump_out;
-@z
-
-@x [7.111] Do half and halfp in cpascal.h.
-@d half(#)==(#) div 2
-@d halfp(#)==(#) div 2
-@y
-@z
-
-@x [7.122-7.130] Optionally replace make_fraction etc. with external routines.
-@p function make_fraction(@!p,@!q:integer):fraction;
-@y
-In the C version, there are external routines that use double precision
-floating point to simulate functions such as |make_fraction|. This is carefully
-done to be virtually machine-independent and it gives up to 12 times speed-up
-on machines with hardware floating point. Since some machines do not have fast
-double-precision floating point, we provide a C preprocessor switch that allows
-selecting the standard versions given below.
-
-@p ifdef('FIXPT')@/
-function make_fraction(@!p,@!q:integer):fraction;
-@z
-@x
- if negative then make_fraction:=-(f+n)@+else make_fraction:=f+n;
- end;
-end;
-@y
- if negative then make_fraction:=-(f+n)@+else make_fraction:=f+n;
- end;
-end;@/
-endif('FIXPT')
-@z
-@x
-@p function take_fraction(@!q:integer;@!f:fraction):integer;
-@y
-@p ifdef('FIXPT')@/
-function take_fraction(@!q:integer;@!f:fraction):integer;
-@z
-@x
-else take_fraction:=n+p;
-end;
-@y
-else take_fraction:=n+p;
-end;@/
-endif('FIXPT')
-@z
-@x
-@p function take_scaled(@!q:integer;@!f:scaled):integer;
-@y
-@p ifdef('FIXPT')@/
-function take_scaled(@!q:integer;@!f:scaled):integer;
-@z
-@x
-else take_scaled:=n+p;
-end;
-@y
-else take_scaled:=n+p;
-end;@/
-endif('FIXPT')
-@z
-@x
-operands are positive. \ (This procedure is not used especially often,
-so it is not part of \MP's inner loop.)
-
-@p function make_scaled(@!p,@!q:integer):scaled;
-@y
-operands are positive. \ (This procedure is not used especially often,
-so it is not part of \MP's inner loop, but we might as well allow for
-an external C routine.)
-
-@p ifdef('FIXPT')@/
-function make_scaled(@!p,@!q:integer):scaled;
-@z
-@x
- if negative then make_scaled:=-(f+n)@+else make_scaled:=f+n;
- end;
-end;
-@y
- if negative then make_scaled:=-(f+n)@+else make_scaled:=f+n;
- end;
-end;@/
-endif('FIXPT')
-@z
-
-@x [7.134] Do floor_scaled, floor_unscaled, round_unscaled, round_fraction in C.
-@p function floor_scaled(@!x:scaled):scaled;
- {$2^{16}\lfloor x/2^{16}\rfloor$}
-var @!be_careful:integer; {temporary register}
-begin if x>=0 then floor_scaled:=x-(x mod unity)
-else begin be_careful:=x+1;
- floor_scaled:=x+((-be_careful) mod unity)+1-unity;
- end;
-end;
-@#
-function round_unscaled(@!x:scaled):integer;
- {$\lfloor x/2^{16}+.5\rfloor$}
-var @!be_careful:integer; {temporary register}
-begin if x>=half_unit then round_unscaled:=1+((x-half_unit) div unity)
-else if x>=-half_unit then round_unscaled:=0
-else begin be_careful:=x+1;
- round_unscaled:=-(1+((-be_careful-half_unit) div unity));
- end;
-end;
-@#
-function round_fraction(@!x:fraction):scaled;
- {$\lfloor x/2^{12}+.5\rfloor$}
-var @!be_careful:integer; {temporary register}
-begin if x>=2048 then round_fraction:=1+((x-2048) div 4096)
-else if x>=-2048 then round_fraction:=0
-else begin be_careful:=x+1;
- round_fraction:=-(1+((-be_careful-2048) div 4096));
- end;
-end;
-@y
-@z
-
-@x [9.168] Increase memory size.
-@d min_quarterword=0 {smallest allowable value in a |quarterword|}
-@d max_quarterword=255 {largest allowable value in a |quarterword|}
-@d min_halfword==0 {smallest allowable value in a |halfword|}
-@d max_halfword==65535 {largest allowable value in a |halfword|}
-@y
-@d min_quarterword=0 {smallest allowable value in a |quarterword|}
-@d max_quarterword=255 {largest allowable value in a |quarterword|}
-@d min_halfword==0 {smallest allowable value in a |halfword|}
-@d max_halfword==@"FFFFFFF {largest allowable value in a |halfword|}
-@z
-
-@x [9.170] Don't bother to subtract zero.
-@d ho(#)==#-min_halfword
- {to take a sixteen-bit item from a halfword}
-@d qo(#)==#-min_quarterword {to read eight bits from a quarterword}
-@d qi(#)==#+min_quarterword {to store eight bits in a quarterword}
-@y
-@d ho(#)==#
-@d qo(#)==#
-@d qi(#)==#
-@z
-
-@x [9.171] memory_word is defined externally.
-@!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 three_choices of
- 1: (@!int:integer);
- 2: (@!hh:two_halves);
- 3: (@!qqqq:four_quarters);
- end;
-@y
-@=#include "texmfmem.h";@>
-@z
-
-@x [9.174] mem is dynamically allocated.
-@!mem : array[mem_min..mem_max] of memory_word; {the big dynamic storage area}
-@y
-@!mem : ^memory_word; {the big dynamic storage area}
-@z
-
-@x [10.184] Fix an unsigned/signed problem in getnode.
-if r>p+1 then @<Allocate from the top of node |p| and |goto found|@>;
-@y
-if r>intcast(p+1) then @<Allocate from the top of node |p| and |goto found|@>;
-@z
-
-% [11.193] Change the word `free' so that it doesn't conflict with the
-% standard C library routine of the same name. Also change arrays that
-% use mem_max, since that's a variable now, effectively disabling the feature.
-@x
-are debugging.)
-
-@<Glob...@>=
-@!debug @!free: packed array [mem_min..mem_max] of boolean; {free cells}
-@t\hskip1em@>@!was_free: packed array [mem_min..mem_max] of boolean;
-@y
-are debugging.)
-
-@d free==free_arr
-
-@<Glob...@>=
-@!debug @!free: packed array [0..1] of boolean; {free cells}
-@t\hskip1em@>@!was_free: packed array [0..1] of boolean;
-@z
-
-@x [11.197] Eliminate unsigned comparisons to zero.
-repeat if (p>=lo_mem_max)or(p<mem_min) then clobbered:=true
- else if (rlink(p)>=lo_mem_max)or(rlink(p)<mem_min) then clobbered:=true
-@y
-repeat if (p>=lo_mem_max) then clobbered:=true
- else if (rlink(p)>=lo_mem_max) then clobbered:=true
-@z
-
-@x [12.212] Do `fix_date_and_time' in C.
-@ 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@>
-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.
-
-Note that the values are |scaled| integers. Hence \MP\ can no longer
-be used after the year 32767.
-
-@p procedure fix_date_and_time;
-begin internal[time]:=12*60*unity; {minutes since midnight}
-internal[day]:=4*unity; {fourth day of the month}
-internal[month]:=7*unity; {seventh month of the year}
-internal[year]:=1776*unity; {Anno Domini}
-end;
-@y
-@ The following procedure, which is called just before \MP\ initializes its
-input and output, establishes the initial values of the date and time.
-It is calls an externally defined |date_and_time|, even though it could
-be done from Pascal.
-The external procedure also sets up interrupt catching.
-@^system dependencies@>
-
-Note that the values are |scaled| integers. Hence \MP\ can no longer
-be used after the year 32767.
-
-@p procedure fix_date_and_time;
-begin
- date_and_time(internal[time],internal[day],internal[month],internal[year]);
- internal[time] := internal[time] * unity;
- internal[day] := internal[day] * unity;
- internal[month] := internal[month] * unity;
- internal[year] := internal[year] * unity;
-end;
-@z
-
-@x Replace class with c_class to avoid C++ keyword.
-@d max_class=20 {the largest class number}
-@y
-@d max_class=20 {the largest class number}
-@d class==c_class
-@z
-
-@x [12.217] Allow tab and form feed as input.
-for k:=127 to 255 do char_class[k]:=invalid_class;
-@y
-for k:=127 to 255 do char_class[k]:=invalid_class;
-char_class[tab]:=space_class;
-char_class[form_feed]:=space_class;
-@z
-
-@x [18.300,301] l.6451 - Make path_size a configuration option.
-@!delta_x,@!delta_y,@!delta:array[0..path_size] of scaled; {knot differences}
-@!psi:array[1..path_size] of angle; {turning angles}
-
-@ @<Other local variables for |make_choices|@>=
-@!k,@!n:0..path_size; {current and final knot numbers}
-@y
-@!delta_x:^scaled; {knot differences}
-@!delta_y:^scaled; {knot differences}
-@!delta:^scaled; {knot differences}
-@!psi:^angle; {turning angles}
-
-@ @<Other local variables for |make_choices|@>=
-@!k,@!n:0..sup_path_size; {current and final knot numbers}
-@z
-
-@x [18.304] l.6544 - Make path_size a configuration option.
-@!theta:array[0..path_size] of angle; {values of $\theta_k$}
-@!uu:array[0..path_size] of fraction; {values of $u_k$}
-@!vv:array[0..path_size] of angle; {values of $v_k$}
-@!ww:array[0..path_size] of fraction; {values of $w_k$}
-
-@ 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|@>=
-@t\4@>@<Declare subroutines needed by |solve_choices|@>@;
-procedure solve_choices(@!p,@!q:pointer;@!n:halfword);
-label found,exit;
-var @!k:0..path_size; {current knot number}
-@y
-@!theta:^angle; {values of $\theta_k$}
-@!uu:^fraction; {values of $u_k$}
-@!vv:^angle; {values of $v_k$}
-@!ww:^fraction; {values of $w_k$}
-
-@ 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|@>=
-@t\4@>@<Declare subroutines needed by |solve_choices|@>@;
-procedure solve_choices(@!p,@!q:pointer;@!n:halfword);
-label found,exit;
-var @!k:0..sup_path_size; {current knot number}
-@z
-
-@x [27.585] l.11443 - data for file:line:error style.
-@!mpx_name : array[0..max_in_open] of halfword;
-@y
-@!mpx_name : array[0..max_in_open] of halfword;
-@!source_filename_stack : ^str_number;
-@!full_source_filename_stack : ^str_number;
-@z
-
-@x [35.745] area and extension rules.
-@ 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...@>=
-@!area_delimiter:integer;
- {most recent `\.>' or `\.:' relative to |str_start[str_ptr]|}
-@!ext_delimiter:integer; {the relevant `\..', if any}
-@y
-@ The file names we shall deal with have the
-following structure: If the name contains `\./', 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...@>=
-@!area_delimiter:integer; {most recent `\./' relative to |str_start[str_ptr]|}
-@!ext_delimiter:integer; {the relevant `\..', if any}
-@z
-
-@x [35.746] MP and MF area directories.
-@d MP_area=="MPinputs:"
-@.MPinputs@>
-@d MF_area=="MFinputs:"
-@.MFinputs@>
-@d MP_font_area=="TeXfonts:"
-@.TeXfonts@>
-@y
-In C, the default paths are specified separately.
-@z
-
-@x [35.747] filenames: quoted
-area_delimiter:=-1; ext_delimiter:=-1;
-@y
-area_delimiter:=-1; ext_delimiter:=-1; quoted_filename:=false;
-@z
-
-@x [35.748] (more_name) Generalize directory separators.
-begin if c=" " then more_name:=false
-else begin if (c=">")or(c=":") then
-@y
-begin
-if c="""" then begin
- quoted_filename:=not quoted_filename;
- more_name:=true;
- end
-else if ((c=" ")or(c=tab)) and stop_at_space and (not quoted_filename) then
- more_name:=false
-else begin
- if IS_DIR_SEP (c) then
-@z
-@x [still 35.748] Last (not first) . is extension.
- else if (c=".")and(ext_delimiter<0) then
-@y
- else if (c=".") then
-@z
-
-@x [35.749] (end_name) Quote name if necessary.
-procedure end_name;
-var a,@!n,@!e:pool_pointer; {length of area, name, and extension}
-begin e:=pool_ptr-str_start[str_ptr]; {total length}
-@y
-procedure end_name;
-var a,@!n,@!e:pool_pointer; {length of area, name, and extension}
-@!j,@!s,@!t:pool_pointer; {running indices}
-@!must_quote:boolean; {whether we need to quote a string}
-begin str_room(6); {room for quotes}
-if area_delimiter<>-1 then begin
- {maybe quote |cur_area|}
- must_quote:=false;
- s:=str_start[str_ptr];
- t:=str_start[str_ptr]+area_delimiter+1;
- 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<>-1 then ext_delimiter:=ext_delimiter+2;
- area_delimiter:=area_delimiter+2;
- pool_ptr:=pool_ptr+2;
- end;
- s:=str_start[str_ptr]+area_delimiter+1;
- end
-else begin
- s:=str_start[str_ptr];
- end;
-{maybe quote |cur_name|}
-if ext_delimiter=-1 then t:=pool_ptr else t:=str_start[str_ptr]+ext_delimiter;
-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<>-1 then ext_delimiter:=ext_delimiter+2;
- pool_ptr:=pool_ptr+2;
- end;
-if ext_delimiter<>-1 then begin
- {maybe quote |cur_ext|}
- s:=str_start[str_ptr]+ext_delimiter;
- 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;
-e:=pool_ptr-str_start[str_ptr]; {total length}
-@z
-
-@x [35.750] print_file_name
-begin print(a); print(n); 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[a];
- while (not must_quote) and (j<>str_stop(a)) do begin
- must_quote:=str_pool[j]=" "; incr(j);
- end;
-end;
-if n>0 then begin
- j:=str_start[n];
- while (not must_quote) and (j<>str_stop(n)) do begin
- must_quote:=str_pool[j]=" "; incr(j);
- end;
-end;
-if e>0 then begin
- j:=str_start[e];
- while (not must_quote) and (j<>str_stop(e)) do begin
- must_quote:=str_pool[j]=" "; incr(j);
- end;
-end;
-if must_quote then print("""");
-if a>0 then
- for j:=str_start[a] to str_stop(a)-1 do
- if so(str_pool[j])<>"""" then
- print(so(str_pool[j]));
-if n>0 then
- for j:=str_start[n] to str_stop(n)-1 do
- if so(str_pool[j])<>"""" then
- print(so(str_pool[j]));
-if e>0 then
- for j:=str_start[e] to str_stop(e)-1 do
- if so(str_pool[j])<>"""" then
- print(so(str_pool[j]));
-if must_quote then print("""");
-@z
-
-@x [35.751] macro used in pack_file_name
-@d append_to_name(#)==begin c:=#; incr(k);
- if k<=file_name_size then name_of_file[k]:=xchr[c];
- end
-@y
-@d append_to_name(#)==begin c:=#; if not (c="""") then begin incr(k);
- if k<=file_name_size then name_of_file[k]:=xchr[c];
- end end
-@z
-
-@x [35.751] (pack_file_name) malloc and null terminate name_of_file.
-for j:=str_start[a] to str_stop(a)-1 do append_to_name(so(str_pool[j]));
-@y
-if name_of_file then libc_free (name_of_file);
-name_of_file := xmalloc_array (ASCII_code, length(a)+length(n)+length(e)+1);
-for j:=str_start[a] to str_stop(a)-1 do append_to_name(so(str_pool[j]));
-@z
-@x
-for k:=name_length+1 to file_name_size do name_of_file[k]:=' ';
-@y
-name_of_file[name_length + 1] := 0;
-@z
-
-@x [35.752] default mem area is nonexistent
-@d mem_default_length=15 {length of the |MP_mem_default| string}
-@d mem_area_length=6 {length of its area part}
-@y
-@d mem_area_length=0 {no fixed area in C}
-@z
-
-@x [35.753] Where `plain.mem' is.
-@!MP_mem_default:packed array[1..mem_default_length] of char;
-
-@ @<Set init...@>=
-MP_mem_default:='MPlib:plain.mem';
-@.MPlib@>
-@.plain@>
-@^system dependencies@>
-@y
-@!mem_default_length: integer;
-@!MP_mem_default: ^char;
-@!troff_mode:boolean; {has the user requested \.{troff} mode?}
-
-@ We set the name of the default format file and the length of that name
-in \.{texmfmp.c}, since we want them to depend on the name of the
-program.
-@z
-
-@x [35.755] Change to pack_buffered_name as with pack_file_name.
-for j:=1 to n do append_to_name(xord[MP_mem_default[j]]);
-@y
-if name_of_file then libc_free (name_of_file);
-name_of_file := xmalloc_array (ASCII_code, n+(b-a+1)+mem_ext_length+1);
-for j:=1 to n do append_to_name(xord[MP_mem_default[j]]);
-@z
-% @x [35.755] Set program name to match format.
-% for j:=a to b do append_to_name(buffer[j]);
-% @y
-% for j:=a to b do append_to_name(buffer[j]);
-% name_of_file[k+1]:=0;
-% kpse_reset_program_name(name_of_file+1);{set search path to match format}
-% @z
-@x [35.755] Change to pack_buffered_name as with pack_file_name.
-for k:=name_length+1 to file_name_size do name_of_file[k]:=' ';
-@y
-name_of_file[name_length + 1] := 0;
-@z
-
-@x [35.756] Mem file opening: only try once, with path searching.
- pack_buffered_name(0,loc,j-1); {try first without the system file area}
- if w_open_in(mem_file) then goto found;
- pack_buffered_name(mem_area_length,loc,j-1);
- {now try the system mem file area}
- if w_open_in(mem_file) then goto found;
-@y
- pack_buffered_name(0,loc,j-1);
- if w_open_in(mem_file) then goto found;
-@z
-
-@x [still 35.756] Replace `PLAIN' in error messages with `default'.
- wterm_ln('Sorry, I can''t find that mem file;',' will try PLAIN.');
-@y
- wterm ('Sorry, I can''t find the mem file `');
- fputs (stringcast(name_of_file + 1), stdout);
- wterm ('''; will try `');
- fputs (MP_mem_default + 1, stdout);
- wterm_ln ('''.');
-@z
-@x
- wterm_ln('I can''t find the PLAIN mem file!');
-@.I can't find PLAIN...@>
-@y
- wterm ('I can''t find the mem file `');
- fputs (MP_mem_default + 1, stdout);
- wterm_ln ('''!');
-@.I can't find the mem...@>
-@z
-
-@x [35.758] Make scan_file_name ignore leading tabs as well as spaces.
-@p procedure scan_file_name;
-label done;
-begin begin_name;
-while buffer[loc]=" " do incr(loc);
-@y
-@p procedure scan_file_name;
-label done;
-begin begin_name;
-while (buffer[loc]=" ")or(buffer[loc]=tab) do incr(loc);
-@z
-
-@x [35.760] `logname' is declared in <unistd.h> on some systems.
-`\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
-@y
-`\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
-@d log_name == texmf_log_name
-@z
-
-@x [35.763] prompt_file_name: avoid empty filenames.
-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 [35.763] prompt_file_name: avoid empty filenames.
-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 [35.764] <Scan file name...> needs similar leading tab treatment.
-@ @<Scan file name in the buffer@>=
-begin begin_name; k:=first;
-while (buffer[k]=" ")and(k<last) do incr(k);
-@y
-@ @<Scan file name in the buffer@>=
-begin begin_name; k:=first;
-while ((buffer[k]=" ")or(buffer[k]=tab))and(k<last) do incr(k);
-@z
-
-@x [35.765] Adjust for C string conventions.
-@!months:packed array [1..36] of char; {abbreviations of month names}
-@y
-@!months:^char;
-@z
-
-@x [35.765] Change name of recorder file.
-if job_name=0 then job_name:="mpout";
-pack_job_name(".log");
-@y
-if job_name=0 then job_name:=get_job_name("mpout");
-pack_job_name(".fls");
-recorder_change_filename(stringcast(name_of_file+1));
-pack_job_name(".log");
-@z
-
-@x [35.767]
-begin wlog(banner);
-print(mem_ident); print(" ");
-print_int(round_unscaled(internal[day])); print_char(" ");
-months:='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
-@y
-begin wlog(banner);
-wlog (version_string);
-print(mem_ident); print(" ");
-print_int(round_unscaled(internal[day])); print_char(" ");
-months := ' JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
-@z
-
-@x [35.767] l.14341 - Print name of TCX, if given.
-end
-@y
-if translate_filename then begin
- wlog_cr;
- wlog('(');
- fputs(translate_filename, log_file);
- wlog(')');
-end;
-end
-@z
-
-@x [35.768] (try_extension) a_open_in of input file needs path specifier.
-begin pack_file_name(cur_name,cur_area,ext);
-in_name:=cur_name; in_area:=cur_area;
-if a_open_in(cur_file) then try_extension:=true
-else begin if str_vs_str(ext,".mf")=0 then in_area:=MF_area
- else in_area:=MP_area;
- pack_file_name(cur_name,in_area,ext);
- try_extension:=a_open_in(cur_file);
- end;
-@y
-{|cur_ext| will be \.{two} if the filename was \.{one.two}.}
-begin pack_file_name(cur_name,cur_area,cur_ext);
-in_name:=cur_name; in_area:=cur_area;
-{The extension is not relevant for determining whether we're allowed to
- open the file.}
-if not open_in_name_ok(stringcast(name_of_file+1)) then try_extension:=false
-else if str_vs_str(ext,".mf")=0 then
- try_extension:=a_open_in(cur_file, kpse_mf_format)
-else try_extension:=a_open_in(cur_file, kpse_mp_format);
-@z
-
-@x [35.770] We need another loop variable.
-@p procedure start_input; {\MP\ will \.{input} something}
-label done;
-@y
-@p procedure start_input; {\MP\ will \.{input} something}
-label done;
-var j:integer;
-@z
-
-@x [still 35.770] Kpathsea already tries with no extension.
- if cur_ext="" then
- if try_extension(".mp") then goto done
- else if try_extension("") then goto done
- else if try_extension(".mf") then goto done
- else do_nothing
- else if try_extension(cur_ext) then goto done;
-@y
- if try_extension(".mp") then goto done
- else if try_extension(".mf") then goto done
- else do_nothing;
-@z
-
-@x [still 35.770] Allow jobname to be `one.two'.
- begin job_name:=cur_name; str_ref[job_name]:=max_str_ref;
-@y
- begin
- j:=1;
- begin_name;
- stop_at_space:=false;
- while (j<=name_length)and(more_name(name_of_file[j])) do
- incr(j);
- stop_at_space:=true;
- end_name;
- job_name:=get_job_name(cur_name);
- str_ref[job_name] := max_str_ref;
-@z
-
-@x [35.771] Cannot return name to string pool, for the e option?
-flush_string(name); name:=cur_name; cur_name:=0
-@y
-@z
-
-@x [35.774] (copy_old_name) Allocate old_file_name dynamically.
-for j:=str_start[s] to str_stop(s)-1 do
-@y
-if old_file_name then libc_free (old_file_name);
-old_file_name := xmalloc_array (ASCII_code, length(s)+1);
-for j:=str_start[s] to str_stop(s)-1 do
-@z
-@x [still 35.774] Avoid blanking rest of nonexistent array.
-for k:=old_name_length+1 to file_name_size do @+old_file_name[k]:=' ';
-@y
-old_file_name[old_name_length + 1] := 0;
-@z
-
-@x [35.775] Declare old_file_name as a regular C string.
-@!old_file_name : packed array[1..file_name_size] of char;
-@y
-@!old_file_name : ^text_char;
-@z
-
-@x [35.776] [Unique to MP] Path selector for |a_open_in| of mpx file.
-if not a_open_in(cur_file) then
- begin end_file_reading;
-@y
-if not a_open_in(cur_file,no_file_path) then
- begin end_file_reading;
-@z
-
-@x [35.777] [Unique to MP] Invoke |makempx|.
-copy_old_name(name)
-{System-dependent code should be added here}
-@y
-copy_old_name (name);
-if not call_make_mpx (stringcast(old_file_name+1), stringcast(name_of_file+1))
- then goto not_found
-@z
-
-@x [35.778] [Unique to MP] Fix help message for our implementation.
- ("try running it manually through MPtoTeX, TeX, and DVItoMP");
-@y
- ("try running it manually through MPto -tex, TeX, and DVItoMP.");
-@z
-
-@x [35.782] [Unique to MP] Path selector for |a_open_in| of readfrom file.
-if not a_open_in(rd_file[n]) then goto not_found;
-@y
-if not open_in_name_ok(stringcast(name_of_file+1))
- or not a_open_in(rd_file[n],kpse_mp_format) then goto not_found;
-@z
-
-@x [35.783] The Amiga needs a different open_write_file.
-@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
-
-@p procedure open_write_file(s:str_number; n:readf_index);
-begin str_scan_file(s);
-pack_cur_name;
-while not a_open_out(wr_file[n]) do
- prompt_file_name("file name for write output","");
-wr_fname[n]:=s;
-add_str_ref(s);
-end;
-@y
-@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
-The Amiga operating system does not permit write access to a file that is
-currently opened in read mode. To avoid disaster, we look for the file to
-be opened in the list of |read_from| files and close it if present.
-
-@d amiga==ifdef('AMIGA')
-@d agima==endif('AMIGA')
-@f amiga==begin
-@f agima==end
-
-@p procedure open_write_file(s:str_number; n:readf_index);
-amiga@;
-label done;
-var @!n0:readf_index; {Scratch variable}
-agima@;
-begin
- str_scan_file(s);
- pack_cur_name;
-amiga@;
- for n0:=0 to read_files-1 do begin
- if rd_fname[n0]<>0 then begin
- if str_vs_str(s,rd_fname[n0])=0 then begin
- a_close(rd_file[n0]);
- delete_str_ref(rd_fname[n0]);
- rd_fname[n0]:=0;
- if n0=read_files-1 then read_files:=n0;
- goto done;
- end;
- end;
- end;
-done: do_nothing;
-agima@;
-while not open_out_name_ok(stringcast(name_of_file+1))
- or not a_open_out(wr_file[n]) do
- prompt_file_name("file name for write output","");
-wr_fname[n]:=s;
-add_str_ref(s);
-{If on first line of input, log file is not ready yet, so don't log.}
-if log_opened then begin
- old_setting:=selector;
- if (internal[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.}
- print_nl("write");
- print_int(n);
- print(" = `");
- print_file_name(cur_name,cur_area,cur_ext);
- print("'."); print_nl(""); print_ln;
- selector:=old_setting;
-end;
-end;
-@z
-
-@x [41.1040] if batchmode, MakeTeX... scripts should be silent.
-mode_command: begin print_ln; interaction:=cur_mod;
-@y
-mode_command: begin print_ln; interaction:=cur_mod;
-if interaction = batch_mode
-then kpse_make_tex_discard_errors := 1
-else kpse_make_tex_discard_errors := 0;
-@z
-
-@x [42.1151] Fix `threshold' conflict with local variable name.
-@p function threshold(@!m:integer):scaled;
-var @!d:scaled; {lower bound on the smallest interval size}
-begin excess:=min_cover(0)-m;
-if excess<=0 then threshold:=0
-else begin repeat d:=perturbation;
- until min_cover(d+d)<=m;
- while min_cover(d)>m do d:=perturbation;
- threshold:=d;
- end;
-end;
-@y
-@p function compute_threshold(@!m:integer):scaled;
-var @!d:scaled; {lower bound on the smallest interval size}
-begin excess:=min_cover(0)-m;
-if excess<=0 then compute_threshold:=0
-else begin repeat d:=perturbation;
- until min_cover(d+d)<=m;
- while min_cover(d)>m do d:=perturbation;
- compute_threshold:=d;
- end;
-end;
-@z
-
-@x [42.1152] Change the call to the threshold function.
-begin d:=threshold(m); perturbation:=0;
-@y
-begin d:=compute_threshold(m); perturbation:=0;
-@z
-
-@x [45.1164] Writing the tfm file.
-@d tfm_out(#)==write(tfm_file,#) {output one byte to |tfm_file|}
-
-@p procedure tfm_two(@!x:integer); {output two bytes to |tfm_file|}
-begin tfm_out(x div 256); tfm_out(x mod 256);
-end;
-@#
-procedure tfm_four(@!x:integer); {output four bytes to |tfm_file|}
-begin if x>=0 then tfm_out(x div three_bytes)
-else begin x:=x+@'10000000000; {use two's complement for negative values}
- x:=x+@'10000000000;
- tfm_out((x div three_bytes) + 128);
- end;
-x:=x mod three_bytes; tfm_out(x div unity);
-x:=x mod unity; tfm_out(x div @'400);
-tfm_out(x mod @'400);
-end;
-@#
-procedure tfm_qqqq(@!x:four_quarters); {output four quarterwords to |tfm_file|}
-@y
-The default definitions don't work. Why not? So use C macros.
-
-@d tfm_out(#) == put_byte (#, tfm_file)
-@d tfm_two(#) == put_2_bytes (tfm_file, #)
-@d tfm_four(#) == put_4_bytes (tfm_file, #)
-
-@p procedure tfm_qqqq(@!x:four_quarters); {output four quarterwords to |tfm_file|}
-@z
-
-@x [42.1165] print_file_name
-print_nl("Font metrics written on "); print(metric_file_name); print_char(".");
-@y
-print_nl("Font metrics written on ");
-print_file_name(0,metric_file_name,0);
-print_char(".");
-@z
-
-% [43.1182] [See TeX module 564] Reading tfm files. As a special case,
-% whenever we open a tfm file for input, we read its first byte into
-% "tfm_temp" right away.
-@x
-@d tfget==get(tfm_infile)
-@d tfbyte==tfm_infile^
-@y
-@d tfget==tfm_temp:=getc(tfm_infile)
-@d tfbyte==tfm_temp
-@z
-
-% [43.1186] [See TeX module 575] We only want `eof' on the TFM file
-% to be true if we previously had EOF, not if we're at EOF now.
-% This is like `feof', and unlike our implementation of `eof' elsewhere.
-@x
-if eof(tfm_infile) then goto bad_tfm;
-@y
-if feof(tfm_infile) then goto bad_tfm;
-@z
-
-% [43.1188] [See TeX module 563] TFM file opening.
-@x
-if cur_area="" then cur_area:=MP_font_area;
-if cur_ext="" then cur_ext:=".tfm";
-pack_cur_name;
-@y
-if cur_ext="" then cur_ext:=".tfm";
-pack_cur_name;
-@z
-
-@x [43.1195] [Unique to MP] Path selector for |a_open_in| of ps_tab_file.
-begin name_of_file:=ps_tab_name;
-if a_open_in(ps_tab_file) then
-@y
-begin
-name_length := strlen (ps_tab_name);
-name_of_file := xmalloc_array (ASCII_code, name_length+1);
-strcpy (stringcast(name_of_file+1), ps_tab_name); {copy the string}
-if a_open_in(ps_tab_file, kpse_fontmap_format) then
-@z
-
-@x [43.1198] Allow blank lines and comment lines in |ps_tab_file|.
-@ @<Read at most |lmax| characters from |ps_tab_file| into string |s|...@>=
-str_room(lmax);
-j:=lmax;
-loop @+begin if eoln(ps_tab_file) then
- fatal_error("The psfont map file is bad!");
- read(ps_tab_file,c);
- if c=' ' then goto done;
-@y
-@ If we encounter the end of line before we have started reading
-characters from |ps_tab_file|, we have found an entirely blank
-line and we skip over it. Otherwise, we abort if the line ends
-prematurely. If we encounter a comment character, we also skip
-over the line, since recent versions of \.{dvips} allow comments
-in the font map file.
-
-@<Read at most |lmax| characters from |ps_tab_file| into string |s|...@>=
-str_room(lmax);
-j:=lmax;
-loop @+begin if eoln(ps_tab_file) then
- if j=lmax then begin flush_cur_string;
- goto common_ending; {skip over blank line}
- end
- else fatal_error("The psfonts.map file is bad!");
- read(ps_tab_file,c);
- if ((c='%')or(c='*')or(c=';')or(c='#')) then begin flush_cur_string;
- goto common_ending; {skip over comment line}
- end;
- if ((c=' ')or(c=tab)) then goto done;
-@z
-
-@x [43.1199] Allow tabs as field seperators in |ps_tab_file|.
-repeat if eoln(ps_tab_file) then fatal_error("The psfont map file is bad!");
- read(ps_tab_file,c);
-until c<>' ';
-repeat decr(j);
- if j<0 then fatal_error("The psfont map file is bad!");
- append_char(xord[c]);
- if eoln(ps_tab_file) then c:=' ' @+else read(ps_tab_file,c);
-until c=' ';
-@y
-repeat if eoln(ps_tab_file) then fatal_error("The psfonts.map file is bad!");
- read(ps_tab_file,c);
-until ((c<>' ')and(c<>tab));
-repeat decr(j);
- if j<0 then fatal_error("The psfonts.map file is bad!");
- append_char(xord[c]);
- if eoln(ps_tab_file) then c:=' ' @+else read(ps_tab_file,c);
-until ((c=' ')or(c=tab));
-@z
-
-@x [44.1208] l.21341 - i18n fix
- print(" output file");
- if total_shipped>1 then print_char("s");
-@y
- print(" output ");
- if total_shipped>1 then print("files")
- else print("file");
-@z
-
-@x [44.1208] print_file_name
- print(first_file_name);
-@y
- print_file_name(0,first_file_name,0);
-@z
-@x [44.1208 print_file_name
- print(last_file_name);
-@y
- print_file_name(0,last_file_name,0);
-@z
-
-@x [45.1279] INI = VIR.
-mem_ident:=" (INIMP)";
-@y
-if ini_version then mem_ident:=" (INIMP)";
-@z
-
-@x [45.1280] Add base_engine.
-@!w: four_quarters; {four ASCII codes}
-@y
-@!w: four_quarters; {four ASCII codes}
-@!base_engine: ^text_char;
-@z
-
-@x [45.1281] Add base_engine.
-@!w: four_quarters; {four ASCII codes}
-@y
-@!w: four_quarters; {four ASCII codes}
-@!base_engine: ^text_char;
-@!dummy_xord: ASCII_code;
-@!dummy_xchr: text_char;
-@!dummy_xprn: ASCII_code;
-@z
-
-@x [45.1282] Reading and writing of `mem_file' done in C.
-@d dump_wd(#)==begin mem_file^:=#; put(mem_file);@+end
-@d dump_int(#)==begin mem_file^.int:=#; put(mem_file);@+end
-@d dump_hh(#)==begin mem_file^.hh:=#; put(mem_file);@+end
-@d dump_qqqq(#)==begin mem_file^.qqqq:=#; put(mem_file);@+end
-@y
-@z
-
-@x [45.1283]
-@d undump_wd(#)==begin get(mem_file); #:=mem_file^;@+end
-@d undump_int(#)==begin get(mem_file); #:=mem_file^.int;@+end
-@d undump_hh(#)==begin get(mem_file); #:=mem_file^.hh;@+end
-@d undump_qqqq(#)==begin get(mem_file); #:=mem_file^.qqqq;@+end
-@y
-@z
-
-@x [45.1284]
-dump_int(@$);@/
-@y
-dump_int(@"57324D50); {Web2C \MP's magic constant: "W2MP"}
-{Align engine to 4 bytes with one or more trailing NUL}
-x:=strlen(engine_name);
-base_engine:=xmalloc_array(text_char,x+4);
-strcpy(stringcast(base_engine), engine_name);
-for k:=x to x+3 do base_engine[k]:=0;
-x:=x+4-(x mod 4);
-dump_int(x);dump_things(base_engine[0], x);
-libc_free(base_engine);@/
-dump_int(@$);@/
-dump_int(main_memory);@/
-@<Dump |xord|, |xchr|, and |xprn|@>;
-@z
-
-@x [45.1285] Avoid Pascal file convention.
-x:=mem_file^.int;
-if x<>@$ then goto off_base; {check that strings are the same}
-undump_int(x);
-if x<>mem_min then goto off_base;
-undump_int(x);
-if x<>mem_top then goto off_base;
-@y
-undump_int(x);
-if x<>@"57324D50 then goto off_base; {not a base file}
-undump_int(x);
-if (x<0) or (x>256) then goto off_base; {corrupted base file}
-base_engine:=xmalloc_array(text_char, x);
-undump_things(base_engine[0], x);
-base_engine[x-1]:=0; {force string termination, just in case}
-if strcmp(engine_name, stringcast(base_engine)) then
- begin wake_up_terminal;
- wterm_ln('---! ', stringcast(name_of_file+1), ' was written by ', base_engine);
- libc_free(base_engine);
- goto off_base;
-end;
-libc_free(base_engine);
-undump_int(x);
-if x<>@$ then begin {check that strings are the same}
- wake_up_terminal;
- wterm_ln('---! ', stringcast(name_of_file+1), ' doesn''t match pool strings');
- goto off_base;
-end;
-undump_int(x);
-if x<>main_memory then goto off_base;
-@<Undump |xord|, |xchr|, and |xprn|@>;
-undump_int(x);
-if x<>mem_min then goto off_base;
-{Dynamic allocation \`a la \.{mf.ch}.}
-@+init
-if ini_version then begin
- {We allocated these at start-up, but now we need to reallocate.}
- libc_free (mem);
- libc_free (str_ref);
- libc_free (next_str);
- libc_free (str_start);
- libc_free (str_pool);
-end;
-@+tini
-undump_int(mem_top);
-if mem_max < mem_top then mem_max:=mem_top; {Use at least what we dumped.}
-if mem_min+1100>mem_top then goto off_base;
-mem_max := mem_top + extra_mem_top;
-mem:=xmalloc_array (memory_word, mem_max - mem_min + 1);
-@z
-
-@x [45.1287] String pool undumping is dynamic.
-undump_size(0)(pool_size)('string pool size')(pool_ptr);
-undump_size(0)(max_strings-1)('max strings')(max_str_ptr);
-@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)('max strings')(max_str_ptr);
-@/
-str_ref:=xmalloc_array (str_ref_type, max_strings);
-next_str:=xmalloc_array (str_number, max_strings);
-str_start:=xmalloc_array (pool_pointer, max_strings);
-str_pool:=xmalloc_array (pool_ASCII_code, pool_size);
-@z
-
-@x [45.1293] l.22667 - Allow command line to override dumped value.
-undump(batch_mode)(error_stop_mode)(interaction);
-@y
-undump(batch_mode)(error_stop_mode)(interaction);
-if interaction_option<>unspecified_mode then interaction:=interaction_option;
-@z
-
-@x [45.1293] eof is like feof here.
-undump_int(x);@+if (x<>69073)or eof(mem_file) then goto off_base
-@y
-undump_int(x);@+if (x<>69073)or feof(mem_file) then goto off_base
-@z
-
-@x [45.1294] Eliminate probably-wrong word `preloaded' from mem_idents.
-print(" (preloaded mem="); print(job_name); print_char(" ");
-print_int(round_unscaled(internal[year]) mod 100); print_char(".");
-@y
-print(" (mem="); print(job_name); print_char(" ");
-print_int(round_unscaled(internal[year])); print_char(".");
-@z
-
-@x [46.1298] Dynamic allocation.
-@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 \.{tex.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(#) ==
- setup_bound_variable (address_of (#), bound_name, bound_default);
-
-@p begin @!{|start_here|}
- {See comments in \.{tex.ch} for why the name has to be duplicated.}
- setup_bound_var (250000)('main_memory')(main_memory);
- {|memory_word|s for |mem| in \.{INIMP}}
- setup_bound_var (0)('extra_mem_top')(extra_mem_top);
- {increase high mem in \.{VIRMP}}
- setup_bound_var (100000)('pool_size')(pool_size);
- setup_bound_var (75000)('string_vacancies')(string_vacancies);
- setup_bound_var (3000)('buf_size')(buf_size);
- setup_bound_var (2000)('path_size')(path_size);
- setup_bound_var (5000)('pool_free')(pool_free); {min pool avail after fmt}
- setup_bound_var (15000)('max_strings')(max_strings);
- 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);
- if error_line > ssup_error_line then error_line := ssup_error_line;
-
- const_chk (main_memory);
-@+init
- if ini_version then
- extra_mem_top := 0;
-@+tini
- if extra_mem_top>sup_main_memory then extra_mem_top:=sup_main_memory;
- mem_top := mem_min + main_memory - 1;
- mem_max := mem_top;
-
- const_chk (pool_size);
- const_chk (string_vacancies);
- const_chk (buf_size);
- const_chk (path_size);
- const_chk (pool_free);
- const_chk (max_strings);
-
- buffer:=xmalloc_array (ASCII_code, buf_size);
- delta_x:=xmalloc_array (scaled, path_size);
- delta_y:=xmalloc_array (scaled, path_size);
- delta:=xmalloc_array (scaled, path_size);
- psi:=xmalloc_array (angle, path_size);
- theta:=xmalloc_array (angle, path_size);
- uu:=xmalloc_array (fraction, path_size);
- vv:=xmalloc_array (angle, path_size);
- ww:=xmalloc_array (fraction, path_size);
- source_filename_stack:=xmalloc_array (str_number, max_in_open);
- full_source_filename_stack:=xmalloc_array (str_number, max_in_open);
-
-@+init
-if ini_version then begin
- mem:=xmalloc_array (memory_word, mem_top - mem_min + 1);
-
- str_ref:=xmalloc_array (str_ref_type, max_strings);
- next_str:=xmalloc_array (str_number, max_strings);
- str_start:=xmalloc_array (pool_pointer, max_strings);
- str_pool:=xmalloc_array (pool_ASCII_code, pool_size);
-end;
-@+tini
-@z
-
-@x [46.1298] Only do get_strings_started etc. if ini.
-@!init if not get_strings_started then goto final_end;
-init_tab; {initialize the tables}
-init_prim; {call |primitive| for each primitive}
-init_str_use:=str_ptr; init_pool_ptr:=pool_ptr;@/
-max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr;
-fix_date_and_time;
-@y
-@!init if ini_version then begin
-if not get_strings_started then goto final_end;
-init_tab; {initialize the tables}
-init_prim; {call |primitive| for each primitive}
-init_str_use:=str_ptr; init_pool_ptr:=pool_ptr;@/
-max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr;
-fix_date_and_time;
-end;
-@z
-
-@x [46.1298] Set internal[prologues] in troff mode.
-history:=spotless; {ready to go!}
-@y
-history:=spotless; {ready to go!}
-if troff_mode then begin
- internal[gtroffmode]:=unity;
- internal[prologues]:=unity;
-end;
-@z
-
-@x [46.1298] Call do_final_end.
-end_of_MP: close_files_and_terminate;
-final_end: ready_already:=0;
-@y
-close_files_and_terminate;
-final_end: do_final_end;
-@z
-
-@x [46.1299] Print new line before termination; maybe switch to editor.
- print(log_name); print_char(".");
- end;
- end;
-@y
- print_file_name(0,log_name,0); print_char(".");
- end;
- end;
-print_ln;
-if (edit_name_start<>0) and (interaction>batch_mode) then
- call_edit(str_pool,edit_name_start,edit_name_length,edit_line);
-@z
-
-@x [46.1304] (final_cleanup) Only do dump if ini.
- begin @!init store_mem_file; return;@+tini@/
-@y
- begin @!init if ini_version then begin store_mem_file; return;end;@+tini@/
-@z
-
-@x [46.1306] l.22937 - Handle %&mem line
-if (mem_ident=0)or(buffer[loc]="&") then
-@y
-if (mem_ident=0)or(buffer[loc]="&")or dump_line then
-@z
-
-@x [46.1307] l.23004
-sys_random_seed := (internal[time] div unity)+internal[day];@/
-@y
-sys_random_seed := get_random_seed;@/
-@z
-
-@x [47.1307] Change read of integer.
- 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);
-@y
- m:=input_int (stdin);
- 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 n:=input_int (stdin);
-@z
-
-@x [47.1308]
-13: begin read(term_in,l); print_cmd_mod(n,l);
-@y
-13: begin l:=input_int (stdin); print_cmd_mod(n,l);
-@z
-
-@x [48.1309] Add editor-switch variable to globals.
-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@>
-@y
-Here are the variables used to hold ``switch-to-editor'' information.
-@^system dependencies@>
-
-@<Global...@>=
-@!edit_name_start: pool_pointer;
-@!edit_name_length,@!edit_line: integer;
-@!xprn: array[ASCII_code] of ASCII_code; {use \.{\^\^} notation?}
-@!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 \MP\ is supposed to switch to an editor on exit.
-
-@<Set init...@>=
-edit_name_start:=0;
-stop_at_space:=true;
-
-@ Dumping the |xord|, |xchr|, and |xprn| arrays. We dump these always
-in the format, so a TCX file loaded during format creation can set a
-default for users of the format.
-
-@<Dump |xord|, |xchr|, and |xprn|@>=
-dump_things(xord[0], 256);
-dump_things(xchr[0], 256);
-dump_things(xprn[0], 256);
-
-@ Undumping the |xord|, |xchr|, and |xprn| arrays. This code is more
-complicated, because we want to ensure that a TCX file specified on
-the command line will override whatever is in the format. Since the
-tcx file has already been loaded, that implies throwing away the data
-in the format. Also, if no |translate_filename| is given, but
-|eight_bit_p| is set we have to make all characters printable.
-
-@<Undump |xord|, |xchr|, and |xprn|@>=
-if translate_filename then begin
- for k:=0 to 255 do undump_things(dummy_xord, 1);
- for k:=0 to 255 do undump_things(dummy_xchr, 1);
- for k:=0 to 255 do undump_things(dummy_xprn, 1);
- end
-else begin
- undump_things(xord[0], 256);
- undump_things(xchr[0], 256);
- undump_things(xprn[0], 256);
- if eight_bit_p then
- for k:=0 to 255 do
- xprn[k]:=1;
-end;
-
-@ Web2c is deficient, and can only translate pointers to a type
-identifier, not a general type. Easier, if more annoying, to introduce
-this extra definition than to fix Web2c.
-
-@<Types...@> =
-@!str_ref_type = 0..max_str_ref;
-@z
diff --git a/Build/source/texk/web2c/mp.web b/Build/source/texk/web2c/mp.web
deleted file mode 100644
index 4b3f0491313..00000000000
--- a/Build/source/texk/web2c/mp.web
+++ /dev/null
@@ -1,24680 +0,0 @@
-% $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){} % 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{MetaPost}
-\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}
-\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 \MP, a graphics-language processor based on D. E. Knuth's \MF.
-The \PASCAL\ program that follows defines a standard version
-@:PASCAL}{\PASCAL@>
-of \MP\ 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 \MP\
-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 \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.005' {printed when \MP\ starts}
-@d metapost_version=="1.005"
-
-@ Different \PASCAL s have slightly different conventions, and the present
-@!@:PASCAL H}{\ph@>
-program is expressed in a version of \PASCAL\ that D. E. Knuth used for \MF.
-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 \MP\ program below is intended to be adaptable, without
-extensive changes, to most other versions of \PASCAL\ and commonly used
-\PASCAL-to-C translators, so it does not fully
-@!@:C@>
-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;
-there are no tag fields on variant records; there are no |real| variables;
-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@>
-
-@ 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 \MP\ user
-to specify a file name if |output| were specified here.
-@:PASCAL H}{\ph@>
-@^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 MP; {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 @<Set initial values of key variables@>@/
- end;@#
-@t\4@>@<Basic printing procedures@>@/
-@t\4@>@<Error handling procedures@>@/
-
-@ 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.
-
-@ Three labels must be declared in the main program, so we give them
-symbolic names.
-
-@d start_of_MP=1 {go here when \MP's variables are initialized}
-@d end_of_MP=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_MP@t\hskip-2pt@>, end_of_MP@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 \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 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 \MP's memory usage.
-@^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 \.{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.
-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
-
-@ 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 \MP\ 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.
-@:PASCAL H}{\ph@>
-@^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 \MP\ 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 \MP\ 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!)
-@:PASCAL H}{\ph@>
-
-@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 \MP's capacity. They may have different values in \.{INIMP} and
-in production versions of \MP.
-@.INIMP@>
-@^system dependencies@>
-
-@<Constants...@>=
-@!mem_max=30000; {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|}
-@!max_internal=100; {maximum number of internal quantities}
-@!buf_size=500; {maximum number of characters simultaneously present in
- current lines of open files; 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}
-@!emergency_line_length=255;
- {\ps\ output lines can be this long in unusual circumstances}
-@!stack_size=30; {maximum number of simultaneous input sources}
-@!max_read_files=4; {maximum number of simultaneously open \&{readfrom} files}
-@!max_strings=2500; {maximum number of strings; must not exceed |max_halfword|}
-@!string_vacancies=9000; {the minimum number of characters that should be
- available for the user's identifier names and strings,
- after \MP's own error messages are stored}
-@!strings_vacant=1000; {the minimum number of strings that should be available}
-@!pool_size=32000; {maximum number of characters in strings, including all
- error messages and help texts, and the names of all identifiers;
- must exceed |string_vacancies| by the total
- length of \MP's own strings, which is currently about 22000}
-@!font_max=50; {maximum font number for included text fonts}
-@!font_mem_size=10000; {number of words for \.{TFM} information for text fonts}
-@!file_name_size=40; {file names shouldn't be longer than this}
-@!pool_name='MPlib:MP.POOL ';
- {string of length |file_name_size|; tells where the string pool appears}
-@.MPlib@>
-@!ps_tab_name='MPlib:PSFONTS.MAP ';
- {string of length |file_name_size|; locates font name translation table}
-@!path_size=300; {maximum number of knots between breakpoints of a path}
-@!bistack_size=785; {size of stack for bisection algorithms;
- should probably be left at this value}
-@!header_size=100; {maximum number of \.{TFM} header words, times~4}
-@!lig_table_size=5000; {maximum number of ligature/kern steps, must be
- at least 255 and at most 32510}
-@!max_kerns=500; {maximum number of distinct kern amounts}
-@!max_font_dimen=50; {maximum number of \&{fontdimen} parameters}
-
-@ 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. They are defined here using
-\.{WEB} macros, instead of being put into \PASCAL's |const| list, in order to
-emphasize this distinction.
-
-@d mem_min=0 {smallest index in the |mem| array, must not be less
- than |min_halfword|}
-@d mem_top==30000 {largest index in the |mem| array dumped by \.{INIMP};
- must be substantially larger than |mem_min|
- and not greater than |mem_max|}
-@d hash_size=2100 {maximum number of symbolic tokens,
- must be less than |max_halfword-3*param_size|}
-@d hash_prime=1777 {a prime number equal to about 85\pct! of |hash_size|}
-@d max_in_open=6 {maximum number of input files and error insertions that
- can be going on simultaneously}
-@d param_size=150 {maximum number of simultaneous macro parameters}
-@d max_write_files=4 {maximum number of simultaneously open \&{write} files}
-@^system dependencies@>
-
-@ 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...@>=
-@!bad:integer; {is some ``constant'' wrong?}
-
-@ Later on we will say `\ignorespaces|if mem_max>=max_halfword then bad:=10|',
-or something similar. (We can't do that until |max_halfword| has been defined.)
-
-@<Check the ``constant'' values for consistency@>=
-bad:=0;
-if (half_error_line<30)or(half_error_line>error_line-15) then bad:=1;
-if max_print_line<60 then bad:=2;
-if emergency_line_length<max_print_line then bad:=3;
-if mem_min+1100>mem_top then bad:=4;
-if hash_prime>hash_size then bad:=5;
-if header_size mod 4 <> 0 then bad:=6;
-if(lig_table_size<255)or(lig_table_size>32510)then bad:=7;
-
-@ 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 found3=43 {like |found|, when there's more than three per routine}
-@d not_found=45 {go here when you've found nothing}
-@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 double(#) == #:=#+# {multiply a variable by two}
-@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 == {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...@>=
-@!ASCII_code=0..255; {eight-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 font design;
-so the present specification of \MP\ 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 \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.
-
-@<Glob...@>=
-@!xord: array [text_char] of ASCII_code;
- {specifies conversion of input characters}
-@!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 \MP\ 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]:='~';@/
-
-@ 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. If \MP\ 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 \MP\ more friendly on
-computers that have an extended character set, so that users can type things
-like `\.^^Z' instead of `\.{<>}'.
-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 init...@>=
-for i:=0 to @'37 do xchr[i]:=' ';
-for i:=@'177 to @'377 do xchr[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...@>=
-for i:=first_text_char to last_text_char do xord[chr(i)]:=@'177;
-for i:=@'200 to @'377 do xord[xchr[i]]:=i;
-for i:=0 to @'176 do 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.
-
-\MP\ 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 mem 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..255; {unsigned one-byte quantity}
-@!alpha_file=packed file of text_char; {files that contain textual data}
-@!byte_file=packed file of 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
-\MP; some sort of extension to \PASCAL's ordinary |reset| and |rewrite|
-is crucial for our purposes. We shall assume that |name_of_file| is a variable
-of an appropriate type such that the \PASCAL\ run-time system being used to
-implement \MP\ can open a file whose external name is specified by
-|name_of_file|.
-@^system dependencies@>
-
-@<Glob...@>=
-@!name_of_file:packed array[1..file_name_size] of char;@;@/
- {on some systems this may be a \&{record} variable}
-@!name_length:0..file_name_size;@/{this many characters are actually
- relevant in |name_of_file| (the rest are blank)}
-
-@ The \ph\ compiler with which the original version of \MF\ was prepared
-extends 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 `\ignorespaces|packed
-array[@t\<\\{any}>@>] of text_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
-\MP\ to undertake appropriate corrective action.
-@:PASCAL H}{\ph@>
-@^system dependencies@>
-
-\MP's file-opening procedures return |false| if no file identified by
-|name_of_file| 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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/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,name_of_file,'/O'); w_open_out:=rewrite_OK(f);
-end;
-
-@ Files can be closed with the \ph\ routine `|close(f)|', which
-@:PASCAL H}{\ph@>
-@^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.
-
-@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;
-
-@ 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.
-\MP'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
-|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 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 |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@>
-
-An overflow error is given, however, if the normal actions of |input_ln|
-would make |last>=buf_size|; this is done so that other parts of \MP\
-can safely look at the contents of |buffer[last+1]| without overstepping
-the bounds of the |buffer| array. Upon entry to |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 |input_ln|.
-
-If the |bypass_eoln| parameter is |true|, |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 \MP\ 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).
-
-@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]:=xord[f^]; get(f); incr(last);
- if buffer[last-1]<>" " then last_nonblank:=last;
- end;
- last:=last_nonblank; input_ln:=true;
- 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|.
-@:PASCAL H}{\ph@>
-@^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:
-@:PASCAL H}{\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 \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 if we are lucky enough to have an operating
-system that treats \MP\ differently from a run-of-the-mill \PASCAL\ object
-program. 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.
-
-The first line is special also because it may be read before \MP\ has
-input a mem file. In such cases, normal error messages cannot yet
-be given. The following code uses concepts that will be explained later.
-
-@<Report overflow of the input buffer, and abort@>=
-if mem_ident=0 then
- begin write_ln(term_out,'Buffer size exceeded!'); goto final_end;
-@.Buffer size exceeded@>
- end
-else begin cur_input.loc_field:=first; cur_input.limit_field:=last-1;
- overflow("buffer size",buf_size);
-@:MetaPost capacity exceeded buffer size}{\quad buffer size@>
- end
-
-@ 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==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 write_ln(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;
- write_ln(term_out,'Please type the name of your input file.');
- end;
-exit:end;
-
-@* \[4] String handling.
-Symbolic token names and diagnostic messages are variable-length strings
-of eight-bit characters. Since \PASCAL\ does not have a well-developed string
-mechanism, \MP\ does all of its string processing by homegrown methods.
-
-\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.
-
-Elements of the |str_pool| array must be ASCII codes that can actually be
-printed; i.e., they must have an |xchr| equivalent in the local
-character set. (This restriction applies only to preloaded strings,
-not to those generated dynamically by the user.)
-
-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 via macros that can easily be redefined.
-When accessing character dimensions for the \&{infont} operator, an explicit
-offset is used to convert from |pool_ASCII_code| to |ASCII_code|.
-@^system dependencies@>
-
-@d si(#) == # {convert from |ASCII_code| to |pool_ASCII_code|}
-@d so(#) == # {convert from |pool_ASCII_code| to |ASCII_code|}
-@d min_pool_ASCII=0 {added to an |ASCII_code| to make a |pool_ASCII_code|}
-
-@<Types...@>=
-@!pool_pointer = 0..pool_size; {for variables that point into |str_pool|}
-@!str_number = 0..max_strings; {for variables that point into |str_start|}
-@!pool_ASCII_code = 0..255; {elements of |str_pool| array}
-
-@ @<Glob...@>=
-@!str_pool:packed array[pool_pointer] of pool_ASCII_code; {the characters}
-@!str_start : array[str_number] of pool_pointer; {the starting pointers}
-@!next_str : array[str_number] of str_number; {for linking strings in order}
-@!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_use : str_number; {the initial number of strings in use}
-@!max_pool_ptr : pool_pointer; {the maximum so far of |pool_ptr|}
-@!max_str_ptr : str_number; {the maximum so far of |str_ptr|}
-
-@ Except for |strs_used_up|, the following string statistics are only
-maintained when code between |stat| $\ldots$ |tats| delimiters is not
-commented out:
-
-@<Glob...@>=
-@!strs_used_up:integer; {strings in use or unused but not reclaimed}
-@!pool_in_use:integer; {total number of cells of |str_pool| actually in use}
-@!strs_in_use:integer; {total number of strings actually in use}
-@!max_pl_used:integer; {maximum |pool_in_use| so far}
-@!max_strs_used:integer; {maximum |strs_in_use| so far}
-
-@ 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 str_stop(#)==str_start[next_str[#]] {one cell past the end of string
- number \#}
-@d length(#)==(str_stop(#)-str_start[#]) {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 == (pool_ptr - str_start[str_ptr])
-@d flush_cur_string == pool_ptr:=str_start[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(#) == {put |ASCII_code| \# at the end of |str_pool|}
-begin str_pool[pool_ptr]:=si(#); incr(pool_ptr);
-end
-@d str_room(#) == {make sure that the pool hasn't overflowed}
- begin if pool_ptr+# > max_pool_ptr then
- if pool_ptr+# > pool_size then do_compaction(#)
- else max_pool_ptr:=pool_ptr+#;
- end
-
-@ The following routine is similar to |str_room(1)| but it uses the
-argument |pool_size| to prevent |do_compaction| from aborting when
-string space is exhausted.
-
-@<Declare the procedure called |unit_str_room|@>=
-procedure unit_str_room;
-begin if pool_ptr>=pool_size then do_compaction(pool_size);
-if pool_ptr>=max_pool_ptr then max_pool_ptr:=pool_ptr+1;
-end;
-
-@ \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(#)==begin if str_ref[#]<max_str_ref then incr(str_ref[#]);
- end
-
-@<Glob...@>=
-@!str_ref:array[str_number] of 0..max_str_ref;
-
-@ Here's what we do when a string reference disappears:
-
-@d delete_str_ref(#)== begin if str_ref[#]<max_str_ref then
- if str_ref[#]>1 then decr(str_ref[#])@+else flush_string(#);
- end
-
-@<Declare the procedure called |flush_string|@>=
-procedure flush_string(@!s:str_number);
-begin stat pool_in_use:=pool_in_use-length(s);
- decr(strs_in_use);
- tats@;
-if next_str[s]<>str_ptr then str_ref[s]:=0
-else begin str_ptr:=s;
- decr(strs_used_up);
- end;
-pool_ptr:=str_start[str_ptr];
-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.
-
-When getting the next unused string number from the linked list, we pretend
-that
-$$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |max_strings|} $$
-are linked sequentially even though the |next_str| entries have not been
-initialized yet. We never allow |str_ptr| to reach |max_strings|;
-|do_compaction| is responsible for making sure of this.
-
-@p @t\4@>@<Declare the procedure called |do_compaction|@>@;
-@t\4@>@<Declare the procedure called |unit_str_room|@>@;
-function make_string : str_number; {current string enters the pool}
-label restart;
-var @!s:str_number; {the new string}
-begin restart: s:=str_ptr;
-str_ptr:=next_str[s];
-if str_ptr>max_str_ptr then
- if str_ptr=max_strings then
- begin str_ptr:=s;
- do_compaction(0);
- goto restart;
- end
- else begin debug if strs_used_up<>max_str_ptr then confusion("s");@+gubed@/
-@:this can't happen s}{\quad \.s@>
- max_str_ptr:=str_ptr;
- next_str[str_ptr]:=max_str_ptr+1;
- end;
-str_ref[s]:=1;
-str_start[str_ptr]:=pool_ptr;
-incr(strs_used_up);
-stat incr(strs_in_use);
- pool_in_use:=pool_in_use+length(s);
- if pool_in_use>max_pl_used then max_pl_used:=pool_in_use;
- if strs_in_use>max_strs_used then max_strs_used:=strs_in_use;
-tats@;
-make_string:=s;
-end;
-
-@ On rare occasions, we might decide after calling |make_string| that some
-characters should be removed from the end of the last string and transferred
-to the beginning of a string under construction. This basically a matter of
-resetting |str_start[str_ptr]|. It is not practical to ensure that the new
-value for this pointer is in range, so this procedure should be used carefully.
-
-@p procedure chop_last_string(@!p:pool_pointer);
-begin stat pool_in_use:=pool_in_use-(str_start[str_ptr]-p); @+tats;
-str_start[str_ptr]:=p;
-end;
-
-@ 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=pool_size|. Calling |do_compaction|
-with |needed=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...@>=
-@!last_fixed_str:str_number; {last permanently allocated string}
-@!fixed_str_use:str_number; {number of permanently allocated strings}
-
-@ @<Declare the procedure called |do_compaction|@>=
-procedure do_compaction(@!needed:pool_pointer);
-label done;
-var @!str_use:str_number; {a count of strings in use}
-@!r,@!s,@!t:str_number; {strings being manipulated}
-@!p,@!q:pool_pointer; {destination and source for copying string characters}
-begin @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
-r:=last_fixed_str;
-s:=next_str[r];
-p:=str_start[s];
-while s<>str_ptr do
- begin while str_ref[s]=0 do
- @<Advance |s| and add the old |s| to the list of free string numbers;
- then |goto done| if |s=str_ptr|@>;
- r:=s; s:=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@>;
- end;
-done: @<Move the current string back so that it starts at |p|@>;
-if needed<pool_size then
- @<Make sure that there is room for another string with |needed| characters@>;
-stat @<Account for the compaction and make sure the statistics agree with the
- global versions@>;
-tats@;
-strs_used_up:=str_use;
-end;
-
-@ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
-t:=next_str[last_fixed_str];
-while (str_ref[t]=max_str_ref)and(t<>str_ptr) do
- begin incr(fixed_str_use);
- last_fixed_str:=t;
- t:=next_str[t];
- end;
-str_use:=fixed_str_use
-
-@ Because of the way |flush_string| has been written, it should never be
-necessary to |goto done| 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;...@>=
-begin t:=s;
-s:=next_str[s];
-next_str[r]:=s;
-next_str[t]:=next_str[str_ptr];
-next_str[str_ptr]:=t;
-if s=str_ptr then goto done;
-end
-
-@ 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:=str_start[r];
-str_start[r]:=p;
-while q<str_start[s] do
- begin str_pool[p]:=str_pool[q];
- incr(p); incr(q);
- end
-
-@ 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:=str_start[str_ptr];
-str_start[str_ptr]:=p;
-while q<pool_ptr do
- begin str_pool[p]:=str_pool[q];
- incr(p); incr(q);
- end;
-pool_ptr:=p
-
-@ We must remember that |str_ptr| is not allowed to reach |max_strings|.
-
-@<Make sure that there is room for another string with |needed| char...@>=
-begin if str_use>=max_strings-1 then
- begin str_overflowed:=true;
- overflow("number of strings", max_strings-1-init_str_use);
-@:MetaPost capacity exceeded number of strings}{\quad number of strings@>
- end;
-if pool_ptr+needed>max_pool_ptr then
- if pool_ptr+needed>pool_size then
- begin str_overflowed:=true;
- overflow("pool size", pool_size-init_pool_ptr);
-@:MetaPost capacity exceeded pool size}{\quad pool size@>
- end
- else max_pool_ptr:=pool_ptr+needed;
-end
-
-@ Routines that can be called after string overflow need a way of checking
-whether it is safe to use |str_room|, |make_string|, or |do_compaction|.
-
-@<Glob...@>=
-@!str_overflowed:boolean; {is \MP\ aborting due to pool size of number of
- strings?}
-
-@ @<Account for the compaction and make sure the statistics agree with...@>=
-if (str_start[str_ptr]<>pool_in_use)or(str_use<>strs_in_use) then
- confusion("string");
-@:this can't happen string}{\quad string@>
-incr(pact_count);
-pact_chars:=pact_chars+pool_ptr-str_stop(last_fixed_str);
-pact_strs:=pact_strs+str_use-fixed_str_use;
-debug s:=str_ptr; t:=str_use;
- while s<=max_str_ptr do
- begin if t>max_str_ptr then confusion("""");
- incr(t); s:=next_str[s];
- end;
- if t<=max_str_ptr then confusion("""");
-gubed
-
-@ A few more global variables are needed to keep track of statistics when
-|stat| $\ldots$ |tats| blocks are not commented out.
-
-@<Glob...@>=
-@!pact_count:integer; {number of string pool compactions so far}
-@!pact_chars:integer; {total number of characters moved during compactions}
-@!pact_strs:integer; {total number of strings moved during compactions}
-
-@ @<Initialize compaction statistics@>=
-pact_count:=0;
-pact_chars:=0;
-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.
-
-@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}
-@!result: boolean; {result of comparison}
-begin j:=str_start[s];
-while j<str_stop(s) do
- begin if so(str_pool[j])<>buffer[k] then
- begin result:=false; goto not_found;
- end;
- incr(j); incr(k);
- 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. If the first string
-is lexicographically greater than, less than, or equal to the second,
-the result is respectively positive, negative, or zero.
-
-@p function str_vs_str(@!s,@!t:str_number):integer;
- {test equality of strings}
-label exit;
-var @!j,@!k: pool_pointer; {running indices}
-@!ls,@!lt:integer; {lengths}
-@!l:integer; {length remaining to test}
-begin ls:=length(s); lt:=length(t);
-if ls<=lt then l:=ls@+else l:=lt;
-j:=str_start[s]; k:=str_start[t];
-while l>0 do
- begin if str_pool[j]<>str_pool[k] then
- begin str_vs_str:=str_pool[j]-str_pool[k]; return;
- end;
- incr(j); incr(k); decr(l);
- end;
-str_vs_str:=ls-lt;
-exit:end;
-
-@ 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@>
-
-@p @!init function get_strings_started:boolean; {initializes the string pool,
- but returns |false| if something goes wrong}
-label done,exit;
-var @!k:0..255; {small indices or counters}
-@!g:str_number; {garbage}
-begin pool_ptr:=0; str_ptr:=0; max_pool_ptr:=0; max_str_ptr:=0;
-str_start[0]:=0;
-next_str[0]:=1;
-str_overflowed:=false;
-stat pool_in_use:=0; strs_in_use:=0;
- max_pl_used:=0; max_strs_used:=0;
- @<Initialize compaction statistics@>;
-tats@;
-strs_used_up:=0;
-@<Make the first 256 strings@>;
-@<Read the other strings from the \.{MP.POOL} file and return |true|,
- or give an error message and return |false|@>;
-last_fixed_str:=str_ptr-1;
-fixed_str_use:=str_ptr;
-exit:end;
-tini
-
-@ The first 256 strings will consist of a single character only.
-
-@<Make the first 256...@>=
-for k:=0 to 255 do
- begin append_char(k);
- g:=make_string; str_ref[g]:=max_str_ref;
- end;
-
-@ 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 printed as 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 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<@'200|, then character |k+@'100| or
-|k-@'100| must be printable; moreover, ASCII codes |[@'60..@'71, @'141..@'146]|
-must be printable.
-@^character set dependencies@>
-@^system dependencies@>
-
-@<Character |k| cannot be printed@>=
- (k<" ")or(k>"~")
-
-@ When the \.{WEB} system program called \.{TANGLE} processes the \.{MP.WEB}
-description that you are now reading, it outputs the \PASCAL\ program
-\.{MP.PAS} and also a string pool file called \.{MP.POOL}. The \.{INIMP}
-@.WEB@>@.INIMP@>
-program reads the latter file, where each string appears as a two-digit decimal
-length followed by the string itself, and the information is recorded in
-\MP's string memory.
-
-@<Glob...@>=
-@!init @!pool_file:alpha_file; {the string-pool file output by \.{TANGLE}}
-tini
-
-@ @<Read the other strings...@>=
- g := loadpoolstrings((pool_size-string_vacancies));
- if g=0 then begin
- wake_up_terminal; write_ln(term_out,'! You have to increase POOLSIZE.');
- get_strings_started:=false;
- return;
- end;
- get_strings_started:=true;
-
-
-@ The \.{WEB} operation \.{@@\$} denotes the value that should be at the
-end of this \.{MP.POOL} file; any other value means that the wrong pool
-file has been loaded.
-@^check sum@>
-
-
-@* \[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 |ps_file_only| prints only on the \ps\ output file.
-
-\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..max_write_files-1| 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|, |new_string|,
-or |ps_file_only|. We need not check for unprintable characters when
-|selector<pseudo|.
-
-Four additional global variables, |tally|, |term_offset|, |file_offset|,
-and |ps_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|,
-|file_offset|, and |ps_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=max_write_files {printing is deflected to the string pool}
-@d ps_file_only=new_string+1 {printing goes to the \ps\ output file}
-@d pseudo=new_string+2 {special |selector| setting for |show_context|}
-@d no_print=new_string+3 {|selector| setting that makes data disappear}
-@d term_only=new_string+4 {printing is destined for the terminal only}
-@d log_only=new_string+5 {printing is destined for the transcript file only}
-@d term_and_log=new_string+6 {normal |selector| setting}
-@d max_selector=term_and_log {highest selector setting}
-
-@<Glob...@>=
-@!log_file : alpha_file; {transcript of \MP\ session}
-@!ps_file: alpha_file; {the generic font output goes here}
-@!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}
-@!ps_offset : integer;
- {the number of characters on the current \ps\ file line}
-@!trick_buf:array[0..error_line] of ASCII_code; {circular buffer for
- pseudoprinting}
-@!trick_count: integer; {threshold for pseudoprinting, explained later}
-@!first_count: integer; {another variable for pseudoprinting}
-
-@ @<Initialize the output routines@>=
-selector:=term_only; tally:=0; term_offset:=0; file_offset:=0; ps_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 wterm(#)==write(term_out,#)
-@d wterm_ln(#)==write_ln(term_out,#)
-@d wterm_cr==write_ln(term_out)
-@d wlog(#)==write(log_file,#)
-@d wlog_ln(#)==write_ln(log_file,#)
-@d wlog_cr==write_ln(log_file)
-@d wps(#)==write(ps_file,#)
-@d wps_ln(#)==write_ln(ps_file,#)
-@d wps_cr==write_ln(ps_file)
-
-@ 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.
-
-@<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;
-ps_file_only: begin wps_cr; ps_offset:=0;
- end;
-no_print,pseudo,new_string: do_nothing;
-othercases write_ln(wr_file[selector])
-endcases;
-end; {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...@>=
-procedure@?unit_str_room; forward;@t\2@>@/
-procedure print_visible_char(@!s:ASCII_code); {prints a single character}
-label done;
-begin case selector of
-term_and_log: begin wterm(xchr[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 wlog(xchr[s]); incr(file_offset);
- if file_offset=max_print_line then print_ln;
- end;
-term_only: begin wterm(xchr[s]); incr(term_offset);
- if term_offset=max_print_line then print_ln;
- end;
-ps_file_only: if s=13 then begin
- wps_cr; ps_offset:=0;
- end
- else
- begin
- wps(xchr[s]); incr(ps_offset);
- end;
-no_print: do_nothing;
-pseudo: if tally<trick_count then trick_buf[tally mod error_line]:=s;
-new_string: begin if pool_ptr>=max_pool_ptr then
- begin unit_str_room;
- if pool_ptr>=pool_size then goto done;
- {drop characters if string space is full}
- end;
- append_char(s);
- end;
-othercases write(wr_file[selector],xchr[s])
-endcases;
-done:incr(tally);
-end;
-
-@ 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| or when
-|selector=ps_file_only|. In the former case the user might want to write
-unprintable characters, and in the latter case the \ps\ printing routines
-check their arguments themselves before calling |print_char| or |print|.)
-
-@d print_lc_hex(#)==l:=#;
- if l<10 then print_visible_char(l+"0")@+else print_visible_char(l-10+"a")
-
-@<Basic printing...@>=
-procedure print_char(@!k:ASCII_code); {prints a single character}
-var l:0..255; {small index or counter}
-begin if selector<pseudo then print_visible_char(k)
-else if @<Character |k| cannot be printed@> then
- begin print_visible_char("^"); print_visible_char("^");
- if k<@'100 then print_visible_char(k+@'100)
- else if k<@'200 then print_visible_char(k-@'100)
- else begin print_lc_hex(k div 16); print_lc_hex(k mod 16);
- end;
- end
-else print_visible_char(k);
-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 \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...@>=
-procedure print(@!s:integer); {prints string |s|}
-var @!j:pool_pointer; {current character code position}
-begin if (s<0)or(s>max_str_ptr) then s:="???"; {this can't happen}
-@.???@>
-j:=str_start[s];
-while j<str_stop(s) do
- begin print_char(so(str_pool[j])); incr(j);
- end;
-end;
-
-@ By popular demand, \MP\ prints the banner line only on the transcript file.
-Thus there is nothing special to be printed here.
-
-@<Initialize the output...@>=
-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...@>=
-procedure print_nl(@!s:str_number); {prints string |s| at beginning of line}
-begin case selector of
-term_and_log: if (term_offset>0)or(file_offset>0) then print_ln;
-log_only: if file_offset>0 then print_ln;
-term_only: if term_offset>0 then print_ln;
-ps_file_only: if ps_offset>0 then print_ln;
-no_print,pseudo,new_string: do_nothing;
-end; {there are no other cases}
-print(s);
-end;
-
-@ An array of digits in the range |0..9| 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); print_char("0"+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;
-
-@ \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|.
-
-@p procedure print_dd(@!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;
-
-@ 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|.
-
-@d prompt_input(#)==begin wake_up_terminal; print(#); term_input;
- end {prints a string and gets a line of input}
-
-@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; buffer[last]:="%"; incr(selector); {restore previous status}
-end;
-
-@* \[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:
-
-@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(#);
-@.!\relax@>
- end
-
-@<Glob...@>=
-@!interaction:batch_mode..error_stop_mode; {current level of interaction}
-
-@ @<Set init...@>=interaction:=error_stop_mode;
-
-@ \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=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|
-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.
-
-@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_next|?}
-@!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 statement ended}
-
-@ The value of |history| is initially |fatal_error_stop|, but it will
-be changed to |spotless| if \MP\ survives the initialization process.
-
-@<Set init...@>=
-deletions_allowed:=true; 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.
-
-@<Error handling...@>=
-procedure@?normalize_selector; forward;@t\2@>@/
-procedure@?get_next; 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@>@/
-@t\4\hskip-\fontdimen2\font@>@;@+@!debug@+procedure@?debug_help;
- forward;@;@+gubed@;@/
-@t\4@>@<Declare the procedure called |flush_string|@>
-
-@ 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}
-
-@<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| string be shown?}
-@!err_help:str_number; {a string set up by \&{errhelp}}
-@!filename_template:str_number; {a string set up by \&{filenametemplate}}
-
-@ @<Set init...@>=
-help_ptr:=0; use_err_help:=false; err_help:=0; 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.
-
-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_MP;
-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}
-@!s1,@!s2,@!s3:integer; {used to save global variables when deleting tokens}
-@!j:pool_pointer; {character position being printed}
-begin if history<error_message_issued then history:=error_message_issued;
-print_char("."); 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 \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@>
-
-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-"0"| tokens and |goto continue|@>;
-@t\4\4@>@;@+@!debug "D":begin debug_help;goto continue;@+end;@+gubed@/
-"E": if file_ptr>0 then
- begin print_nl("You want to edit file ");
-@.You want to edit file x@>
- print(input_stack[file_ptr].name_field);
- print(" at line "); print_int(true_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 file_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 \MP\ 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("batchmode"); decr(selector);
- end;
-"R":print("nonstopmode");
-"S":print("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 \MP's input stacks.
-
-@<Introduce new material...@>=
-begin begin_file_reading; {enter a new syntactic level for terminal input}
-if last>first+1 then
- begin loc:=first+1; buffer[first]:=" ";
- end
-else begin prompt_input("insert>"); loc:=first;
-@.insert>@>
- end;
-first:=last+1; cur_input.limit_field:=last; return;
-end
-
-@ We allow deletion of up to 99 tokens at a time.
-
-@<Delete |c-"0"| tokens...@>=
-begin s1:=cur_cmd; s2:=cur_mod; s3:=cur_sym; 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_next; {one-level recursive call of |error| is possible}
- @<Decrease the string reference count, if the current token is a string@>;
- decr(c);
- end;
-cur_cmd:=s1; cur_mod:=s2; cur_sym:=s3; 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 @<Print the string |err_help|, possibly on several lines@>;
- 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
-
-@ @<Print the string |err_help|, possibly on several lines@>=
-j:=str_start[err_help];
-while j<str_stop(err_help) do
- begin if str_pool[j]<>si("%") then print(so(str_pool[j]))
- else if j+1=str_stop(err_help) then print_ln
- else if str_pool[j+1]<>si("%") then print_ln
- else begin incr(j); print_char("%");
- end;
- incr(j);
- 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_nl("");
- @<Print the string |err_help|, possibly on several lines@>;
- 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
-
-@ 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 \MP'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 overflow(@!s:str_number;@!n:integer); {stop due to finiteness}
-begin normalize_selector;
-print_err("MetaPost capacity exceeded, sorry [");
-@.MetaPost 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;
-
-@ 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@>
-
-@<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 \MP\ 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 signaled. Otherwise there is probably at least
-a way to make |interrupt| nonzero using the \PASCAL\ debugger.
-@^system dependencies@>
-@^debugging@>
-
-@d check_interrupt==begin if interrupt<>0 then pause_for_instructions;
- end
-
-@<Global...@>=
-@!interrupt:integer; {should \MP\ pause for instructions?}
-@!OK_to_interrupt:boolean; {should interrupts be observed?}
-
-@ @<Set init...@>=
-interrupt:=0; OK_to_interrupt:=true;
-
-@ 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.
-
-@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 show x'),")@/
- ("unless you just want to quit by typing `X'.");
- deletions_allowed:=false; error; deletions_allowed:=true;
- interrupt:=0;
- end;
-end;
-
-@ 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.
-
-@p procedure missing_err(@!s:str_number);
-begin print_err("Missing `"); print(s); print("' has been inserted");
-@.Missing...inserted@>
-end;
-
-@* \[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 \PASCAL\ does not define the @!|div|
-operation in the case of negative dividends; for example, the result of
-|(-2*n-1) div 2| is |-(n+1)| on some computers and |-n| on others.
-There are two principal types of arithmetic: ``translation-preserving,''
-in which the identity |(a+q*b)div b=(a div b)+q| is valid; and
-``negation-preserving,'' in which |(-a)div b=-(a div 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 == @'17777777777 {$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 only decent way to do
-this in \PASCAL\ is to write `|(a+b) div 2|'; but on most machines it is
-far more efficient to calculate `|(a+b)| right shifted one bit'.
-
-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 languages 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(#)==(#) div 2
-@d halfp(#)==(#) div 2
-
-@ 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...@>=
-@!arith_error:boolean; {has arithmetic overflow occurred recently?}
-
-@ @<Set init...@>=
-arith_error:=false;
-
-@ At crucial points the program will say |check_arith|, to test if
-an arithmetic error has been detected.
-
-@d check_arith==begin if arith_error then clear_arith;@+end
-
-@p procedure clear_arith;
-begin 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.");
-error; arith_error:=false;
-end;
-
-@ 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.
-
-@p function slow_add(@!x,@!y:integer):integer;
-begin if x>=0 then
- if y<=el_gordo-x then slow_add:=x+y
- else begin arith_error:=true; slow_add:=el_gordo;
- end
-else if -y<=el_gordo+x then slow_add:=x+y
- else begin arith_error:=true; slow_add:=-el_gordo;
- end;
-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 quarter_unit == @'40000 {$2^{14}$, represents 0.250000}
-@d half_unit == @'100000 {$2^{15}$, represents 0.50000}
-@d three_quarter_unit == @'140000 {$3\cdot2^{14}$, represents 0.75000}
-@d unity == @'200000 {$2^{16}$, represents 1.00000}
-@d two == @'400000 {$2^{17}$, represents 2.00000}
-@d three == @'600000 {$2^{17}+2^{16}$, represents 3.00000}
-
-@<Types...@>=
-@!scaled = integer; {this type is used for scaled integers}
-@!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:=halfp(a+1);
-end;
-
-@ 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...@>=
-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}
-s:=10*(s mod unity)+5;
-if s<>5 then
- begin delta:=10; print_char(".");
- repeat if delta>unity then
- s:=s+@'100000-(delta div 2); {round the final digit}
- print_char("0"+(s div unity)); s:=10*(s mod unity); delta:=delta*10;
- until s<=delta;
- end;
-end;
-
-@ We often want to print two scaled quantities in parentheses,
-separated by a comma.
-
-@<Basic printing...@>=
-procedure print_two(@!x,@!y:scaled); {prints `|(x,y)|'}
-begin print_char("("); print_scaled(x); print_char(","); print_scaled(y);
-print_char(")");
-end;
-
-@ 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==@'1000000000 {$2^{27}$, represents 0.50000000}
-@d fraction_one==@'2000000000 {$2^{28}$, represents 1.00000000}
-@d fraction_two==@'4000000000 {$2^{29}$, represents 2.00000000}
-@d fraction_three==@'6000000000 {$3\cdot2^{28}$, represents 3.00000000}
-@d fraction_four==@'10000000000 {$2^{30}$, represents 4.00000000}
-
-@<Types...@>=
-@!fraction=integer; {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==@'264000000 {$45\cdot2^{20}$, represents $45^\circ$}
-@d ninety_deg==@'550000000 {$90\cdot2^{20}$, represents $90^\circ$}
-@d one_eighty_deg==@'1320000000 {$180\cdot2^{20}$, represents $180^\circ$}
-@d three_sixty_deg==@'2640000000 {$360\cdot2^{20}$, represents $360^\circ$}
-
-@<Types...@>=
-@!angle=integer; {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 \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_fraction(@!p,@!q:integer):fraction;
-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_fraction:=-el_gordo@+else make_fraction:=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_fraction:=-(f+n)@+else make_fraction:=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)
-
-@ 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@>
-
-@p function take_fraction(@!q:integer;@!f:fraction):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_fraction:=-(n+p)
-else take_fraction:=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
-
-
-@ 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@>
-
-@p function take_scaled(@!q:integer;@!f:scaled):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<unity then n:=0
-else begin n:=f div unity; f:=f mod unity;
- if q<=el_gordo div n then n:=n*q
- else begin arith_error:=true; n:=el_gordo;
- end;
- end;
-f:=f+unity;
-@<Compute $p=\lfloor qf/2^{16}+{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_scaled:=-(n+p)
-else take_scaled:=n+p;
-end;
-
-@ @<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 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
-
-@ 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.)
-
-@p function make_scaled(@!p,@!q:integer):scaled;
-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>=@'100000 then
- begin arith_error:=true;
- if negative then make_scaled:=-el_gordo@+else make_scaled:=el_gordo;
- end
-else begin n:=(n-1)*unity;
- @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
- if negative then make_scaled:=-(f+n)@+else make_scaled:=f+n;
- end;
-end;
-
-@ @<Compute $f=\lfloor 2^{16}(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>=unity;
-be_careful:=p-q;
-if be_careful+p>=0 then 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.
-
-@p function velocity(@!st,@!ct,@!sf,@!cf:fraction;@!t:scaled):fraction;
-var @!acc,@!num,@!denom:integer; {registers for intermediate calculations}
-begin acc:=take_fraction(st-(sf div 16), sf-(st div 16));
-acc:=take_fraction(acc,ct-cf);
-num:=fraction_two+take_fraction(acc,379625062);
- {$2^{28}\sqrt2\approx379625062.497$}
-denom:=fraction_three+take_fraction(ct,497706707)+take_fraction(cf,307599661);
- {$3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
- $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$}
-if t<>unity then num:=make_scaled(num,t);
- {|make_scaled(fraction,scaled)=fraction|}
-if num div 4>=denom then velocity:=fraction_four
-else velocity:=make_fraction(num,denom);
-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
-
-@ We conclude this set of elementary routines with some simple rounding
-and truncation operations that are coded in a machine-independent fashion.
-The routines are slightly complicated because we want them to work
-without overflow whenever $-2^{31}\L x<2^{31}$.
-
-@p function floor_scaled(@!x:scaled):scaled;
- {$2^{16}\lfloor x/2^{16}\rfloor$}
-var @!be_careful:integer; {temporary register}
-begin if x>=0 then floor_scaled:=x-(x mod unity)
-else begin be_careful:=x+1;
- floor_scaled:=x+((-be_careful) mod unity)+1-unity;
- end;
-end;
-@#
-function round_unscaled(@!x:scaled):integer;
- {$\lfloor x/2^{16}+.5\rfloor$}
-var @!be_careful:integer; {temporary register}
-begin if x>=half_unit then round_unscaled:=1+((x-half_unit) div unity)
-else if x>=-half_unit then round_unscaled:=0
-else begin be_careful:=x+1;
- round_unscaled:=-(1+((-be_careful-half_unit) div unity));
- end;
-end;
-@#
-function round_fraction(@!x:fraction):scaled;
- {$\lfloor x/2^{12}+.5\rfloor$}
-var @!be_careful:integer; {temporary register}
-begin if x>=2048 then round_fraction:=1+((x-2048) div 4096)
-else if x>=-2048 then round_fraction:=0
-else begin be_careful:=x+1;
- round_fraction:=-(1+((-be_careful-2048) div 4096));
- end;
-end;
-
-@* \[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.
-
-@p function square_rt(@!x:scaled):scaled;
-var @!k:small_number; {iteration control counter}
-@!y,@!q:integer; {registers for intermediate calculations}
-begin if x<=0 then @<Handle square root of zero or negative argument@>
-else begin k:=23; q:=2;
- while x<fraction_two do {i.e., |while x<@t$2^{29}$@>|\unskip}
- begin decr(k); x:=x+x+x+x;
- end;
- if x<fraction_four then y:=0
- else begin x:=x-fraction_four; y:=1;
- end;
- repeat @<Decrease |k| by 1, maintaining the invariant
- relations between |x|, |y|, and~|q|@>;
- until k=0;
- square_rt:=halfp(q);
- end;
-end;
-
-@ @<Handle square root of zero...@>=
-begin if x<0 then
- begin print_err("Square root of ");
-@.Square root...replaced by 0@>
- print_scaled(x); print(" 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.");
- error;
- end;
-square_rt:=0;
-end
-
-@ @<Decrease |k| by 1, maintaining...@>=
-double(x); double(y);
-if x>=fraction_four then {note that |fraction_four=@t$2^{30}$@>|}
- begin x:=x-fraction_four; incr(y);
- end;
-double(x); y:=y+y-q; double(q);
-if x>=fraction_four then
- begin x:=x-fraction_four; incr(y);
- end;
-if y>q then
- begin y:=y-q; q:=q+2;
- end
-else if y<=0 then
- begin q:=q-2; y:=y+q;
- end;
-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.
-
-@p function pyth_add(@!a,@!b:integer):integer;
-label done;
-var @!r:fraction; {register used to transform |a| and |b|}
-@!big:boolean; {is the result dangerously near $2^{31}$?}
-begin a:=abs(a); b:=abs(b);
-if a<b then
- begin r:=b; b:=a; a:=r;
- end; {now |0<=b<=a|}
-if b>0 then
- begin if a<fraction_two then big:=false
- else begin a:=a div 4; b:=b div 4; big:=true;
- end; {we reduced the precision to avoid arithmetic overflow}
- @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
- if big then
- if a<fraction_two then a:=a+a+a+a
- else begin arith_error:=true; a:=el_gordo;
- end;
- end;
-pyth_add:=a;
-end;
-
-@ 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}$@>=
-loop@+ begin r:=make_fraction(b,a);
- r:=take_fraction(r,r); {now $r\approx b^2/a^2$}
- if r=0 then goto done;
- r:=make_fraction(r,fraction_four+r);
- a:=a+take_fraction(a+a,r); b:=take_fraction(b,r);
- end;
-done:
-
-@ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
-It converges slowly when $b$ is near $a$, but otherwise it works fine.
-
-@p function pyth_sub(@!a,@!b:integer):integer;
-label done;
-var @!r:fraction; {register used to transform |a| and |b|}
-@!big:boolean; {is the input dangerously near $2^{31}$?}
-begin a:=abs(a); b:=abs(b);
-if a<=b then @<Handle erroneous |pyth_sub| and set |a:=0|@>
-else begin if a<fraction_four then big:=false
- else begin a:=halfp(a); b:=halfp(b); big:=true;
- end;
- @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
- if big then a:=a+a;
- end;
-pyth_sub:=a;
-end;
-
-@ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
-loop@+ begin r:=make_fraction(b,a);
- r:=take_fraction(r,r); {now $r\approx b^2/a^2$}
- if r=0 then goto done;
- r:=make_fraction(r,fraction_four-r);
- a:=a-take_fraction(a+a,r); b:=take_fraction(b,r);
- end;
-done:
-
-@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
-begin if a<b then
- begin print_err("Pythagorean subtraction "); print_scaled(a);
- print("+-+"); print_scaled(b); print(" 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.");
- error;
- end;
-a:=0;
-end
-
-@ 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}
-
-@ @<Local variables for initialization@>=
-@!k:integer; {all-purpose loop index}
-
-@ @<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;
-
-@ 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.)
-
-@p function m_log(@!x:scaled):scaled;
-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
-
-@ 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.
-
-@p function m_exp(@!x:scaled):scaled;
-var @!k:small_number; {loop control index}
-@!y,@!z:integer; {auxiliary registers}
-begin if x>174436200 then
- {$2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$}
- begin arith_error:=true; m_exp:=el_gordo;
- end
-else if x<-197694359 then m_exp:=0
- {$2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$}
-else begin if x<=0 then
- begin z:=-8*x; y:=@'4000000; {$y=2^{20}$}
- end
- else begin if x<=127919879 then 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;
- end;
- @<Multiply |y| by $\exp(-z/2^{27})$@>;
- if x<=127919879 then m_exp:=(y+8) div 16@+else m_exp:=y;
- end;
-end;
-
-@ 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 do
- begin while z>=spec_log[k] do
- begin z:=z-spec_log[k];
- y:=y-1-((y-two_to_the[k-1]) div two_to_the[k]);
- end;
- incr(k);
- end
-
-@ The trigonometric subroutines use an auxiliary table such that
-|spec_atan[k]| contains an approximation to the |angle| whose tangent
-is~$1/2^k$.
-
-@<Glob...@>=
-@!spec_atan:array[1..26] of angle; {$\arctan2^{-k}$ times $2^{20}\cdot180/\pi$}
-
-@ @<Set init...@>=
-spec_atan[1]:=27855475;
-spec_atan[2]:=14718068;
-spec_atan[3]:=7471121;
-spec_atan[4]:=3750058;
-spec_atan[5]:=1876857;
-spec_atan[6]:=938658;
-spec_atan[7]:=469357;
-spec_atan[8]:=234682;
-spec_atan[9]:=117342;
-spec_atan[10]:=58671;
-spec_atan[11]:=29335;
-spec_atan[12]:=14668;
-spec_atan[13]:=7334;
-spec_atan[14]:=3667;
-spec_atan[15]:=1833;
-spec_atan[16]:=917;
-spec_atan[17]:=458;
-spec_atan[18]:=229;
-spec_atan[19]:=115;
-spec_atan[20]:=57;
-spec_atan[21]:=29;
-spec_atan[22]:=14;
-spec_atan[23]:=7;
-spec_atan[24]:=4;
-spec_atan[25]:=2;
-spec_atan[26]:=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
-
-@p function n_arg(@!x,@!y:integer):angle;
-var @!z:angle; {auxiliary register}
-@!t:integer; {temporary storage}
-@!k:small_number; {loop counter}
-@!octant:first_octant..sixth_octant; {octant code}
-begin if x>=0 then octant:=first_octant
-else begin negate(x); octant:=first_octant+negate_x;
- end;
-if y<0 then
- begin negate(y); octant:=octant+negate_y;
- end;
-if x<y then
- begin t:=y; y:=x; x:=t; octant:=octant+switch_x_and_y;
- end;
-if x=0 then @<Handle undefined arg@>
-else begin @<Set variable |z| to the arg of $(x,y)$@>;
- @<Return an appropriate answer based on |z| and |octant|@>;
- end;
-end;
-
-@ @<Handle undefined arg@>=
-begin 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.");
-error; n_arg:=0;
-end
-
-@ @<Return an appropriate answer...@>=
-case octant of
-first_octant:n_arg:=z;
-second_octant:n_arg:=ninety_deg-z;
-third_octant:n_arg:=ninety_deg+z;
-fourth_octant:n_arg:=one_eighty_deg-z;
-fifth_octant:n_arg:=z-one_eighty_deg;
-sixth_octant:n_arg:=-z-ninety_deg;
-seventh_octant:n_arg:=z-ninety_deg;
-othercases n_arg:=-z; { |eighth_octant| }
-end
-
-@ 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 do
- begin x:=halfp(x); y:=halfp(y);
- end;
-z:=0;
-if y>0 then
- begin while x<fraction_one do
- begin double(x); double(y);
- end;
- @<Increase |z| to the arg of $(x,y)$@>;
- end
-
-@ 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;
-repeat double(y); incr(k);
-if y>x then
- begin z:=z+spec_atan[k]; t:=x; x:=x+(y div two_to_the[k+k]); y:=y-t;
- end;
-until k=15;
-repeat double(y); incr(k);
-if y>x then
- begin z:=z+spec_atan[k]; y:=y-x;
- end;
-until 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...@>=
-@!n_sin,@!n_cos:fraction; {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|.
-
-@p procedure n_sin_cos(@!z:angle); {computes a multiple of the sine and cosine}
-var @!k:small_number; {loop control variable}
-@!q:0..7; {specifies the quadrant}
-@!r:fraction; {magnitude of |(x,y)|}
-@!x,@!y,@!t:integer; {temporary registers}
-begin while z<0 do z:=z+three_sixty_deg;
-z:=z mod three_sixty_deg; {now |0<=z<three_sixty_deg|}
-q:=z div forty_five_deg; z:=z mod forty_five_deg;
-x:=fraction_one; y:=x;
-if not odd(q) then z:=forty_five_deg-z;
-@<Subtract angle |z| from |(x,y)|@>;
-@<Convert |(x,y)| to the octant determined by~|q|@>;
-r:=pyth_add(x,y); n_cos:=make_fraction(x,r); n_sin:=make_fraction(y,r);
-end;
-
-@ In this case the octants are numbered sequentially.
-
-@<Convert |(x,...@>=
-case q of
-0:do_nothing;
-1:begin t:=x; x:=y; y:=t;
- end;
-2:begin t:=x; x:=-y; y:=t;
- end;
-3:negate(x);
-4:begin negate(x); negate(y);
- end;
-5:begin t:=x; x:=-y; y:=-t;
- end;
-6:begin t:=x; x:=y; y:=-t;
- end;
-7:negate(y);
-end {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 do
- begin if z>=spec_atan[k] then
- begin z:=z-spec_atan[k]; t:=x;@/
- x:=t+y div two_to_the[k];
- y:=y-t div two_to_the[k];
- end;
- incr(k);
- end;
-if y<0 then 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 |sys_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 pascal code below will initialize
-this variable to |(internal[time] div unity)+internal[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...@>=
-@!randoms:array[0..54] of fraction; {the last 55 random values generated}
-@!j_random:0..54; {the number of unused |randoms|}
-@!sys_random_seed:scaled; {the default 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 j_random=0 then new_randoms
- else decr(j_random)
-
-@p procedure new_randoms;
-var @!k:0..54; {index into |randoms|}
-@!x:fraction; {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:scaled);
-var @!j,@!jj,@!k:fraction; {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_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.
-
-@p function unif_rand(@!x:scaled):scaled;
-var @!y:scaled; {trial value}
-begin next_random; y:=take_fraction(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:scaled;
-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_fraction(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_fraction(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;
-
-@* \[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 \PASCAL\ 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.
-
-Since we are assuming 32-bit integers, a halfword must contain at least
-16 bits, and a quarterword must contain at least 8 bits.
-@^system dependencies@>
-But it doesn't hurt to have more bits; for example, with enough 36-bit
-words you might be able to have |mem_max| as large as 262142.
-
-N.B.: Valuable memory space will be dreadfully wasted unless \MP\ is compiled
-by a \PASCAL\ that packs all of the |memory_word| variants into
-the space of a single integer. 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.
-
-@d min_quarterword=0 {smallest allowable value in a |quarterword|}
-@d max_quarterword=255 {largest allowable value in a |quarterword|}
-@d min_halfword==0 {smallest allowable value in a |halfword|}
-@d max_halfword==65535 {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''...@>=
-init if mem_max<>mem_top then bad:=8;@+tini@;@/
-if mem_max<mem_top then bad:=8;
-if (min_quarterword>0)or(max_quarterword<127) then bad:=9;
-if (min_halfword>0)or(max_halfword<32767) then bad:=10;
-if (min_quarterword<min_halfword)or@|
- (max_quarterword>max_halfword) then bad:=11;
-if (mem_min<min_halfword)or(mem_max>=max_halfword) then bad:=12;
-if max_strings>max_halfword then bad:=13;
-if buf_size>max_halfword then bad:=14;
-if font_max>max_halfword then bad:=15;
-if (max_quarterword-min_quarterword<255)or@|
- (max_halfword-min_halfword<65535) then bad:=16;
-
-@ The operation of subtracting |min_halfword| occurs rather frequently in
-\MP, so it is convenient to abbreviate this operation by using the macro
-|ho| defined here. \MP\ will run faster with respect to compilers that
-don't optimize the expression `|x-0|', if this macro is simplified in the
-obvious way when |min_halfword=0|. Similarly, |qi| and |qo| are used for
-input to and output from quarterwords.
-@^system dependencies@>
-
-@d ho(#)==#-min_halfword
- {to take a sixteen-bit item from a halfword}
-@d qo(#)==#-min_quarterword {to read eight bits from a quarterword}
-@d qi(#)==#+min_quarterword {to store eight bits in a quarterword}
-
-@ 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}
-@!three_choices = 1..3; {used when there are three 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 three_choices of
- 1: (@!int:integer);
- 2: (@!hh:two_halves);
- 3: (@!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(w.sc div @'10000); print_ln;@/
-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
-
-@* \[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 pointer==halfword {a flag or a location in |mem| or |eqtb|}
-@d null==mem_min {the null pointer}
-
-@ 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 |mem_min| 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=mem_min<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
-
-@<Glob...@>=
-@!mem : array[mem_min..mem_max] of memory_word; {the big dynamic storage area}
-@!lo_mem_max : pointer; {the largest location of variable-size memory in use}
-@!hi_mem_min : pointer; {the smallest location of one-word memory in use}
-
-@ 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 |tracing_stats| is positive.
-
-@<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 |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(#) == mem[#].hh.rh {the |link| field of a memory word}
-@d info(#) == mem[#].hh.lh {the |info| field of a memory word}
-
-@<Glob...@>=
-@!avail : pointer; {head of the list of available one-word nodes}
-@!mem_end : pointer; {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.
-
-@p @t\4@>@<Declare the procedure called |show_token_list|@>@;
-@t\4@>@<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@>
-
-@p function get_avail : pointer; {single-word node allocation}
-var @!p:pointer; {the new node being got}
-begin p:=avail; {get top location in the |avail| stack}
-if p<>null then avail:=link(avail) {and pop it off}
-else if mem_end<mem_max then {or go into virgin territory}
- begin incr(mem_end); p:=mem_end;
- end
-else begin decr(hi_mem_min); p:=hi_mem_min;
- if hi_mem_min<=lo_mem_max then
- begin runaway; {if memory is exhausted, display possible runaway text}
- overflow("main memory size",mem_max+1-mem_min);
- {quit; all one-word nodes are busy}
-@:MetaPost capacity exceeded main memory size}{\quad main memory size@>
- 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|.
-
-@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 macro 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 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(#) == (link(#)=empty_flag) {tests for empty node}
-@d node_size == info {the size field in empty variable-size nodes}
-@d llink(#) == info(#+1) {left link in doubly-linked list of empty nodes}
-@d rlink(#) == link(#+1) {right link in doubly-linked list of empty nodes}
-
-@<Glob...@>=
-@!rover : pointer; {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|.
-
-@p function get_node(@!s:integer):pointer; {variable-size node allocation}
-label found,exit,restart;
-var @!p:pointer; {the node currently under inspection}
-@!q:pointer; {the node physically after node |p|}
-@!r:integer; {the newly allocated node, or a candidate for this honor}
-@!t,@!tt:integer; {temporary registers}
-@^inner loop@>
-begin restart: p:=rover; {start at some free node in the ring}
-repeat @<Try to allocate within node |p| and its physical successors,
- and |goto found| if allocation was possible@>;
-p:=rlink(p); {move to the next node in the ring}
-until p=rover; {repeat until the whole list has been traversed}
-if s=@'10000000000 then
- begin get_node:=max_halfword; return;
- end;
-if lo_mem_max+2<hi_mem_min then if lo_mem_max+2<=mem_min+max_halfword then
- @<Grow more variable-size memory and |goto restart|@>;
-overflow("main memory size",mem_max+1-mem_min);
- {sorry, nothing satisfactory is left}
-@:MetaPost capacity exceeded main memory size}{\quad main memory size@>
-found: link(r):=null; {this node is now nonempty}
-@!stat var_used:=var_used+s; {maintain usage statistics}
-tats@;@/
-get_node:=r;
-exit:end;
-
-@ 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|@>=
-begin if hi_mem_min-lo_mem_max>=1998 then t:=lo_mem_max+1000
-else t:=lo_mem_max+1+(hi_mem_min-lo_mem_max) div 2;
- {|lo_mem_max+2<=t<hi_mem_min|}
-if t>mem_min+max_halfword then t:=mem_min+max_halfword;
-p:=llink(rover); q:=lo_mem_max; rlink(p):=q; llink(rover):=q;@/
-rlink(q):=rover; llink(q):=p; link(q):=empty_flag; node_size(q):=t-lo_mem_max;@/
-lo_mem_max:=t; link(lo_mem_max):=null; info(lo_mem_max):=null;
-rover:=q; goto restart;
-end
-
-@ @<Try to allocate...@>=
-q:=p+node_size(p); {find the physical successor}
-while is_empty(q) do {merge node |p| with node |q|}
- begin t:=rlink(q); tt:=llink(q);
-@^inner loop@>
- if q=rover then rover:=t;
- llink(t):=tt; rlink(tt):=t;@/
- q:=q+node_size(q);
- end;
-r:=q-s;
-if r>p+1 then @<Allocate from the top of node |p| and |goto found|@>;
-if r=p then if rlink(p)<>p then
- @<Allocate entire node |p| and |goto found|@>;
-node_size(p):=q-p {reset the size in case it grew}
-
-@ @<Allocate from the top...@>=
-begin node_size(p):=r-p; {store the remaining size}
-rover:=p; {start searching here next time}
-goto found;
-end
-
-@ Here we delete node |p| from the ring, and let |rover| rove around.
-
-@<Allocate entire...@>=
-begin rover:=rlink(p); t:=llink(p);
-llink(rover):=t; rlink(t):=rover;
-goto found;
-end
-
-@ 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.
-
-@p procedure free_node(@!p:pointer; @!s:halfword); {variable-size node
- liberation}
-var @!q:pointer; {|llink(rover)|}
-begin node_size(p):=s; link(p):=empty_flag;
-@^inner loop@>
-q:=llink(rover); llink(p):=q; rlink(p):=rover; {set both links}
-llink(rover):=p; rlink(q):=p; {insert |p| into the ring}
-@!stat var_used:=var_used-s;@+tats@;{maintain statistics}
-end;
-
-@ 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.
-
-@p @!init procedure sort_avail; {sorts the available variable-size nodes
- by location}
-var @!p,@!q,@!r: pointer; {indices into |mem|}
-@!old_rover:pointer; {initial |rover| setting}
-begin p:=get_node(@'10000000000); {merge adjacent free areas}
-p:=rlink(rover); rlink(rover):=max_halfword; old_rover:=rover;
-while p<>old_rover do @<Sort |p| into the list starting at |rover|
- and advance |p| to |rlink(p)|@>;
-p:=rover;
-while rlink(p)<>max_halfword do
- begin llink(rlink(p)):=p; p:=rlink(p);
- end;
-rlink(p):=rover; llink(rover):=p;
-end;
-tini
-
-@ 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<rover then
- begin q:=p; p:=rlink(q); rlink(q):=rover; rover:=q;
- end
-else begin q:=rover;
- while rlink(q)<p do q:=rlink(q);
- r:=rlink(p); rlink(p):=rlink(q); rlink(q):=p; p:=r;
- end
-
-@* \[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 |mem_min| to |mem_min+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 |mem_min| through |lo_mem_stat_max|, and static single-word nodes
-appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
-
-@d null_dash==mem_min+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==mem_top {end of sorted lists}
-@d temp_head==mem_top-1 {head of a temporary list of some kind}
-@d hold_head==mem_top-2 {head of a temporary list of another kind}
-@d spec_head==mem_top-3 {head of a list of unprocessed \&{special} items}
-@d hi_mem_stat_min==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)@>=
-rover:=lo_mem_stat_max+1; {initialize the dynamic memory}
-link(rover):=empty_flag;
-node_size(rover):=1000; {which is a 1000-word available node}
-llink(rover):=rover; rlink(rover):=rover;@/
-lo_mem_max:=rover+1000; link(lo_mem_max):=null; info(lo_mem_max):=null;@/
-for k:=hi_mem_stat_min to mem_top do
- mem[k]:=mem[lo_mem_max]; {clear list heads}
-avail:=null; mem_end:=mem_top;
-hi_mem_min:=hi_mem_stat_min; {initialize the one-word memory}
-var_used:=lo_mem_stat_max+1-mem_min; dyn_used:=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@>
-
-@p procedure flush_list(@!p:pointer); {makes list of single-word nodes
- available}
-label done;
-var @!q,@!r:pointer; {list traversers}
-begin if p>=hi_mem_min then if p<>sentinel then
- begin r:=p;
- repeat q:=r; r:=link(r); @!stat decr(dyn_used);@+tats@/
- if r<hi_mem_min then goto done;
- until r=sentinel;
- done: {now |q| is the last node on the list}
- link(q):=avail; avail:=p;
- end;
-end;
-@#
-procedure flush_node_list(@!p:pointer);
-var @!q:pointer; {the node being recycled}
-begin while p<>null do
- begin q:=p; p:=link(p);
- if q<hi_mem_min then free_node(q,2)@+else free_avail(q);
- end;
-end;
-
-@ 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.)
-
-@<Glob...@>=
-@!debug @!free: packed array [mem_min..mem_max] of boolean; {free cells}
-@t\hskip1em@>@!was_free: packed array [mem_min..mem_max] of boolean;
- {previously free cells}
-@t\hskip1em@>@!was_mem_end,@!was_lo_max,@!was_hi_min: pointer;
- {previous |mem_end|, |lo_mem_max|,and |hi_mem_min|}
-@t\hskip1em@>@!panicking:boolean; {do we want to check memory constantly?}
-gubed
-
-@ @<Set initial...@>=
-@!debug was_mem_end:=mem_min; {indicate that everything was previously free}
-was_lo_max:=mem_min; was_hi_min:=mem_max;
-panicking:=false;
-gubed
-
-@ 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.
-
-@p @!debug procedure check_mem(@!print_locs : boolean);
-label done1,done2,done3; {loop exits}
-var @!p,@!q,@!r:pointer; {current locations of interest in |mem|}
-@!clobbered:boolean; {is something amiss?}
-begin for p:=mem_min to lo_mem_max do free[p]:=false; {you can probably
- do this faster}
-for p:=hi_mem_min to mem_end do 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 then @<Print newly busy locations@>;
-for p:=mem_min to lo_mem_max do was_free[p]:=free[p];
-for p:=hi_mem_min to mem_end do was_free[p]:=free[p];
- {|was_free:=free| might be faster}
-was_mem_end:=mem_end; was_lo_max:=lo_mem_max; was_hi_min:=hi_mem_min;
-end;
-gubed
-
-@ @<Check single-word...@>=
-p:=avail; q:=null; clobbered:=false;
-while p<>null do
- begin if (p>mem_end)or(p<hi_mem_min) then clobbered:=true
- else if free[p] then clobbered:=true;
- if clobbered then
- begin print_nl("AVAIL list clobbered at ");
-@.AVAIL list clobbered...@>
- print_int(q); goto done1;
- end;
- free[p]:=true; q:=p; p:=link(q);
- end;
-done1:
-
-@ @<Check variable-size...@>=
-p:=rover; q:=null; clobbered:=false;
-repeat if (p>=lo_mem_max)or(p<mem_min) then clobbered:=true
- else if (rlink(p)>=lo_mem_max)or(rlink(p)<mem_min) then clobbered:=true
- else if not(is_empty(p))or(node_size(p)<2)or@|
- (p+node_size(p)>lo_mem_max)or@| (llink(rlink(p))<>p) then clobbered:=true;
- if clobbered then
- begin print_nl("Double-AVAIL list clobbered at ");
-@.Double-AVAIL list clobbered...@>
- print_int(q); goto done2;
- end;
-for q:=p to p+node_size(p)-1 do {mark all locations free}
- begin if free[q] then
- begin print_nl("Doubly free location at ");
-@.Doubly free location...@>
- print_int(q); goto done2;
- end;
- free[q]:=true;
- end;
-q:=p; p:=rlink(p);
-until p=rover;
-done2:
-
-@ @<Check flags...@>=
-p:=mem_min;
-while p<=lo_mem_max do {node |p| should not be empty}
- begin if is_empty(p) then
- begin print_nl("Bad flag at "); print_int(p);
-@.Bad flag...@>
- end;
- while (p<=lo_mem_max) and not free[p] do incr(p);
- while (p<=lo_mem_max) and free[p] do incr(p);
- end
-
-@ @<Print newly busy...@>=
-begin @<Do intialization required before printing new busy locations@>;
-print_nl("New busy locs:");
-@.New busy locs@>
-for p:=mem_min to lo_mem_max do
- if not free[p] and ((p>was_lo_max) or was_free[p]) then
- @<Indicate that |p| is a new busy location@>;
-for p:=hi_mem_min to mem_end do
- if not free[p] and
- ((p<was_hi_min) or (p>was_mem_end) or was_free[p]) then
- @<Indicate that |p| is a new busy location@>;
-@<Finish printing new busy locations@>;
-end
-
-@ 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@>=
-begin if p>q+1 then
- begin if q>r then
- begin print(".."); print_int(q);
- end;
- print_char(" "); print_int(p);
- r:=p;
- end;
-q:=p;
-end
-
-@ @<Do intialization required before printing new busy locations@>=
-q:=mem_max; r:=mem_max
-
-@ @<Finish printing new busy locations@>=
-if q>r then
- begin print(".."); print_int(q);
- end
-
-@ 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
-@^dirty \PASCAL@>
-undefined in \PASCAL, 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.
-
-@p @!debug procedure search_mem(@!p:pointer); {look for pointers to |p|}
-var @!q:integer; {current position being searched}
-begin for q:=mem_min to lo_mem_max do
- begin if link(q)=p then
- begin print_nl("LINK("); print_int(q); print_char(")");
- end;
- if info(q)=p then
- begin print_nl("INFO("); print_int(q); print_char(")");
- end;
- end;
-for q:=hi_mem_min to mem_end do
- begin if link(q)=p then
- begin print_nl("LINK("); print_int(q); print_char(")");
- end;
- if info(q)=p then
- begin print_nl("INFO("); print_int(q); print_char(")");
- end;
- end;
-@<Search |eqtb| for equivalents equal to |p|@>;
-end;
-gubed
-
-@* \[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 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==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...@>=
-@!command_code=1..max_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
-|>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 vacuous=1 {no expression was present}
-@d boolean_type=2 {\&{boolean} with a known value}
-@d unknown_boolean=boolean_type+unknown_tag
-@d string_type=4 {\&{string} with a known value}
-@d unknown_string=string_type+unknown_tag
-@d pen_type=6 {\&{pen} with a known value}
-@d unknown_pen=pen_type+unknown_tag
-@d path_type=8 {\&{path} with a known value}
-@d unknown_path=path_type+unknown_tag
-@d picture_type=10 {\&{picture} with a known value}
-@d unknown_picture=picture_type+unknown_tag
-@d transform_type=12 {\&{transform} variable or capsule}
-@d color_type=13 {\&{color} variable or capsule}
-@d cmykcolor_type=14 {\&{cmykcolor} variable or capsule}
-@d pair_type=15 {\&{pair} variable or capsule}
-@d numeric_type=16 {variable that has been declared \&{numeric} but not used}
-@d known=17 {\&{numeric} with a known value}
-@d dependent=18 {a linear combination with |fraction| coefficients}
-@d proto_dependent=19 {a linear combination with |scaled| coefficients}
-@d independent=20 {\&{numeric} with unknown value}
-@d token_list=21 {variable name or suffix argument or text argument}
-@d structured=22 {variable with subscripts and attributes}
-@d unsuffixed_macro=23 {variable defined with \&{vardef} but no \.{\AT!\#}}
-@d suffixed_macro=24 {variable defined with \&{vardef} and \.{\AT!\#}}
-@#
-@d unknown_types==unknown_boolean,unknown_string,
- unknown_pen,unknown_picture,unknown_path
-
-@<Basic printing procedures@>=
-procedure print_type(@!t:small_number);
-begin case t of
-vacuous:print("vacuous");
-boolean_type:print("boolean");
-unknown_boolean:print("unknown boolean");
-string_type:print("string");
-unknown_string:print("unknown string");
-pen_type:print("pen");
-unknown_pen:print("unknown pen");
-path_type:print("path");
-unknown_path:print("unknown path");
-picture_type:print("picture");
-unknown_picture:print("unknown picture");
-transform_type:print("transform");
-color_type:print("color");
-cmykcolor_type:print("cmykcolor");
-pair_type:print("pair");
-known:print("known numeric");
-dependent:print("dependent");
-proto_dependent:print("proto-dependent");
-numeric_type:print("numeric");
-independent:print("independent");
-token_list:print("token list");
-structured:print("structured");
-unsuffixed_macro:print("unsuffixed macro");
-suffixed_macro:print("suffixed macro");
-othercases print("undefined")
-endcases;
-end;
-
-@ 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.
-
-@d root=0 {|name_type| at the top level of a variable}
-@d saved_root=1 {same, when the variable has been saved}
-@d structured_root=2 {|name_type| where a |structured| branch occurs}
-@d subscr=3 {|name_type| in a subscript node}
-@d attr=4 {|name_type| in an attribute node}
-@d x_part_sector=5 {|name_type| in the \&{xpart} of a node}
-@d y_part_sector=6 {|name_type| in the \&{ypart} of a node}
-@d xx_part_sector=7 {|name_type| in the \&{xxpart} of a node}
-@d xy_part_sector=8 {|name_type| in the \&{xypart} of a node}
-@d yx_part_sector=9 {|name_type| in the \&{yxpart} of a node}
-@d yy_part_sector=10 {|name_type| in the \&{yypart} of a node}
-@d red_part_sector=11 {|name_type| in the \&{redpart} of a node}
-@d green_part_sector=12 {|name_type| in the \&{greenpart} of a node}
-@d blue_part_sector=13 {|name_type| in the \&{bluepart} of a node}
-@d cyan_part_sector=14 {|name_type| in the \&{redpart} of a node}
-@d magenta_part_sector=15 {|name_type| in the \&{greenpart} of a node}
-@d yellow_part_sector=16 {|name_type| in the \&{bluepart} of a node}
-@d black_part_sector=17 {|name_type| in the \&{greenpart} of a node}
-@d grey_part_sector=18 {|name_type| in the \&{bluepart} of a node}
-@d capsule=19 {|name_type| in stashed-away subexpressions}
-@d token=20 {|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., |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..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}}
-
-@p procedure print_op(@!c:quarterword);
-begin if c<=numeric_type then print_type(c)
-else case c of
-true_code:print("true");
-false_code:print("false");
-null_picture_code:print("nullpicture");
-null_pen_code:print("nullpen");
-job_name_op:print("jobname");
-read_string_op:print("readstring");
-pen_circle:print("pencircle");
-normal_deviate:print("normaldeviate");
-read_from_op:print("readfrom");
-close_from_op:print("closefrom");
-odd_op:print("odd");
-known_op:print("known");
-unknown_op:print("unknown");
-not_op:print("not");
-decimal:print("decimal");
-reverse:print("reverse");
-make_path_op:print("makepath");
-make_pen_op:print("makepen");
-oct_op:print("oct");
-hex_op:print("hex");
-ASCII_op:print("ASCII");
-char_op:print("char");
-length_op:print("length");
-turning_op:print("turningnumber");
-x_part:print("xpart");
-y_part:print("ypart");
-xx_part:print("xxpart");
-xy_part:print("xypart");
-yx_part:print("yxpart");
-yy_part:print("yypart");
-red_part:print("redpart");
-green_part:print("greenpart");
-blue_part:print("bluepart");
-cyan_part:print("cyanpart");
-magenta_part:print("magentapart");
-yellow_part:print("yellowpart");
-black_part:print("blackpart");
-grey_part:print("greypart");
-color_model_part:print("colormodel");
-font_part:print("fontpart");
-text_part:print("textpart");
-path_part:print("pathpart");
-pen_part:print("penpart");
-dash_part:print("dashpart");
-sqrt_op:print("sqrt");
-m_exp_op:print("mexp");
-m_log_op:print("mlog");
-sin_d_op:print("sind");
-cos_d_op:print("cosd");
-floor_op:print("floor");
-uniform_deviate:print("uniformdeviate");
-char_exists_op:print("charexists");
-font_size:print("fontsize");
-ll_corner_op:print("llcorner");
-lr_corner_op:print("lrcorner");
-ul_corner_op:print("ulcorner");
-ur_corner_op:print("urcorner");
-arc_length:print("arclength");
-angle_op:print("angle");
-cycle_op:print("cycle");
-filled_op:print("filled");
-stroked_op:print("stroked");
-textual_op:print("textual");
-clipped_op:print("clipped");
-bounded_op:print("bounded");
-plus:print_char("+");
-minus:print_char("-");
-times:print_char("*");
-over:print_char("/");
-pythag_add:print("++");
-pythag_sub:print("+-+");
-or_op:print("or");
-and_op:print("and");
-less_than:print_char("<");
-less_or_equal:print("<=");
-greater_than:print_char(">");
-greater_or_equal:print(">=");
-equal_to:print_char("=");
-unequal_to:print("<>");
-concatenate:print("&");
-rotated_by:print("rotated");
-slanted_by:print("slanted");
-scaled_by:print("scaled");
-shifted_by:print("shifted");
-transformed_by:print("transformed");
-x_scaled:print("xscaled");
-y_scaled:print("yscaled");
-z_scaled:print("zscaled");
-in_font:print("infont");
-intersect:print("intersectiontimes");
-substring_of:print("substring");
-subpath_of:print("subpath");
-direction_time_of:print("directiontime");
-point_of:print("point");
-precontrol_of:print("precontrol");
-postcontrol_of:print("postcontrol");
-pen_offset_of:print("penoffset");
-arc_time_of:print("arctime");
-mp_version:print("mpversion");
-othercases print("..")
-endcases;
-end;
-
-@ \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.
-
-@d tracing_titles=1 {show titles online when they appear}
-@d tracing_equations=2 {show each variable when it becomes known}
-@d tracing_capsules=3 {show capsules too}
-@d tracing_choices=4 {show the control points chosen for paths}
-@d tracing_specs=5 {show path subdivision prior to filling with polygonal a pen}
-@d tracing_commands=6 {show commands and operations before they are performed}
-@d tracing_restores=7 {show when a variable or internal is restored}
-@d tracing_macros=8 {show macros before they are expanded}
-@d tracing_output=9 {show digitized edges as they are output}
-@d tracing_stats=10 {show memory usage at end of job}
-@d tracing_lost_chars=11 {show characters that aren't \&{infont}}
-@d tracing_online=12 {show long diagnostics on terminal and in the log file}
-@d year=13 {the current year (e.g., 1984)}
-@d month=14 {the current month (e.g., 3 $\equiv$ March)}
-@d day=15 {the current day of the month}
-@d time=16 {the number of minutes past midnight when this job started}
-@d char_code=17 {the number of the next character to be output}
-@d char_ext=18 {the extension code of the next character to be output}
-@d char_wd=19 {the width of the next character to be output}
-@d char_ht=20 {the height of the next character to be output}
-@d char_dp=21 {the depth of the next character to be output}
-@d char_ic=22 {the italic correction of the next character to be output}
-@d design_size=23 {the unit of measure used for |char_wd..char_ic|, in points}
-@d pausing=24 {positive to display lines on the terminal before they are read}
-@d showstopping=25 {positive to stop after each \&{show} command}
-@d fontmaking=26 {positive if font metric output is to be produced}
-@d linejoin=27 {as in \ps: 0 for mitered, 1 for round, 2 for beveled}
-@d linecap=28 {as in \ps: 0 for butt, 1 for round, 2 for square}
-@d miterlimit=29 {controls miter length as in \ps}
-@d warning_check=30 {controls error message when variable value is large}
-@d boundary_char=31 {the right boundary character for ligatures}
-@d prologues=32 {positive to output conforming PostScript using built-in fonts}
-@d true_corners=33 {positive to make \&{llcorner} etc. ignore \&{setbounds}}
-@d default_color_model=34 {the default color model for unspecified items}
-@d restore_clip_color=35
-@d mpprocset=36 {wether or not create PostScript command shortcuts}
-@d gtroffmode=37 {whether the user specified |-troff| on the command line}
-@d max_given_internal=37
-
-@<Glob...@>=
-@!internal:array[1..max_internal] of scaled;
- {the values of internal quantities}
-@!int_name:array[1..max_internal] of str_number;
- {their names}
-@!int_ptr:max_given_internal..max_internal;
- {the maximum internal quantity defined so far}
-
-@ @<Set init...@>=
-for k:=1 to max_given_internal do internal[k]:=0;
-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@>=
-primitive("tracingtitles",internal_quantity,tracing_titles);@/
-@!@:tracingtitles_}{\&{tracingtitles} primitive@>
-primitive("tracingequations",internal_quantity,tracing_equations);@/
-@!@:tracing_equations_}{\&{tracingequations} primitive@>
-primitive("tracingcapsules",internal_quantity,tracing_capsules);@/
-@!@:tracing_capsules_}{\&{tracingcapsules} primitive@>
-primitive("tracingchoices",internal_quantity,tracing_choices);@/
-@!@:tracing_choices_}{\&{tracingchoices} primitive@>
-primitive("tracingspecs",internal_quantity,tracing_specs);@/
-@!@:tracing_specs_}{\&{tracingspecs} primitive@>
-primitive("tracingcommands",internal_quantity,tracing_commands);@/
-@!@:tracing_commands_}{\&{tracingcommands} primitive@>
-primitive("tracingrestores",internal_quantity,tracing_restores);@/
-@!@:tracing_restores_}{\&{tracingrestores} primitive@>
-primitive("tracingmacros",internal_quantity,tracing_macros);@/
-@!@:tracing_macros_}{\&{tracingmacros} primitive@>
-primitive("tracingoutput",internal_quantity,tracing_output);@/
-@!@:tracing_output_}{\&{tracingoutput} primitive@>
-primitive("tracingstats",internal_quantity,tracing_stats);@/
-@!@:tracing_stats_}{\&{tracingstats} primitive@>
-primitive("tracinglostchars",internal_quantity,tracing_lost_chars);@/
-@!@:tracing_lost_chars_}{\&{tracinglostchars} primitive@>
-primitive("tracingonline",internal_quantity,tracing_online);@/
-@!@:tracing_online_}{\&{tracingonline} primitive@>
-primitive("year",internal_quantity,year);@/
-@!@:year_}{\&{year} primitive@>
-primitive("month",internal_quantity,month);@/
-@!@:month_}{\&{month} primitive@>
-primitive("day",internal_quantity,day);@/
-@!@:day_}{\&{day} primitive@>
-primitive("time",internal_quantity,time);@/
-@!@:time_}{\&{time} primitive@>
-primitive("charcode",internal_quantity,char_code);@/
-@!@:char_code_}{\&{charcode} primitive@>
-primitive("charext",internal_quantity,char_ext);@/
-@!@:char_ext_}{\&{charext} primitive@>
-primitive("charwd",internal_quantity,char_wd);@/
-@!@:char_wd_}{\&{charwd} primitive@>
-primitive("charht",internal_quantity,char_ht);@/
-@!@:char_ht_}{\&{charht} primitive@>
-primitive("chardp",internal_quantity,char_dp);@/
-@!@:char_dp_}{\&{chardp} primitive@>
-primitive("charic",internal_quantity,char_ic);@/
-@!@:char_ic_}{\&{charic} primitive@>
-primitive("designsize",internal_quantity,design_size);@/
-@!@:design_size_}{\&{designsize} primitive@>
-primitive("pausing",internal_quantity,pausing);@/
-@!@:pausing_}{\&{pausing} primitive@>
-primitive("showstopping",internal_quantity,showstopping);@/
-@!@:showstopping_}{\&{showstopping} primitive@>
-primitive("fontmaking",internal_quantity,fontmaking);@/
-@!@:fontmaking_}{\&{fontmaking} primitive@>
-primitive("linejoin",internal_quantity,linejoin);@/
-@!@:linejoin_}{\&{linejoin} primitive@>
-primitive("linecap",internal_quantity,linecap);@/
-@!@:linecap_}{\&{linecap} primitive@>
-primitive("miterlimit",internal_quantity,miterlimit);@/
-@!@:miterlimit_}{\&{miterlimit} primitive@>
-primitive("warningcheck",internal_quantity,warning_check);@/
-@!@:warning_check_}{\&{warningcheck} primitive@>
-primitive("boundarychar",internal_quantity,boundary_char);@/
-@!@:boundary_char_}{\&{boundarychar} primitive@>
-primitive("prologues",internal_quantity,prologues);@/
-@!@:prologues_}{\&{prologues} primitive@>
-primitive("truecorners",internal_quantity,true_corners);@/
-@!@:true_corners_}{\&{truecorners} primitive@>
-primitive("mpprocset",internal_quantity,mpprocset);@/
-@!@:mpprocset_}{\&{mpprocset} primitive@>
-primitive("troffmode",internal_quantity,gtroffmode);@/
-@!@:troffmode_}{\&{troffmode} primitive@>
-primitive("defaultcolormodel",internal_quantity,default_color_model);@/
-@!@:default_color_model_}{\&{defaultcolormodel} primitive@>
-primitive("restoreclipcolor",internal_quantity,restore_clip_color);@/
-@!@: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.
-
-@d no_model=1
-@d grey_model=3
-@d rgb_model=5
-@d cmyk_model=7
-@d uninitialized_model=9
-
-@<Initialize table entries (done by \.{INIMP} only)@>=
-internal[default_color_model]:=(rgb_model*unity);
-internal[restore_clip_color]:=unity;
-
-@ Well, we do have to list the names one more time, for use in symbolic
-printouts.
-
-@<Initialize table...@>=
-int_name[tracing_titles]:="tracingtitles";
-int_name[tracing_equations]:="tracingequations";
-int_name[tracing_capsules]:="tracingcapsules";
-int_name[tracing_choices]:="tracingchoices";
-int_name[tracing_specs]:="tracingspecs";
-int_name[tracing_commands]:="tracingcommands";
-int_name[tracing_restores]:="tracingrestores";
-int_name[tracing_macros]:="tracingmacros";
-int_name[tracing_output]:="tracingoutput";
-int_name[tracing_stats]:="tracingstats";
-int_name[tracing_lost_chars]:="tracinglostchars";
-int_name[tracing_online]:="tracingonline";
-int_name[year]:="year";
-int_name[month]:="month";
-int_name[day]:="day";
-int_name[time]:="time";
-int_name[char_code]:="charcode";
-int_name[char_ext]:="charext";
-int_name[char_wd]:="charwd";
-int_name[char_ht]:="charht";
-int_name[char_dp]:="chardp";
-int_name[char_ic]:="charic";
-int_name[design_size]:="designsize";
-int_name[pausing]:="pausing";
-int_name[showstopping]:="showstopping";
-int_name[fontmaking]:="fontmaking";
-int_name[linejoin]:="linejoin";
-int_name[linecap]:="linecap";
-int_name[miterlimit]:="miterlimit";
-int_name[warning_check]:="warningcheck";
-int_name[boundary_char]:="boundarychar";
-int_name[prologues]:="prologues";
-int_name[true_corners]:="truecorners";
-int_name[default_color_model]:="defaultcolormodel";
-int_name[mpprocset]:="mpprocset";
-int_name[gtroffmode]:="troffmode";
-int_name[restore_clip_color]:="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@>
-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.
-
-Note that the values are |scaled| integers. Hence \MP\ can no longer
-be used after the year 32767.
-
-@p procedure fix_date_and_time;
-begin internal[time]:=12*60*unity; {minutes since midnight}
-internal[day]:=4*unity; {fourth day of the month}
-internal[month]:=7*unity; {seventh month of the year}
-internal[year]:=1776*unity; {Anno Domini}
-end;
-
-@ \MP\ is occasionally supposed to print diagnostic information that
-goes only into the transcript file, unless |tracing_online| is positive.
-Now that we have defined |tracing_online| we can define
-two routines that adjust the destination of print commands:
-
-@<Basic printing...@>=
-@<Declare a function called |true_line|@>@;
-procedure begin_diagnostic; {prepare to do some tracing}
-begin old_setting:=selector;
-if selector=ps_file_only then selector:=non_ps_setting;
-if(internal[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:=old_setting;
-end;
-
-@ The global variable |non_ps_setting| is initialized when it is time to print
-on |ps_file|.
-
-@<Glob...@>=
-@!old_setting,@!non_ps_setting:0..max_selector;
-
-@ 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...@>=
-procedure print_diagnostic(@!s,@!t:str_number;@!nuline:boolean);
-begin begin_diagnostic;
-if nuline then print_nl(s)@+else print(s);
-print(" at line "); print_int(true_line);
-print(t); print_char(":");
-end;
-
-@ 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,6,7,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...@>=
-@!char_class:array[ASCII_code] of 0..max_class; {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 init...@>=
-for k:="0" to "9" do char_class[k]:=digit_class;
-char_class["."]:=period_class;
-char_class[" "]:=space_class;
-char_class["%"]:=percent_class;
-char_class[""""]:=string_class;@/
-char_class[","]:=5;
-char_class[";"]:=6;
-char_class["("]:=7;
-char_class[")"]:=right_paren_class;
-for k:="A" to "Z" do char_class[k]:=letter_class;
-for k:="a" to "z" do char_class[k]:=letter_class;
-char_class["_"]:=letter_class;@/
-char_class["<"]:=10;
-char_class["="]:=10;
-char_class[">"]:=10;
-char_class[":"]:=10;
-char_class["|"]:=10;@/
-char_class["`"]:=11;
-char_class["'"]:=11;@/
-char_class["+"]:=12;
-char_class["-"]:=12;@/
-char_class["/"]:=13;
-char_class["*"]:=13;
-char_class["\"]:=13;@/
-char_class["!"]:=14;
-char_class["?"]:=14;@/
-char_class["#"]:=15;
-char_class["&"]:=15;
-char_class["@@"]:=15;
-char_class["$"]:=15;@/
-char_class["^"]:=16;
-char_class["~"]:=16;@/
-char_class["["]:=left_bracket_class;
-char_class["]"]:=right_bracket_class;@/
-char_class["{"]:=19;
-char_class["}"]:=19;@/
-for k:=0 to " "-1 do char_class[k]:=invalid_class;
-for k:=127 to 255 do 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(#) == hash[#].lh {link for coalesced lists}
-@d text(#) == hash[#].rh {string number for symbolic token name}
-@d eq_type(#) == eqtb[#].lh {the current ``meaning'' of a symbolic token}
-@d equiv(#) == eqtb[#].rh {parametric part of a token's meaning}
-@d hash_base=257 {hashing actually starts here}
-@d hash_is_full == (hash_used=hash_base) {are all positions occupied?}
-
-@<Glob...@>=
-@!hash_used:pointer; {allocation pointer for |hash|}
-@!st_count:integer; {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+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...@>=
-@!hash: array[1..hash_end] of two_halves; {the hash table}
-@!eqtb: array[1..hash_end] of two_halves; {the equivalents}
-
-@ @<Set init...@>=
-next(1):=0; text(1):=0; eq_type(1):=tag_token; equiv(1):=null;
-for k:=2 to hash_end do
- begin hash[k]:=hash[1]; eqtb[k]:=eqtb[1];
- end;
-
-@ @<Initialize table entries...@>=
-hash_used:=frozen_inaccessible; {nothing is used}
-st_count:=0;@/
-text(frozen_bad_vardef):="a bad variable";
-text(frozen_etex):="etex";
-text(frozen_mpx_break):="mpxbreak";
-text(frozen_fi):="fi";
-text(frozen_end_group):="endgroup";
-text(frozen_end_def):="enddef";
-text(frozen_end_for):="endfor";@/
-text(frozen_semicolon):=";";
-text(frozen_colon):=":";
-text(frozen_slash):="/";
-text(frozen_left_bracket):="[";
-text(frozen_right_delimiter):=")";@/
-text(frozen_inaccessible):=" INACCESSIBLE";@/
-eq_type(frozen_right_delimiter):=right_delimiter;
-
-@ @<Check the ``constant'' values...@>=
-if hash_end+max_internal>max_halfword then 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.
-
-@p function id_lookup(@!j,@!l:integer):pointer; {search the hash table}
-label found; {go here when you've found it}
-var @!h:integer; {hash code}
-@!p:pointer; {index in |hash| array}
-@!k:pointer; {index in |buffer| array}
-begin if l=1 then @<Treat special case of length 1 and |goto found|@>;
-@<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
- @<Insert a new symbolic token after |p|, then
- make |p| point to it and |goto found|@>;
- p:=next(p);
- end;
-found: id_lookup:=p;
-end;
-
-@ @<Treat special case of length 1...@>=
-begin p:=buffer[j]+1; text(p):=p-1; goto found;
-end
-
-@ @<Insert a new symbolic...@>=
-begin if text(p)>0 then
- begin repeat if hash_is_full then
- overflow("hash size",hash_size);
-@:MetaPost 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);
-for k:=j to j+l-1 do append_char(buffer[k]);
-text(p):=make_string; str_ref[text(p)]:=max_str_ref;
-@!stat incr(st_count);@+tats@;@/
-goto found;
-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
-
-@ @<Search |eqtb| for equivalents equal to |p|@>=
-for q:=1 to hash_end do
- begin if equiv(q)=p then
- begin print_nl("EQUIV("); print_int(q); print_char(")");
- end;
- end
-
-@ 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.
-
-@p @!init procedure primitive(@!s:str_number;@!c:halfword;@!o:halfword);
-var @!k:pool_pointer; {index into |str_pool|}
-@!j:small_number; {index into |buffer|}
-@!l:small_number; {length of the string}
-begin k:=str_start[s]; l:=str_stop(s)-k;
- {we will move |s| into the (empty) |buffer|}
-for j:=0 to l-1 do buffer[j]:=so(str_pool[k+j]);
-cur_sym:=id_lookup(0,l);@/
-if s>=256 then {we don't want to have the string twice}
- begin flush_string(text(cur_sym)); text(cur_sym):=s;
- end;
-eq_type(cur_sym):=c; equiv(cur_sym):=o;
-end;
-tini
-
-@ 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@>=
-primitive("..",path_join,0);@/
-@!@:.._}{\.{..} primitive@>
-primitive("[",left_bracket,0); eqtb[frozen_left_bracket]:=eqtb[cur_sym];@/
-@!@:[ }{\.{[} primitive@>
-primitive("]",right_bracket,0);@/
-@!@:] }{\.{]} primitive@>
-primitive("}",right_brace,0);@/
-@!@:]]}{\.{\char`\}} primitive@>
-primitive("{",left_brace,0);@/
-@!@:][}{\.{\char`\{} primitive@>
-primitive(":",colon,0); eqtb[frozen_colon]:=eqtb[cur_sym];@/
-@!@:: }{\.{:} primitive@>
-primitive("::",double_colon,0);@/
-@!@::: }{\.{::} primitive@>
-primitive("||:",bchar_label,0);@/
-@!@:::: }{\.{\char'174\char'174:} primitive@>
-primitive(":=",assignment,0);@/
-@!@::=_}{\.{:=} primitive@>
-primitive(",",comma,0);@/
-@!@:, }{\., primitive@>
-primitive(";",semicolon,0); eqtb[frozen_semicolon]:=eqtb[cur_sym];@/
-@!@:; }{\.; primitive@>
-primitive("\",relax,0);@/
-@!@:]]\\}{\.{\char`\\} primitive@>
-@#
-primitive("addto",add_to_command,0);@/
-@!@:add_to_}{\&{addto} primitive@>
-primitive("atleast",at_least,0);@/
-@!@:at_least_}{\&{atleast} primitive@>
-primitive("begingroup",begin_group,0); bg_loc:=cur_sym;@/
-@!@:begin_group_}{\&{begingroup} primitive@>
-primitive("controls",controls,0);@/
-@!@:controls_}{\&{controls} primitive@>
-primitive("curl",curl_command,0);@/
-@!@:curl_}{\&{curl} primitive@>
-primitive("delimiters",delimiters,0);@/
-@!@:delimiters_}{\&{delimiters} primitive@>
-primitive("endgroup",end_group,0);
- eqtb[frozen_end_group]:=eqtb[cur_sym]; eg_loc:=cur_sym;@/
-@!@:endgroup_}{\&{endgroup} primitive@>
-primitive("everyjob",every_job_command,0);@/
-@!@:every_job_}{\&{everyjob} primitive@>
-primitive("exitif",exit_test,0);@/
-@!@:exit_if_}{\&{exitif} primitive@>
-primitive("expandafter",expand_after,0);@/
-@!@:expand_after_}{\&{expandafter} primitive@>
-primitive("interim",interim_command,0);@/
-@!@:interim_}{\&{interim} primitive@>
-primitive("let",let_command,0);@/
-@!@:let_}{\&{let} primitive@>
-primitive("newinternal",new_internal,0);@/
-@!@:new_internal_}{\&{newinternal} primitive@>
-primitive("of",of_token,0);@/
-@!@:of_}{\&{of} primitive@>
-primitive("randomseed",random_seed,0);@/
-@!@:random_seed_}{\&{randomseed} primitive@>
-primitive("save",save_command,0);@/
-@!@:save_}{\&{save} primitive@>
-primitive("scantokens",scan_tokens,0);@/
-@!@:scan_tokens_}{\&{scantokens} primitive@>
-primitive("shipout",ship_out_command,0);@/
-@!@:ship_out_}{\&{shipout} primitive@>
-primitive("skipto",skip_to,0);@/
-@!@:skip_to_}{\&{skipto} primitive@>
-primitive("special",special_command,0);
-@!@:special}{\&{special} primitive@>
-primitive("fontmapfile",special_command,1);
-@!@:fontmapfile}{\&{fontmapfile} primitive@>
-primitive("fontmapline",special_command,2);
-@!@:fontmapline}{\&{fontmapline} primitive@>
-primitive("step",step_token,0);@/
-@!@:step_}{\&{step} primitive@>
-primitive("str",str_op,0);@/
-@!@:str_}{\&{str} primitive@>
-primitive("tension",tension,0);@/
-@!@:tension_}{\&{tension} primitive@>
-primitive("to",to_token,0);@/
-@!@:to_}{\&{to} primitive@>
-primitive("until",until_token,0);@/
-@!@:until_}{\&{until} primitive@>
-primitive("within",within_token,0);@/
-@!@:within_}{\&{within} primitive@>
-primitive("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@>=
-add_to_command:print("addto");
-assignment:print(":=");
-at_least:print("atleast");
-bchar_label:print("||:");
-begin_group:print("begingroup");
-colon:print(":");
-comma:print(",");
-controls:print("controls");
-curl_command:print("curl");
-delimiters:print("delimiters");
-double_colon:print("::");
-end_group:print("endgroup");
-every_job_command:print("everyjob");
-exit_test:print("exitif");
-expand_after:print("expandafter");
-interim_command:print("interim");
-left_brace:print("{");
-left_bracket:print("[");
-let_command:print("let");
-new_internal:print("newinternal");
-of_token:print("of");
-path_join:print("..");
-random_seed:print("randomseed");
-relax:print_char("\");
-right_brace:print("}");
-right_bracket:print("]");
-save_command:print("save");
-scan_tokens:print("scantokens");
-semicolon:print(";");
-ship_out_command:print("shipout");
-skip_to:print("skipto");
-special_command: if m=2 then print("fontmapline") else
- if m=1 then print("fontmapfile") else
- print("special");
-step_token:print("step");
-str_op:print("str");
-tension:print("tension");
-to_token:print("to");
-until_token:print("until");
-within_token:print("within");
-write_command:print("write");
-
-@ 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 |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(#) == mem[#].hh.b0 {identifies what kind of value this is}
-@d name_type(#) == mem[#].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(#)==#+1 {the word that contains the |value| field}
-@d value(#)==mem[value_loc(#)].int {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+param_size {code for the zeroth \&{suffix} parameter}
-@d text_base==suffix_base+param_size {code for the zeroth \&{text} parameter}
-
-@<Check the ``constant''...@>=
-if text_base+param_size>max_halfword then 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.
-
-@p function new_num_tok(@!v:scaled):pointer;
-var @!p:pointer; {the new node}
-begin p:=get_node(token_node_size); value(p):=v;
-type(p):=known; name_type(p):=token; new_num_tok:=p;
-end;
-
-@ 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.
-
-@p procedure@?token_recycle; forward;@t\2@>@;@/
-procedure flush_token_list(@!p:pointer);
-var @!q:pointer; {the node being recycled}
-begin while p<>null do
- begin q:=p; p:=link(p);
- if q>=hi_mem_min then free_avail(q)
- else begin case type(q) of
- vacuous,boolean_type,known:do_nothing;
- string_type:delete_str_ref(value(q));
- unknown_types,pen_type,path_type,picture_type,pair_type,color_type,
- cmykcolor_type,transform_type,dependent,proto_dependent,independent:
- begin g_pointer:=q; token_recycle;
- end;
- othercases confusion("token")
-@:this can't happen token}{\quad token@>
- endcases;@/
- free_node(q,token_node_size);
- end;
- end;
-end;
-
-@ 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|@>=
-procedure@?print_capsule; forward; @t\2@>@;@/
-procedure show_token_list(@!p,@!q:integer;@!l,@!null_tally:integer);
-label exit;
-var @!class,@!c:small_number; {the |char_class| of previous and new tokens}
-@!r,@!v:integer; {temporary registers}
-begin class:=percent_class;
-tally:=null_tally;
-while (p<>null) and (tally<l) do
- begin if p=q then @<Do magic computation@>;
- @<Display token |p| and set |c| to its class;
- but |return| if there are problems@>;
- class:=c; p:=link(p);
- end;
-if p<>null then print(" ETC.");
-@.ETC@>
-exit:
-end;
-
-@ @<Display token |p| and set |c| to its class...@>=
-c:=letter_class; {the default}
-if (p<mem_min)or(p>mem_end) then
- begin print(" CLOBBERED"); return;
-@.CLOBBERED@>
- end;
-if p<hi_mem_min then @<Display two-word token@>
-else begin r:=info(p);
- if r>=expr_base then @<Display a parameter token@>
- else if r<1 then
- if r=0 then @<Display a collective subscript@>
- else print(" IMPOSSIBLE")
-@.IMPOSSIBLE@>
- else begin r:=text(r);
- if (r<0)or(r>max_str_ptr) then print(" NONEXISTENT")
-@.NONEXISTENT@>
- else @<Print string |r| as a symbolic token
- and set |c| to its class@>;
- end;
- end
-
-@ @<Display two-word token@>=
-if name_type(p)=token then
- if type(p)=known then @<Display a numeric token@>
- else if type(p)<>string_type then print(" BAD")
-@.BAD@>
- else begin print_char(""""); print(value(p)); print_char("""");
- c:=string_class;
- end
-else if (name_type(p)<>capsule)or(type(p)<vacuous)or(type(p)>independent) then
- print(" BAD")
-else begin g_pointer:=p; print_capsule; c:=right_paren_class;
- end
-
-@ @<Display a numeric token@>=
-begin if class=digit_class then print_char(" ");
-v:=value(p);
-if v<0 then
- begin if class=left_bracket_class then print_char(" ");
- print_char("["); print_scaled(v); print_char("]");
- c:=right_bracket_class;
- end
-else begin print_scaled(v); c:=digit_class;
- end;
-end
-
-@ 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@>=
-begin if class=left_bracket_class then print_char(" ");
-print("[]"); c:=right_bracket_class;
-end
-
-@ @<Display a parameter token@>=
-begin if r<suffix_base then
- begin print("(EXPR"); r:=r-(expr_base);
-@.EXPR@>
- end
-else if r<text_base then
- begin print("(SUFFIX"); r:=r-(suffix_base);
-@.SUFFIX@>
- end
-else begin print("(TEXT"); r:=r-(text_base);
-@.TEXT@>
- end;
-print_int(r); print_char(")"); c:=right_paren_class;
-end
-
-@ @<Print string |r| as a symbolic token...@>=
-begin c:=char_class[so(str_pool[str_start[r]])];
-if c=class then
- case c of
- letter_class:print_char(".");
- isolated_classes:do_nothing;
- othercases print_char(" ")
- endcases;
-print(r);
-end
-
-@ The following procedures have been declared |forward| with no parameters,
-because the author dislikes \PASCAL's convention about |forward| procedures
-with parameters. It was necessary to do something, because |show_token_list|
-is recursive (although the recursion is limited to one level), and because
-|flush_token_list| is syntactically (but not semantically) recursive.
-@^recursion@>
-
-@<Declare miscellaneous procedures that were declared |forward|@>=
-procedure print_capsule;
-begin print_char("("); print_exp(g_pointer,0); print_char(")");
-end;
-@#
-procedure token_recycle;
-begin recycle_value(g_pointer);
-end;
-
-@ @<Glob...@>=
-@!g_pointer:pointer; {(global) parameter to the |forward| procedures}
-
-@ 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(#)==incr(ref_count(#)) {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}
-
-@p procedure delete_mac_ref(@!p:pointer);
- {|p| points to the reference count of a macro list that is
- losing one reference}
-begin if ref_count(p)=null then flush_token_list(p)
-else decr(ref_count(p));
-end;
-
-@ The following subroutine displays a macro, given a pointer to its
-reference count.
-
-@p @t\4@>@<Declare the procedure called |print_cmd_mod|@>@;
-procedure show_macro(@!p:pointer;@!q,@!l:integer);
-label exit;
-var @!r:pointer; {temporary storage}
-begin p:=link(p); {bypass the reference count}
-while info(p)>text_macro do
- begin r:=link(p); link(p):=null;
- show_token_list(p,null,l,0); link(p):=r; p:=r;
- if l>0 then l:=l-tally@+else return;
- end; {control printing of `\.{ETC.}'}
-@.ETC@>
-tally:=0;
-case info(p) of
-general_macro:print("->");
-@.->@>
-primary_macro,secondary_macro,tertiary_macro:begin print_char("<");
- print_cmd_mod(param_type,info(p)); print(">->");
- end;
-expr_macro:print("<expr>->");
-of_macro:print("<expr>of<primary>->");
-suffix_macro:print("<suffix>->");
-text_macro:print("<text>->");
-end; {there are no other cases}
-show_token_list(link(p),q,l-tally,0);
-exit:end;
-
-@* \[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 |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(#) == #+1 {where |value|, |subscr_head| and |attr_head| are}
-@d attr_head(#) == info(subscr_head_loc(#)) {pointer to attribute info}
-@d subscr_head(#) == link(subscr_head_loc(#)) {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 |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 |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)=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)=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)=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)=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)=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(#)==#+2 {where the |attr_loc| and |parent| fields are}
-@d attr_loc(#)==info(attr_loc_loc(#)) {hash address of this attribute}
-@d parent(#)==link(attr_loc_loc(#)) {pointer to |structured| variable}
-@d subscript_loc(#)==#+2 {where the |subscript| field lives}
-@d subscript(#)==mem[subscript_loc(#)].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=x_part_sector| and the second has |name_type=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|, |xx_part_sector|, |xy_part_sector|,
-|yx_part_sector|, and |yy_part_sector|.
-Finally, variables of type \&{color} have three values in six words
-identified by |red_part_sector|, |green_part_sector|, and |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(#)==# {where the \&{xpart} is found in a pair or transform node}
-@d y_part_loc(#)==#+2 {where the \&{ypart} is found in a pair or transform node}
-@d xx_part_loc(#)==#+4 {where the \&{xxpart} is found in a transform node}
-@d xy_part_loc(#)==#+6 {where the \&{xypart} is found in a transform node}
-@d yx_part_loc(#)==#+8 {where the \&{yxpart} is found in a transform node}
-@d yy_part_loc(#)==#+10 {where the \&{yypart} is found in a transform node}
-@d red_part_loc(#)==# {where the \&{redpart} is found in a color node}
-@d green_part_loc(#)==#+2 {where the \&{greenpart} is found in a color node}
-@d blue_part_loc(#)==#+4 {where the \&{bluepart} is found in a color node}
-@d cyan_part_loc(#)==# {where the \&{cyanpart} is found in a color node}
-@d magenta_part_loc(#)==#+2 {where the \&{magentapart} is found in a color node}
-@d yellow_part_loc(#)==#+4 {where the \&{yellowpart} is found in a color node}
-@d black_part_loc(#)==#+6 {where the \&{blackpart} is found in a color node}
-@d grey_part_loc(#)==# {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...@>=
-@!big_node_size:array[transform_type..pair_type] of small_number;
-@!sector0:array[transform_type..pair_type] of small_number;
-@!sector_offset:array[x_part_sector..black_part_sector] of small_number;
-
-@ 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...@>=
-big_node_size[transform_type]:=transform_node_size;
-big_node_size[pair_type]:=pair_node_size;
-big_node_size[color_type]:=color_node_size;
-big_node_size[cmykcolor_type]:=cmykcolor_node_size;
-sector0[transform_type]:=x_part_sector;
-sector0[pair_type]:=x_part_sector;
-sector0[color_type]:=red_part_sector;
-sector0[cmykcolor_type]:=cyan_part_sector;
-for k:=x_part_sector to yy_part_sector do
- sector_offset[k]:=2*(k-x_part_sector);
-for k:=red_part_sector to blue_part_sector do
- sector_offset[k]:=2*(k-red_part_sector);
-for k:=cyan_part_sector to black_part_sector do
- sector_offset[k]:=2*(k-cyan_part_sector);
-
-@ If |type(p)=pair_type| or |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
-|independent|.
-
-@p procedure init_big_node(@!p:pointer);
-var @!q:pointer; {the new node}
-@!s:small_number; {its size}
-begin s:=big_node_size[type(p)]; q:=get_node(s);
-repeat s:=s-2; @<Make variable |q+s| newly independent@>;
-name_type(q+s):=halfp(s)+sector0[type(p)]; link(q+s):=null;
-until s=0;
-link(q):=p; value(p):=q;
-end;
-
-@ The |id_transform| function creates a capsule for the
-identity transformation.
-
-@p function id_transform:pointer;
-var @!p,@!q,@!r:pointer; {list manipulation registers}
-begin p:=get_node(value_node_size); type(p):=transform_type;
-name_type(p):=capsule; value(p):=null; init_big_node(p); q:=value(p);
-r:=q+transform_node_size;
-repeat r:=r-2;
-type(r):=known; value(r):=0;
-until r=q;
-value(xx_part_loc(q)):=unity; value(yy_part_loc(q)):=unity;
-id_transform:=p;
-end;
-
-@ 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.
-
-@p procedure new_root(@!x:pointer);
-var @!p:pointer; {the new node}
-begin p:=get_node(value_node_size); type(p):=undefined; name_type(p):=root;
-link(p):=x; equiv(x):=p;
-end;
-
-@ 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.
-
-@p procedure print_variable_name(@!p:pointer);
-label found,exit;
-var @!q:pointer; {a token list that will name the variable's suffix}
-@!r:pointer; {temporary for token list creation}
-begin while name_type(p)>=x_part_sector do
- @<Preface the output with a part specifier; |return| in the
- case of a capsule@>;
-q:=null;
-while name_type(p)>saved_root do
- @<Ascend one level, pushing a token onto list |q|
- and replacing |p| by its parent@>;
-r:=get_avail; info(r):=link(p); link(r):=q;
-if name_type(p)=saved_root then print("(SAVED)");
-@.SAVED@>
-show_token_list(r,null,el_gordo,tally); flush_token_list(r);
-exit:end;
-
-@ @<Ascend one level, pushing a token onto list |q|...@>=
-begin if name_type(p)=subscr then
- begin r:=new_num_tok(subscript(p));
- repeat p:=link(p);
- until name_type(p)=attr;
- end
-else if name_type(p)=structured_root then
- begin p:=link(p); goto found;
- end
-else begin if name_type(p)<>attr then confusion("var");
-@:this can't happen var}{\quad var@>
- r:=get_avail; info(r):=attr_loc(p);
- end;
-link(r):=q; q:=r;
-found: p:=parent(p);
-end
-
-@ @<Preface the output with a part specifier...@>=
-begin case name_type(p) of
-x_part_sector: print_char("x");
-y_part_sector: print_char("y");
-xx_part_sector: print("xx");
-xy_part_sector: print("xy");
-yx_part_sector: print("yx");
-yy_part_sector: print("yy");
-red_part_sector: print("red");
-green_part_sector: print("green");
-blue_part_sector: print("blue");
-cyan_part_sector: print("cyan");
-magenta_part_sector: print("magenta");
-yellow_part_sector: print("yellow");
-black_part_sector: print("black");
-grey_part_sector: print("grey");
-capsule: begin print("%CAPSULE"); print_int(p-null); return;
-@.CAPSULE@>
- end;
-end; {there are no other cases}
-print("part "); p:=link(p-sector_offset[name_type(p)]);
-end
-
-@ The |interesting| function returns |true| if a given variable is not
-in a capsule, or if the user wants to trace capsules.
-
-@p function interesting(@!p:pointer):boolean;
-var @!t:small_number; {a |name_type|}
-begin if internal[tracing_capsules]>0 then interesting:=true
-else begin t:=name_type(p);
- if t>=x_part_sector then if t<>capsule then
- t:=name_type(link(p-sector_offset[t]));
- interesting:=(t<>capsule);
- end;
-end;
-
-@ Now here is a subroutine that converts an unstructured type into an
-equivalent structured type, by inserting a |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.
-
-@p function new_structure(@!p:pointer):pointer;
-var @!q,@!r:pointer; {list manipulation registers}
-begin r:=null;
-case name_type(p) of
-root: begin q:=link(p); r:=get_node(value_node_size); equiv(q):=r;
- end;
-subscr: @<Link a new subscript node |r| in place of node |p|@>;
-attr: @<Link a new attribute node |r| in place of node |p|@>;
-othercases confusion("struct")
-@:this can't happen struct}{\quad struct@>
-endcases;@/
-link(r):=link(p); type(r):=structured; name_type(r):=name_type(p);
-attr_head(r):=p; name_type(p):=structured_root;@/
-q:=get_node(attr_node_size); link(p):=q; subscr_head(r):=q;
-parent(q):=r; type(q):=undefined; name_type(q):=attr; link(q):=end_attr;
-attr_loc(q):=collective_subscript; new_structure:=r;
-end;
-
-@ @<Link a new subscript node |r| in place of node |p|@>=
-begin q:=p;
-repeat q:=link(q);
-until name_type(q)=attr;
-q:=parent(q); r:=subscr_head_loc(q); {|link(r)=subscr_head(q)|}
-repeat q:=r; r:=link(r);
-until r=p;
-r:=get_node(subscr_node_size);
-link(q):=r; subscript(r):=subscript(p);
-end
-
-@ 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|@>=
-begin q:=parent(p); r:=attr_head(q);
-repeat q:=r; r:=link(r);
-until r=p;
-r:=get_node(attr_node_size); link(q):=r;@/
-mem[attr_loc_loc(r)]:=mem[attr_loc_loc(p)]; {copy |attr_loc| and |parent|}
-if attr_loc(p)=collective_subscript then
- begin q:=subscr_head_loc(parent(p));
- while link(q)<>p do q:=link(q);
- link(q):=r;
- end;
-end
-
-@ 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)<structured|.
-
-@d abort_find==begin find_variable:=null; return;@+end
-
-@p function find_variable(@!t:pointer):pointer;
-label exit;
-var @!p,@!q,@!r,@!s:pointer; {nodes in the ``value'' line}
-@!pp,@!qq,@!rr,@!ss:pointer; {nodes in the ``collective'' line}
-@!n:integer; {subscript or attribute}
-@!save_word:memory_word; {temporary storage for a word of |mem|}
-@^inner loop@>
-begin p:=info(t); t:=link(t);
-if eq_type(p) mod outer_tag<>tag_token then abort_find;
-if equiv(p)=null then new_root(p);
-p:=equiv(p); pp:=p;
-while t<>null do
- begin @<Make sure that both nodes |p| and |pp| are of |structured| type@>;
- if t<hi_mem_min then
- @<Descend one level for the subscript |value(t)|@>
- else @<Descend one level for the attribute |info(t)|@>;
- t:=link(t);
- end;
-if type(pp)>=structured then
- if type(pp)=structured then pp:=attr_head(pp)@+else abort_find;
-if type(p)=structured then p:=attr_head(p);
-if type(p)=undefined then
- begin if type(pp)=undefined then
- begin type(pp):=numeric_type; value(pp):=null;
- end;
- type(p):=type(pp); value(p):=null;
- end;
-find_variable:=p;
-exit:end;
-
-@ 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)<>structured then
- begin if type(pp)>structured then abort_find;
- ss:=new_structure(pp);
- if p=pp then p:=ss;
- pp:=ss;
- end; {now |type(pp)=structured|}
-if type(p)<>structured then {it cannot be |>structured|}
- p:=new_structure(p) {now |type(p)=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)|@>=
-begin n:=value(t);
-pp:=link(attr_head(pp)); {now |attr_loc(pp)=collective_subscript|}
-q:=link(attr_head(p)); save_word:=mem[subscript_loc(q)];
-subscript(q):=el_gordo; s:=subscr_head_loc(p); {|link(s)=subscr_head(p)|}
-repeat r:=s; s:=link(s);
-until n<=subscript(s);
-if n=subscript(s) then p:=s
-else begin p:=get_node(subscr_node_size); link(r):=p; link(p):=s;
- subscript(p):=n; name_type(p):=subscr; type(p):=undefined;
- end;
-mem[subscript_loc(q)]:=save_word;
-end
-
-@ @<Descend one level for the attribute |info(t)|@>=
-begin n:=info(t);
-ss:=attr_head(pp);
-repeat rr:=ss; ss:=link(ss);
-until n<=attr_loc(ss);
-if n<attr_loc(ss) then
- begin qq:=get_node(attr_node_size); link(rr):=qq; link(qq):=ss;
- attr_loc(qq):=n; name_type(qq):=attr; type(qq):=undefined;
- parent(qq):=pp; ss:=qq;
- end;
-if p=pp then
- begin p:=ss; pp:=ss;
- end
-else begin pp:=ss; s:=attr_head(p);
- repeat r:=s; s:=link(s);
- until n<=attr_loc(s);
- if n=attr_loc(s) then p:=s
- else begin q:=get_node(attr_node_size); link(r):=q; link(q):=s;
- attr_loc(q):=n; name_type(q):=attr; type(q):=undefined;
- parent(q):=p; p:=q;
- end;
- end;
-end
-
-@ 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.
-
-@p @t\4@>@<Declare subroutines for printing expressions@>@;@/
-@t\4@>@<Declare basic dependency-list subroutines@>@;
-@t\4@>@<Declare the recycling subroutines@>@;
-@t\4@>@<Declare the procedure called |flush_cur_exp|@>@;
-@t\4@>@<Declare the procedure called |flush_below_variable|@>@;
-procedure flush_variable(@!p,@!t:pointer;@!discard_suffixes:boolean);
-label exit;
-var @!q,@!r:pointer; {list manipulation}
-@!n:halfword; {attribute to match}
-begin while t<>null do
- begin if type(p)<>structured then return;
- n:=info(t); t:=link(t);
- if n=collective_subscript then
- begin r:=subscr_head_loc(p); q:=link(r); {|q=subscr_head(p)|}
- while name_type(q)=subscr do
- begin flush_variable(q,t,discard_suffixes);
- if t=null then
- if type(q)=structured then r:=q
- else begin link(r):=link(q); free_node(q,subscr_node_size);
- end
- else r:=q;
- q:=link(r);
- end;
- end;
- p:=attr_head(p);
- repeat r:=p; p:=link(p);
- until attr_loc(p)>=n;
- if attr_loc(p)<>n then return;
- end;
-if discard_suffixes then flush_below_variable(p)
-else begin if type(p)=structured then p:=attr_head(p);
- recycle_value(p);
- end;
-exit:end;
-
-@ The next procedure is simpler; it wipes out everything but |p| itself,
-which becomes undefined.
-
-@<Declare the procedure called |flush_below_variable|@>=
-procedure flush_below_variable(@!p:pointer);
-var @!q,@!r:pointer; {list manipulation registers}
-begin if type(p)<>structured then
- recycle_value(p) {this sets |type(p)=undefined|}
-else begin q:=subscr_head(p);
- while name_type(q)=subscr do
- begin flush_below_variable(q); r:=q; q:=link(q);
- free_node(r,subscr_node_size);
- end;
- r:=attr_head(p); q:=link(r); recycle_value(r);
- if name_type(p)<=saved_root then free_node(r,value_node_size)
- else free_node(r,subscr_node_size);
- {we assume that |subscr_node_size=attr_node_size|}
- repeat flush_below_variable(q); r:=q; q:=link(q); free_node(r,attr_node_size);
- until q=end_attr;
- type(p):=undefined;
- end;
-end;
-
-@ 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.
-
-@p function und_type(@!p:pointer):small_number;
-begin case type(p) of
-undefined,vacuous:und_type:=undefined;
-boolean_type,unknown_boolean:und_type:=unknown_boolean;
-string_type,unknown_string:und_type:=unknown_string;
-pen_type,unknown_pen:und_type:=unknown_pen;
-path_type,unknown_path:und_type:=unknown_path;
-picture_type,unknown_picture:und_type:=unknown_picture;
-transform_type,color_type,cmykcolor_type,
-pair_type,numeric_type:und_type:=type(p);
-othercases und_type:=numeric_type; { |known,dependent,proto_dependent,independent| }
-end;
-end;
-
-@ 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.
-
-@p procedure clear_symbol(@!p:pointer;@!saving:boolean);
-var @!q:pointer; {|equiv(p)|}
-begin q:=equiv(p);
-case eq_type(p) mod outer_tag of
-defined_macro,secondary_primary_macro,tertiary_secondary_macro,
- expression_tertiary_macro: if not saving then delete_mac_ref(q);
-tag_token:if q<>null then
- if saving then name_type(q):=saved_root
- else begin flush_below_variable(q); free_node(q,value_node_size);
- end;@;
-othercases do_nothing
-endcases;@/
-eqtb[p]:=eqtb[frozen_undefined];
-end;
-
-@* \[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(#)==mem[#+1].hh {where an |eqtb| entry gets saved}
-@d save_boundary_item(#)==begin #:=get_avail; info(#):=0;
- link(#):=save_ptr; save_ptr:=#;
- end
-
-@<Glob...@>=@!save_ptr:pointer; {the most recently saved item}
-
-@ @<Set init...@>=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.
-
-@p procedure save_variable(@!q:pointer);
-var @!p:pointer; {temporary register}
-begin if save_ptr<>null then
- begin p:=get_node(save_node_size); info(p):=q; link(p):=save_ptr;
- saved_equiv(p):=eqtb[q]; save_ptr:=p;
- end;
-clear_symbol(q,(save_ptr<>null));
-end;
-
-@ Similarly, |save_internal| is given the location |q| of an internal
-quantity like |tracing_pens|. It creates a save stack entry of the
-third kind.
-
-@p procedure save_internal(@!q:halfword);
-var @!p:pointer; {new item for the save stack}
-begin if save_ptr<>null then
- begin p:=get_node(save_node_size); info(p):=hash_end+q;
- link(p):=save_ptr; value(p):=internal[q]; save_ptr:=p;
- end;
-end;
-
-@ 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.
-
-@p procedure unsave;
-var @!q:pointer; {index to saved item}
-@!p:pointer; {temporary register}
-begin while info(save_ptr)<>0 do
- begin q:=info(save_ptr);
- if q>hash_end then
- begin if internal[tracing_restores]>0 then
- begin begin_diagnostic; print_nl("{restoring ");
- print(int_name[q-(hash_end)]); print_char("=");
- print_scaled(value(save_ptr)); print_char("}");
- end_diagnostic(false);
- end;
- internal[q-(hash_end)]:=value(save_ptr);
- end
- else begin if internal[tracing_restores]>0 then
- begin begin_diagnostic; print_nl("{restoring ");
- print(text(q)); print_char("}");
- end_diagnostic(false);
- end;
- clear_symbol(q,false);
- eqtb[q]:=saved_equiv(save_ptr);
- if eq_type(q) mod outer_tag=tag_token then
- begin p:=equiv(q);
- if p<>null then name_type(p):=root;
- end;
- end;
- p:=link(save_ptr); free_node(save_ptr,save_node_size); save_ptr:=p;
- end;
-p:=link(save_ptr); free_avail(save_ptr); save_ptr:=p;
-end;
-
-@* \[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(#) == mem[#].hh.b0 {characterizes the path entering this knot}
-@d right_type(#) == mem[#].hh.b1 {characterizes the path leaving this knot}
-@d endpoint=0 {|left_type| at path beginning and |right_type| at path end}
-@d x_coord(#) == mem[#+1].sc {the |x| coordinate of this knot}
-@d y_coord(#) == mem[#+2].sc {the |y| coordinate of this knot}
-@d left_x(#) == mem[#+3].sc {the |x| coordinate of previous control point}
-@d left_y(#) == mem[#+4].sc {the |y| coordinate of previous control point}
-@d right_x(#) == mem[#+5].sc {the |x| coordinate of next control point}
-@d right_y(#) == mem[#+6].sc {the |y| coordinate of next control point}
-@d x_loc(#) == #+1 {where the |x| coordinate is stored in a knot}
-@d y_loc(#) == #+2 {where the |y| coordinate is stored in a knot}
-@d knot_coord(#) == mem[#].sc {|x| or |y| coordinate given |x_loc| or |y_loc|}
-@d left_coord(#) == mem[#+2].sc
- {coordinate of previous control point given |x_loc| or |y_loc|}
-@d right_coord(#) == mem[#+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}
-
-@ 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=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=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=given|, the curve should leave the
-knot in a nonzero direction stored as an |angle| in |right_given|.
-
-\yskip
-\textindent{$\bullet$} If |right_type=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}
-@d explicit=1 {|left_type| or |right_type| when control points are known}
-@d given=2 {|left_type| or |right_type| when a direction is given}
-@d curl=3 {|left_type| or |right_type| when a curl is desired}
-@d open=4 {|left_type| or |right_type| when \MP\ should choose the direction}
-
-@ 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):=metapost_user| when
-it appeared in the actual metapost program, and
-|originator(p):=program_code| in all other cases.
-
-@d originator(#) == mem[#+7].hh.b0 {the creator of this knot}
-@d program_code=0 {not created by a user}
-@d metapost_user=1 {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@>=
-procedure pr_path(@!h:pointer);
-label done,done1;
-var @!p,@!q:pointer; {for list traversal}
-begin p:=h;
-repeat q:=link(p);
-if (p=null)or(q=null) then
- begin print_nl("???"); goto done; {this won't happen}
-@.???@>
- end;
-@<Print information for adjacent knots |p| and |q|@>;
-p:=q;
-if (p<>h)or(left_type(h)<>endpoint) then
- @<Print two dots, followed by |given| or |curl| if present@>;
-until p=h;
-if left_type(h)<>endpoint then print("cycle");
-done:end;
-
-@ @<Print information for adjacent knots...@>=
-print_two(x_coord(p),y_coord(p));
-case right_type(p) of
-endpoint: begin if left_type(p)=open then print("{open?}"); {can't happen}
-@.open?@>
- if (left_type(q)<>endpoint)or(q<>h) then q:=null; {force an error}
- goto done1;
- end;
-explicit: @<Print control points between |p| and |q|, then |goto done1|@>;
-open: @<Print information for a curve that begins |open|@>;
-curl,given: @<Print information for a curve that begins |curl| or |given|@>;
-othercases print("???") {can't happen}
-@.???@>
-endcases;@/
-if left_type(q)<=explicit then print("..control?") {can't happen}
-@.control?@>
-else if (right_tension(p)<>unity)or(left_tension(q)<>unity) then
- @<Print tension between |p| and |q|@>;
-done1:
-
-@ 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...@>=
-begin print_nl(" ..");
-if left_type(p)=given then
- begin n_sin_cos(left_given(p)); print_char("{");
- print_scaled(n_cos); print_char(",");
- print_scaled(n_sin); print_char("}");
- end
-else if left_type(p)=curl then
- begin print("{curl "); print_scaled(left_curl(p)); print_char("}");
- end;
-end
-
-@ @<Print tension between |p| and |q|@>=
-begin print("..tension ");
-if right_tension(p)<0 then print("atleast");
-print_scaled(abs(right_tension(p)));
-if right_tension(p)<>left_tension(q) then
- begin print(" and ");
- if left_tension(q)<0 then print("atleast");
- print_scaled(abs(left_tension(q)));
- end;
-end
-
-@ @<Print control points between |p| and |q|, then |goto done1|@>=
-begin print("..controls "); print_two(right_x(p),right_y(p)); print(" and ");
-if left_type(q)<>explicit then print("??") {can't happen}
-@.??@>
-else print_two(left_x(q),left_y(q));
-goto done1;
-end
-
-@ @<Print information for a curve that begins |open|@>=
-if (left_type(p)<>explicit)and(left_type(p)<>open) then
- print("{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|...@>=
-begin if left_type(p)=open then print("??"); {can't happen}
-@.??@>
-if right_type(p)=curl then
- begin print("{curl "); print_scaled(right_curl(p));
- end
-else begin n_sin_cos(right_given(p)); print_char("{");
- print_scaled(n_cos); print_char(","); print_scaled(n_sin);
- end;
-print_char("}");
-end
-
-@ It is convenient to have another version of |pr_path| that prints the path
-as a diagnostic message.
-
-@<Declare subroutines for printing expressions@>=
-procedure print_path(@!h:pointer;@!s:str_number;@!nuline:boolean);
-begin print_diagnostic("Path",s,nuline); print_ln;
-@.Path at line...@>
-pr_path(h);
-end_diagnostic(true);
-end;
-
-@ If we want to duplicate a knot node, we can say |copy_knot|:
-
-@p function copy_knot(@!p:pointer):pointer;
-var @!q:pointer; {the copy}
-@!k:0..knot_node_size-1; {runs through the words of a knot node}
-begin q:=get_node(knot_node_size);
-for k:=0 to knot_node_size-1 do mem[q+k]:=mem[p+k];
-originator(q):=originator(p);
-copy_knot:=q;
-end;
-
-@ The |copy_path| routine makes a clone of a given path.
-
-@p function copy_path(@!p:pointer):pointer;
-var @!q,@!pp,@!qq:pointer; {for list manipulation}
-begin q:=copy_knot(p);
-qq:=q; pp:=link(p);
-while pp<>p do
- begin link(qq):=copy_knot(pp);@/
- qq:=link(qq);
- pp:=link(pp);
- end;
-link(qq):=q;
-copy_path:=q;
-end;
-
-@ 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.
-
-@p function htap_ypoc(@!p:pointer):pointer;
-label exit;
-var @!q,@!pp,@!qq,@!rr:pointer; {for list manipulation}
-begin q:=get_node(knot_node_size); {this will correspond to |p|}
-qq:=q; pp:=p;
-loop@+ begin 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 then
- begin link(q):=qq; path_tail:=pp; htap_ypoc:=q; return;
- end;
- rr:=get_node(knot_node_size); link(rr):=qq; qq:=rr; pp:=link(pp);
- end;
-exit:end;
-
-@ @<Glob...@>=
-@!path_tail:pointer; {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@>=
-procedure toss_knot_list(@!p:pointer);
-var @!q:pointer; {the node being freed}
-@!r:pointer; {the next node}
-begin q:=p;
-repeat r:=link(q); free_node(q,knot_node_size); q:=r;
-until q=p;
-end;
-
-@* \[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).
-
-@p @t\4@>@<Declare the procedure called |solve_choices|@>@;
-procedure make_choices(@!knots:pointer);
-label done;
-var @!h:pointer; {the first breakpoint}
-@!p,@!q:pointer; {consecutive breakpoints being processed}
-@<Other local variables for |make_choices|@>@;
-begin check_arith; {make sure that |arith_error=false|}
-if internal[tracing_choices]>0 then
- print_path(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;
-repeat @<Fill in the control points between |p| and the next breakpoint,
- then advance |p| to that breakpoint@>;
-until p=h;
-if internal[tracing_choices]>0 then
- print_path(knots,", after choices",true);
-if arith_error then @<Report an unexpected problem during the choice-making@>;
-end;
-
-@ @<Report an unexpected problem during the choice...@>=
-begin 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.");
-put_get_error; arith_error:=false;
-end
-
-@ 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;
-repeat q:=link(p);
-if x_coord(p)=x_coord(q) then if y_coord(p)=y_coord(q) then
- if right_type(p)>explicit then
- begin right_type(p):=explicit;
- if left_type(p)=open then
- begin left_type(p):=curl; left_curl(p):=unity;
- end;
- left_type(q):=explicit;
- if right_type(q)=open then
- begin right_type(q):=curl; right_curl(q):=unity;
- end;
- right_x(p):=x_coord(p); left_x(q):=x_coord(p);@/
- right_y(p):=y_coord(p); left_y(q):=y_coord(p);
- end;
-p:=q;
-until 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|.
-
-@d end_cycle=open+1
-
-@<Find the first breakpoint, |h|, on the path...@>=
-h:=knots;
-loop@+ begin if left_type(h)<>open then goto done;
- if right_type(h)<>open then goto done;
- h:=link(h);
- if h=knots then
- begin left_type(h):=end_cycle; goto done;
- end;
- end;
-done:
-
-@ If |right_type(p)<given| and |q=link(p)|, we must have
-|right_type(p)=left_type(q)=explicit| or |endpoint|.
-
-@<Fill in the control points between |p| and the next breakpoint...@>=
-q:=link(p);
-if right_type(p)>=given then
- begin while (left_type(q)=open)and(right_type(q)=open) do q:=link(q);
- @<Fill in the control information between
- consecutive breakpoints |p| and |q|@>;
- end
-else if right_type(p)=endpoint then
- @<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|@>=
-begin right_x(p):=x_coord(p); right_y(p):=y_coord(p);@/
-left_x(q):=x_coord(q); left_y(q):=y_coord(q);
-end
-
-@ 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@>;
-solve_choices(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...@>=
-@!delta_x,@!delta_y,@!delta:array[0..path_size] of scaled; {knot differences}
-@!psi:array[1..path_size] of angle; {turning angles}
-
-@ @<Other local variables for |make_choices|@>=
-@!k,@!n:0..path_size; {current and final knot numbers}
-@!s,@!t:pointer; {registers for list traversal}
-@!delx,@!dely:scaled; {directions where |open| meets |explicit|}
-@!sine,@!cosine:fraction; {trig functions of various angles}
-
-@ @<Calculate the turning angles...@>=
-k:=0; s:=p; n:=path_size;
-repeat t:=link(s);
-delta_x[k]:=x_coord(t)-x_coord(s);
-delta_y[k]:=y_coord(t)-y_coord(s);
-delta[k]:=pyth_add(delta_x[k],delta_y[k]);
-if k>0 then
- begin sine:=make_fraction(delta_y[k-1],delta[k-1]);
- cosine:=make_fraction(delta_x[k-1],delta[k-1]);
- psi[k]:=n_arg(take_fraction(delta_x[k],cosine)+
- take_fraction(delta_y[k],sine),
- take_fraction(delta_y[k],cosine)-
- take_fraction(delta_x[k],sine));
- end;
-@:MetaPost capacity exceeded path size}{\quad path size@>
-incr(k); s:=t;
-if k=path_size then overflow("path size",path_size);
-if s=q then n:=k;
-until (k>=n)and(left_type(s)<>end_cycle);
-if k=n then psi[n]:=0@+else psi[k]:=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)=end_cycle| or |left_type(p)=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
-|end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
-
-@<Remove |open| types at the breakpoints@>=
-if left_type(q)=open then
- begin delx:=right_x(q)-x_coord(q); dely:=right_y(q)-y_coord(q);
- if (delx=0)and(dely=0) then
- begin left_type(q):=curl; left_curl(q):=unity;
- end
- else begin left_type(q):=given; left_given(q):=n_arg(delx,dely);
- end;
- end;
-if (right_type(p)=open)and(left_type(p)=explicit) then
- begin delx:=x_coord(p)-left_x(p); dely:=y_coord(p)-left_y(p);
- if (delx=0)and(dely=0) then
- begin right_type(p):=curl; right_curl(p):=unity;
- end
- else begin right_type(p):=given; right_given(p):=n_arg(delx,dely);
- end;
- end
-
-@ 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...@>=
-@!theta:array[0..path_size] of angle; {values of $\theta_k$}
-@!uu:array[0..path_size] of fraction; {values of $u_k$}
-@!vv:array[0..path_size] of angle; {values of $v_k$}
-@!ww:array[0..path_size] of fraction; {values of $w_k$}
-
-@ 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|@>=
-@t\4@>@<Declare subroutines needed by |solve_choices|@>@;
-procedure solve_choices(@!p,@!q:pointer;@!n:halfword);
-label found,exit;
-var @!k:0..path_size; {current knot number}
-@!r,@!s,@!t:pointer; {registers for list traversal}
-@<Other local variables for |solve_choices|@>@;
-begin k:=0; r:=null; s:=p;
-loop@+ begin t:=link(s);
- if k=0 then @<Get the linear equations started; or |return|
- with the control points in place, if linear equations
- needn't be solved@>
- else case left_type(s) of
- end_cycle,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@>;
- curl:@<Set up equation for a curl at $\theta_n$
- and |goto found|@>;
- othercases { |given:| }
- @<Calculate the given value of $\theta_n$ and |goto found|@>;
- end;
- r:=s; s:=t; incr(k);
- end;
-found:@<Finish choosing angles and assigning control points@>;
-exit:end;
-
-@ 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...@>=
-case right_type(s) of
-given: if left_type(t)=given then @<Reduce to simple case of two givens
- and |return|@>
- else @<Set up the equation for a given value of $\theta_0$@>;
-curl: if left_type(t)=curl then @<Reduce to simple case of straight line
- and |return|@>
- else @<Set up the equation for a curl at $\theta_0$@>;
-open: begin uu[0]:=0; vv[0]:=0; ww[0]:=fraction_one;
- end; {this begins a cycle}
-end {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|@>=
-@!aa,@!bb,@!cc,@!ff,@!acc:fraction; {temporary registers}
-@!dd,@!ee:scaled; {likewise, but |scaled|}
-@!lt,@!rt:scaled; {tension values}
-
-@ @<Set up equation to match mock curvatures...@>=
-begin @<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)$@>;
-uu[k]:=take_fraction(ff,bb);
-@<Calculate the values of $v_k$ and $w_k$@>;
-if left_type(s)=end_cycle then
- @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
-end
-
-@ 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 then
- begin aa:=fraction_half; dd:=2*delta[k];
- end
-else begin aa:=make_fraction(unity,3*abs(right_tension(r))-unity);
- dd:=take_fraction(delta[k],
- fraction_three-make_fraction(unity,abs(right_tension(r))));
- end;
-if abs(left_tension(t))=unity then
- begin bb:=fraction_half; ee:=2*delta[k-1];
- end
-else begin bb:=make_fraction(unity,3*abs(left_tension(t))-unity);
- ee:=take_fraction(delta[k-1],
- fraction_three-make_fraction(unity,abs(left_tension(t))));
- end;
-cc:=fraction_one-take_fraction(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:=take_fraction(dd,cc); lt:=abs(left_tension(s)); rt:=abs(right_tension(s));
-if lt<>rt then {$\beta_k^{-1}\ne\alpha_k^{-1}$}
- if lt<rt then
- begin ff:=make_fraction(lt,rt);
- ff:=take_fraction(ff,ff); {$\alpha_k^2/\beta_k^2$}
- dd:=take_fraction(dd,ff);
- end
- else begin ff:=make_fraction(rt,lt);
- ff:=take_fraction(ff,ff); {$\beta_k^2/\alpha_k^2$}
- ee:=take_fraction(ee,ff);
- end;
-ff:=make_fraction(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:=-take_fraction(psi[k+1],uu[k]);
-if right_type(r)=curl then
- begin ww[k]:=0;
- vv[k]:=acc-take_fraction(psi[1],fraction_one-ff);
- end
-else begin ff:=make_fraction(fraction_one-ff,cc); {this is
- $B_k/(C_k+B_k-u_{k-1}A_k)<5$}
- acc:=acc-take_fraction(psi[k],ff);
- ff:=take_fraction(ff,aa); {this is $A_k/(C_k+B_k-u_{k-1}A_k)$}
- vv[k]:=acc-take_fraction(vv[k-1],ff);
- if ww[k-1]=0 then ww[k]:=0
- else ww[k]:=-take_fraction(ww[k-1],ff);
- end
-
-@ 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|@>=
-begin aa:=0; bb:=fraction_one; {we have |k=n|}
-repeat decr(k);
-if k=0 then k:=n;
-aa:=vv[k]-take_fraction(aa,uu[k]);
-bb:=ww[k]-take_fraction(bb,uu[k]);
-until k=n; {now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$}
-aa:=make_fraction(aa,fraction_one-bb);
-theta[n]:=aa; vv[0]:=aa;
-for k:=1 to n-1 do vv[k]:=vv[k]+take_fraction(aa,ww[k]);
-goto found;
-end
-
-@ @d reduce_angle(#)==if abs(#)>one_eighty_deg then
- if #>0 then #:=#-three_sixty_deg@+else #:=#+three_sixty_deg
-
-@<Calculate the given value of $\theta_n$...@>=
-begin theta[n]:=left_given(s)-n_arg(delta_x[n-1],delta_y[n-1]);
-reduce_angle(theta[n]);
-goto found;
-end
-
-@ @<Set up the equation for a given value of $\theta_0$@>=
-begin vv[0]:=right_given(s)-n_arg(delta_x[0],delta_y[0]);
-reduce_angle(vv[0]);
-uu[0]:=0; ww[0]:=0;
-end
-
-@ @<Set up the equation for a curl at $\theta_0$@>=
-begin cc:=right_curl(s); lt:=abs(left_tension(t)); rt:=abs(right_tension(s));
-if (rt=unity)and(lt=unity) then
- uu[0]:=make_fraction(cc+cc+unity,cc+two)
-else uu[0]:=curl_ratio(cc,rt,lt);
-vv[0]:=-take_fraction(psi[1],uu[0]); ww[0]:=0;
-end
-
-@ @<Set up equation for a curl at $\theta_n$...@>=
-begin cc:=left_curl(s); lt:=abs(left_tension(s)); rt:=abs(right_tension(r));
-if (rt=unity)and(lt=unity) then
- ff:=make_fraction(cc+cc+unity,cc+two)
-else ff:=curl_ratio(cc,lt,rt);
-theta[n]:=-make_fraction(take_fraction(vv[n-1],ff),
- fraction_one-take_fraction(ff,uu[n-1]));
-goto found;
-end
-
-@ 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|@>=
-function curl_ratio(@!gamma,@!a_tension,@!b_tension:scaled):fraction;
-var @!alpha,@!beta,@!num,@!denom,@!ff:fraction; {registers}
-begin alpha:=make_fraction(unity,a_tension);
-beta:=make_fraction(unity,b_tension);@/
-if alpha<=beta then
- begin ff:=make_fraction(alpha,beta); ff:=take_fraction(ff,ff);
- gamma:=take_fraction(gamma,ff);@/
- beta:=beta div @'10000; {convert |fraction| to |scaled|}
- denom:=take_fraction(gamma,alpha)+three-beta;
- num:=take_fraction(gamma,fraction_three-alpha)+beta;
- end
-else begin ff:=make_fraction(beta,alpha); ff:=take_fraction(ff,ff);
- beta:=take_fraction(beta,ff) div @'10000; {convert |fraction| to |scaled|}
- denom:=take_fraction(gamma,alpha)+(ff div 1365)-beta;
- {$1365\approx 2^{12}/3$}
- num:=take_fraction(gamma,fraction_three-alpha)+beta;
- end;
-if num>=denom+denom+denom+denom then curl_ratio:=fraction_four
-else curl_ratio:=make_fraction(num,denom);
-end;
-
-@ We're in the home stretch now.
-
-@<Finish choosing angles and assigning control points@>=
-for k:=n-1 downto 0 do theta[k]:=vv[k]-take_fraction(theta[k+1],uu[k]);
-s:=p; k:=0;
-repeat t:=link(s);@/
-n_sin_cos(theta[k]); st:=n_sin; ct:=n_cos;@/
-n_sin_cos(-psi[k+1]-theta[k+1]); sf:=n_sin; cf:=n_cos;@/
-set_controls(s,t,k);@/
-incr(k); s:=t;
-until 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...@>=
-@!st,@!ct,@!sf,@!cf:fraction; {sines and cosines}
-
-@ @<Declare subroutines needed by |solve_choices|@>=
-procedure set_controls(@!p,@!q:pointer;@!k:integer);
-var @!rr,@!ss:fraction; {velocities, divided by thrice the tension}
-@!lt,@!rt:scaled; {tensions}
-@!sine:fraction; {$\sin(\theta+\phi)$}
-begin lt:=abs(left_tension(q)); rt:=abs(right_tension(p));
-rr:=velocity(st,ct,sf,cf,rt);
-ss:=velocity(sf,cf,st,ct,lt);
-if (right_tension(p)<0)or(left_tension(q)<0) then @<Decrease the velocities,
- if necessary, to stay inside the bounding triangle@>;
-right_x(p):=x_coord(p)+take_fraction(
- take_fraction(delta_x[k],ct)-take_fraction(delta_y[k],st),rr);
-right_y(p):=y_coord(p)+take_fraction(
- take_fraction(delta_y[k],ct)+take_fraction(delta_x[k],st),rr);
-left_x(q):=x_coord(q)-take_fraction(
- take_fraction(delta_x[k],cf)+take_fraction(delta_y[k],sf),ss);
-left_y(q):=y_coord(q)-take_fraction(
- take_fraction(delta_y[k],cf)-take_fraction(delta_x[k],sf),ss);
-right_type(p):=explicit; left_type(q):=explicit;
-end;
-
-@ 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((st>=0)and(sf>=0))or((st<=0)and(sf<=0)) then
- begin sine:=take_fraction(abs(st),cf)+take_fraction(abs(sf),ct);
- if sine>0 then
- begin sine:=take_fraction(sine,fraction_one+unity); {safety factor}
- if right_tension(p)<0 then
- if ab_vs_cd(abs(sf),fraction_one,rr,sine)<0 then
- rr:=make_fraction(abs(sf),sine);
- if left_tension(q)<0 then
- if ab_vs_cd(abs(st),fraction_one,ss,sine)<0 then
- ss:=make_fraction(abs(st),sine);
- end;
- end
-
-@ Only the simple cases remain to be handled.
-
-@<Reduce to simple case of two givens and |return|@>=
-begin aa:=n_arg(delta_x[0],delta_y[0]);@/
-n_sin_cos(right_given(p)-aa); ct:=n_cos; st:=n_sin;@/
-n_sin_cos(left_given(q)-aa); cf:=n_cos; sf:=-n_sin;@/
-set_controls(p,q,0); return;
-end
-
-@ @<Reduce to simple case of straight line and |return|@>=
-begin right_type(p):=explicit; left_type(q):=explicit;
-lt:=abs(left_tension(q)); rt:=abs(right_tension(p));
-if rt=unity then
- begin if delta_x[0]>=0 then right_x(p):=x_coord(p)+((delta_x[0]+1) div 3)
- else right_x(p):=x_coord(p)+((delta_x[0]-1) div 3);
- if delta_y[0]>=0 then right_y(p):=y_coord(p)+((delta_y[0]+1) div 3)
- else right_y(p):=y_coord(p)+((delta_y[0]-1) div 3);
- end
-else begin ff:=make_fraction(unity,3*rt); {$\alpha/3$}
- right_x(p):=x_coord(p)+take_fraction(delta_x[0],ff);
- right_y(p):=y_coord(p)+take_fraction(delta_y[0],ff);
- end;
-if lt=unity then
- begin if delta_x[0]>=0 then left_x(q):=x_coord(q)-((delta_x[0]+1) div 3)
- else left_x(q):=x_coord(q)-((delta_x[0]-1) div 3);
- if delta_y[0]>=0 then left_y(q):=y_coord(q)-((delta_y[0]+1) div 3)
- else left_y(q):=y_coord(q)-((delta_y[0]-1) div 3);
- end
-else begin ff:=make_fraction(unity,3*lt); {$\beta/3$}
- left_x(q):=x_coord(q)-take_fraction(delta_x[0],ff);
- left_y(q):=y_coord(q)-take_fraction(delta_y[0],ff);
- end;
-return;
-end
-
-@* \[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==begin crossing_point:=fraction_one+1; return;
- end
-@d one_crossing==begin crossing_point:=fraction_one; return;
- end
-@d zero_crossing==begin crossing_point:=0; return;
- end
-
-@p function crossing_point(@!a,@!b,@!c:integer):fraction;
-label exit;
-var @!d:integer; {recursive counter}
-@!x,@!xx,@!x0,@!x1,@!x2:integer; {temporary registers for bisection}
-begin if a<0 then zero_crossing;
-if c>=0 then
- begin if b>=0 then
- if c>0 then no_crossing
- else if (a=0)and(b=0) then no_crossing
- else one_crossing;
- if a=0 then zero_crossing;
- end
-else if a=0 then if b<=0 then zero_crossing;
-@<Use bisection to find the crossing point, if one exists@>;
-exit:end;
-
-@ 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;
-repeat x:=half(x1+x2);
-if x1-x0>x0 then
- begin x2:=x; double(x0); double(d);
- end
-else begin xx:=x1+x-x0;
- if xx>x0 then
- begin x2:=x; double(x0); double(d);
- end
- else begin x0:=x0-xx;
- if x<=x0 then if x+x2<=x0 then no_crossing;
- x1:=x; d:=d+d+1;
- end;
- end;
-until d>=fraction_one;
-crossing_point:=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_end(#)==#,t@=)@>
-@d t_of_the_way(#)==#-take_fraction@=(@>#-t_of_the_way_end
-
-@p function eval_cubic(@!p,@!q:pointer;t:fraction):scaled;
-var @!x1,@!x2,@!x3:scaled; {intermediate values}
-begin 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);
-eval_cubic:=t_of_the_way(x1)(x2);
-end;
-
-@ 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.
-
-@d x_code=0 {index for |minx| and |maxx|}
-@d y_code=1 {index for |miny| and |maxy|}
-@d minx==bbmin[x_code]
-@d maxx==bbmax[x_code]
-@d miny==bbmin[y_code]
-@d maxy==bbmax[y_code]
-
-@<Glob...@>=
-@!bbmin,@!bbmax:array[x_code..y_code] of scaled;
- {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|.
-
-@p procedure bound_cubic(@!p,@!q:pointer;c:small_number);
-var @!wavy:boolean; {whether we need to look for extremes}
-@!del1,@!del2,@!del3,@!del,@!dmax:scaled; {proportional to the control
- points of a quadratic derived from a cubic}
-@!t,@!tt:fraction; {where a quadratic crosses zero}
-@!x:scaled; {a value that |bbmin[c]| and |bbmax[c]| must accommodate}
-begin 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 then
- begin 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 then
- begin negate(del1); negate(del2); negate(del3);
- end;
- t:=crossing_point(del1,del2,del3);
- if t<fraction_one then
- @<Test the extremes of the cubic against the bounding box@>;
- end;
-end;
-
-@ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
-if x<bbmin[c] then bbmin[c]:=x;
-if x>bbmax[c] then bbmax[c]:=x
-
-@ @<Check the control points against the bounding box and set...@>=
-wavy:=true;
-if bbmin[c]<=right_coord(p) then
- if right_coord(p)<=bbmax[c] then
- if bbmin[c]<=left_coord(q) then
- if left_coord(q)<=bbmax[c] then
- 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 then del:=del1
-else if del2<>0 then del:=del2
-else del:=del3;
-if del<>0 then
- begin dmax:=abs(del1);
- if abs(del2)>dmax then dmax:=abs(del2);
- if abs(del3)>dmax then dmax:=abs(del3);
- while dmax<fraction_half do
- begin double(dmax); double(del1); double(del2); double(del3);
- end;
- end
-
-@ 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@>=
-begin x:=eval_cubic(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 then del2:=0;
-tt:=crossing_point(0,-del2,-del3);
-if tt<fraction_one then
- @<Test the second extreme against the bounding box@>;
-end
-
-@ @<Test the second extreme against the bounding box@>=
-begin x:=eval_cubic(p,q,t_of_the_way(tt)(fraction_one));
-@<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
-end
-
-@ Finding the bounding box of a path is basically a matter of applying
-|bound_cubic| twice for each pair of adjacent knots.
-
-@p procedure path_bbox(@!h:pointer);
-label exit;
-var @!p,@!q:pointer; {a pair of adjacent knots}
-begin minx:=x_coord(h); miny:=y_coord(h);
-maxx:=minx; maxy:=miny;@/
-p:=h;
-repeat if right_type(p)=endpoint then return;
-q:=link(p);@/
-bound_cubic(x_loc(p),x_loc(q),x_code);
-bound_cubic(y_loc(p),y_loc(q),y_code);
-p:=q;
-until p=h;
-exit:end;
-
-@ 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|.
-
-@p @t\4@>@<Declare subroutines needed by |arc_test|@>@;
-function arc_test(@!dx0, @!dy0, @!dx1, @!dy1, @!dx2, @!dy2,
- @!v0, @!v02, @!v2, @!a_goal, @!tol:scaled): scaled;
-label exit;
-var simple: boolean; {are the control points confined to a $90^\circ$ sector?}
-@!dx01, @!dy01, @!dx12, @!dy12, @!dx02, @!dy02: scaled; {bisection results}
-@!v002, @!v022: scaled;
- {twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$}
-@!arc: scaled; {best arc length estimate before recursion}
-@<Other local variables in |arc_test|@>@;
-begin @<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 and (abs(arc-v02-halfp(v0+v2)) <= tol) then
- if arc < a_goal then @+arc_test := 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@>;
-exit:end;
-
-@ 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@>=
-begin @<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 := arc_test(dx0,dy0, dx01,dy01, dx02,dy02, v0, v002, halfp(v02), a_new, tol);
-if a<0 then @+arc_test := -halfp(two-a)
-else begin @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
- b := arc_test(dx02,dy02, dx12,dy12, dx2,dy2,
- halfp(v02), v022, v2, a_new, tol);
- if b<0 then @+arc_test := -halfp(-b) - half_unit
- else arc_test := a + half(b-a);
- end;
-end
-
-@ @<Other local variables in |arc_test|@>=
-@!a, @!b: scaled; {results of recursive calls}
-@!a_new, @!a_aux: scaled; {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 then
- begin a_aux := a_goal - a_aux;
- a_new := el_gordo;
- end
-else begin a_new := a_goal + a_goal;
- a_aux := 0;
- end
-
-@ 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 then
- begin a_aux := a_aux - a;
- a_new := a_new + a_aux;
- end
-
-@ 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 := pyth_add(dx01+half(dx0+dx02), dy01+half(dy0+dy02));
-v022 := pyth_add(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) then @+arc := arc+arc1
-else begin arith_error := true;
- if a_goal=el_gordo then @+arc_test := el_gordo
- else arc_test := -two;
- return;
- end
-
-@ @<Other local variables in |arc_test|@>=
-tmp, tmp2: scaled; {all purpose temporary registers}
-arc1: scaled; {arc length estimate for the first half}
-
-@ @<Test if the control points are confined to one quadrant or rotating...@>=
-simple := (dx0>=0) and (dx1>=0) and (dx2>=0) or@|
- (dx0<=0) and (dx1<=0) and (dx2<=0);
-if simple then
- simple := (dy0>=0) and (dy1>=0) and (dy2>=0) or@|
- (dy0<=0) and (dy1<=0) and (dy2<=0);
-if not simple then
- begin simple := (dx0>=dy0) and (dx1>=dy1) and (dx2>=dy2) or@|
- (dx0<=dy0) and (dx1<=dy1) and (dx2<=dy2);
- if simple then
- simple := (-dx0>=dy0) and (-dx1>=dy1) and (-dx2>=dy2) or@|
- (-dx0<=dy0) and (-dx1<=dy1) and (-dx2<=dy2);
- end
-
-@ 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...@>=
-begin tmp := (v02 + 2) div 4;
-if a_goal<=arc1 then
- begin tmp2 := halfp(v0);
- arc_test := halfp(solve_rising_cubic(tmp2, arc1-tmp2-tmp, tmp, a_goal))
- - two;
- end
-else begin tmp2 := halfp(v2);
- arc_test := (half_unit - two) +@|
- halfp(solve_rising_cubic(tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1));
- end;
-end
-
-@ 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|@>=
-function solve_rising_cubic(@!a, @!b, @!c, @!x: scaled): scaled;
-var @!ab, @!bc, @!ac: scaled; {bisection results}
-@!t: integer; {$2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$}
-@!xx: integer; {temporary for updating |x|}
-begin if (a<0) or (c<0) then confusion("rising?");
-@:this can't happen rising?}{\quad rising?@>
-if x<=0 then solve_rising_cubic := 0
-else if x >= a+b+c then solve_rising_cubic := unity
-else begin t := 1;
- @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
- |el_gordo div 3|@>;
- repeat double(t);
- @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
- xx := x - a - ab - ac;
- if xx < -x then
- begin double(x);
- b:=ab; c:=ac;
- end
- else begin x := x + xx;
- a:=ac; b:=bc;
- t := t+1;
- end;
- until t >= unity;
- solve_rising_cubic := t - unity;
- end;
-end;
-
-@ @<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==@'5252525252 {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) or@| (b>one_third_el_gordo)
- or@| (c>one_third_el_gordo) do
- begin a := halfp(a);
- b := half(b);
- c := halfp(c);
- x := halfp(x);
- end
-
-@ 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}
-
-@p function do_arc_test(@!dx0, @!dy0, @!dx1, @!dy1, @!dx2, @!dy2,
- @!a_goal: scaled): scaled;
-var @!v0, @!v1, @!v2: scaled; {length of each $({\it dx},{\it dy})$ pair}
-@!v02: scaled; {twice the norm of the quadratic at $t={1\over2}$}
-begin v0 := pyth_add(dx0,dy0);
-v1 := pyth_add(dx1,dy1);
-v2 := pyth_add(dx2,dy2);
-if (v0>=fraction_four) or (v1>=fraction_four) or (v2>=fraction_four) then
- begin arith_error := true;
- if a_goal=el_gordo then @+do_arc_test := el_gordo
- else do_arc_test := -two;
- end
-else begin v02 := pyth_add(dx1+half(dx0+dx2), dy1+half(dy0+dy2));@/
- do_arc_test := arc_test(dx0,dy0, dx1,dy1, dx2,dy2,@|
- v0, v02, v2, a_goal, arc_tol);
- end;
-end;
-
-@ Now it is easy to find the arc length of an entire path.
-
-@p function get_arc_length(@!h: pointer): scaled;
-label done;
-var @!p, @!q: pointer; {for traversing the path}
-@!a, @!a_tot: scaled; {current and total arc lengths}
-begin a_tot := 0;
-p := h;
-while right_type(p)<>endpoint do
- begin q := link(p);
- a := do_arc_test(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 := slow_add(a, a_tot);
- if q=h then goto done @+else p:=q;
- end;
-done:check_arith;
-get_arc_length := a_tot;
-end;
-
-@ 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.
-
-@p function get_arc_time(@!h: pointer; @!arc0:scaled): scaled;
-label done;
-var @!p, @!q: pointer; {for traversing the path}
-@!t_tot: scaled; {accumulator for the result}
-@!t: scaled; {the result of |do_arc_test|}
-@!arc:scaled; {portion of |arc0| not used up so far}
-@!n: integer; {number of extra times to go around the cycle}
-begin if arc0<0 then @<Deal with a negative |arc0| value and |goto done|@>;
-if arc0=el_gordo then decr(arc0);
-t_tot := 0;
-arc := arc0;
-p := h;
-while (right_type(p)<>endpoint) and (arc>0) do
- begin q := link(p);
- t := do_arc_test(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 then @<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;
- end;
-done: check_arith;
-get_arc_time := t_tot;
-end;
-
-@ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
-if t<0 then
- begin t_tot := t_tot + t + two;
- arc := 0;
- end
-else begin t_tot := t_tot + unity;
- arc := arc - t;
- end
-
-@ @<Deal with a negative |arc0| value and |goto done|@>=
-begin if left_type(h)=endpoint then t_tot:=0
-else begin p := htap_ypoc(h);
- t_tot := -get_arc_time(p, -arc0);
- toss_knot_list(p);
- end;
-goto done;
-end
-
-@ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
-if arc>0 then
- begin n := arc div (arc0 - arc);
- arc := arc - n*(arc0 - arc);
- if t_tot > el_gordo div (n+1) then
- begin arith_error := true;
- t_tot := el_gordo;
- goto done;
- end;
- t_tot := (n + 1)*t_tot;
- end
-
-@* \[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(#)==make_pen(copy_path(#),false)
-
-@p @<Declare a function called |convex_hull|@>@;
-function make_pen(h:pointer;@!need_hull:boolean):pointer;
-var @!p,@!q:pointer; {two consecutive knots}
-begin q:=h;
-repeat p:=q; q:=link(q);
-knil(q):=p;
-until q=h;
-if need_hull then
- begin h:=convex_hull(h);
- @<Make sure |h| isn't confused with an elliptical pen@>;
- end;
-make_pen:=h;
-end;
-
-@ 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(#)==(#=link(#))
-
-@p function get_pen_circle(@!diam:scaled):pointer;
-var @!h:pointer; {the knot node to return}
-begin h:=get_node(knot_node_size);
-link(h):=h; knil(h):=h;@/
-originator(h):=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;@/
-get_pen_circle:=h;
-end;
-
-@ 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) then
- begin left_x(h):=x_coord(h); left_y(h):=y_coord(h);@/
- right_x(h):=x_coord(h); right_y(h):=y_coord(h);
- end
-
-@ 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@>=
-procedure pr_pen(@!h:pointer);
-label done;
-var @!p,@!q:pointer; {for list traversal}
-begin if pen_is_elliptical(h) then
- @<Print the elliptical pen |h|@>
-else begin p:=h;
- repeat print_two(x_coord(p),y_coord(p));
- print_nl(" .. ");
- @<Advance |p| making sure the links are OK and |return| if there is
- a problem@>;
- until p=h;
- print("cycle");
- end;
-done:end;
-
-@ @<Advance |p| making sure the links are OK and |return| if there is...@>=
-q:=link(p);
-if (q=null) or (knil(q)<>p) then
- begin print_nl("???"); goto done; {this won't happen}
-@.???@>
- end;
-p:=q
-
-@ @<Print the elliptical pen |h|@>=
-begin print("pencircle transformed (");
-print_scaled(x_coord(h));
-print_char(",");
-print_scaled(y_coord(h));@/
-print_char(",");
-print_scaled(left_x(h)-x_coord(h));
-print_char(",");
-print_scaled(right_x(h)-x_coord(h));
-print_char(",");
-print_scaled(left_y(h)-y_coord(h));@/
-print_char(",");
-print_scaled(right_y(h)-y_coord(h));@/
-print_char(")");
-end
-
-@ Here us another version of |pr_pen| that prints the pen as a diagnostic
-message.
-
-@<Declare subroutines for printing expressions@>=
-procedure print_pen(@!h:pointer;@!s:str_number;@!nuline:boolean);
-begin print_diagnostic("Pen",s,nuline); print_ln;
-@.Pen at line...@>
-pr_pen(h);
-end_diagnostic(true);
-end;
-
-@ 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.
-
-@p procedure make_path(@!h:pointer);
-var @!p:pointer; {for traversing the knot list}
-@!k:small_number; {a loop counter}
-@<Other local variables in |make_path|@>@;
-begin if pen_is_elliptical(h) then
- @<Make the elliptical pen |h| into a path@>
-else begin p:=h;
- repeat left_type(p):=explicit;
- right_type(p):=explicit;@/
- @<copy the coordinates of knot |p| into its control points@>;@/
- p:=link(p);
- until p=h;
- end;
-end;
-
-@ @<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@>=
-begin @<Extract the transformation parameters from the elliptical pen~|h|@>;
-p:=h;
-for k:=0 to 7 do
- begin @<Initialize |p| as the |k|th knot of a circle of unit diameter,
- transforming it appropriately@>;
- if k=7 then link(p):=h @+else link(p):=get_node(knot_node_size);
- p:=link(p);
- end;
-end
-
-@ @<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|@>=
-@!center_x,@!center_y:scaled; {translation parameters for an elliptical pen}
-@!width_x,@!width_y:scaled; {the effect of a unit change in $x$}
-@!height_x,@!height_y:scaled; {the effect of a unit change in $y$}
-@!dx,@!dy:scaled; {the vector from knot |p| to its right control point}
-@!kk:integer;
- {|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)mod 8;@/
-x_coord(p):=center_x+take_fraction(half_cos[k],width_x)
- +take_fraction(half_cos[kk],height_x);
-y_coord(p):=center_y+take_fraction(half_cos[k],width_y)
- +take_fraction(half_cos[kk],height_y);
-dx:=-take_fraction(d_cos[kk],width_x)+take_fraction(d_cos[k],height_x);
-dy:=-take_fraction(d_cos[kk],width_y)+take_fraction(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):=explicit;
-right_type(p):=explicit;
-originator(p):=program_code
-
-@ @<Glob...@>=
-half_cos:array[0..7] of fraction; {${1\over2}\cos(45k)$}
-d_cos:array[0..7] of fraction; {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...@>=
-half_cos[0]:=fraction_half;
-half_cos[1]:=94906266; {$2^{26}\sqrt2\approx94906265.62$}
-half_cos[2]:=0;@/
-d_cos[0]:=35596755; {$2^{28}d\approx35596754.69$}
-d_cos[1]:=25170707; {$2^{27}\sqrt2\,d\approx25170706.63$}
-d_cos[2]:=0;
-for k:=3 to 4 do
- begin half_cos[k]:=-half_cos[4-k];
- d_cos[k]:=-d_cos[4-k];
- end;
-for k:=5 to 7 do
- begin half_cos[k]:=half_cos[8-k];
- d_cos[k]:=d_cos[8-k];
- end;
-
-@ 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|@>@;
-function convex_hull(@!h:pointer):pointer; {Make a polygonal pen convex}
-label done1,done2,done3;
-var @!l,@!r:pointer; {the leftmost and rightmost knots}
-@!p,@!q:pointer; {knots being scanned}
-@!s:pointer; {the starting point for an upcoming scan}
-@!dx,@!dy:scaled; {a temporary pointer}
-begin if pen_is_elliptical(h) then convex_hull:=h
-else begin @<Set |l| to the leftmost knot in polygon~|h|@>;
- @<Set |r| to the rightmost knot in polygon~|h|@>;
- if l<>r then
- begin 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$@>;
- end;
- if l<>link(l) then @<Do a Gramm scan and remove vertices where there
- is no left turn@>;
- convex_hull:=l;
- end;
-end;
-
-@ 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 do
- begin if x_coord(p)<=x_coord(l) then
- if (x_coord(p)<x_coord(l)) or (y_coord(p)<y_coord(l)) then
- l:=p;
- p:=link(p);
- end
-
-@ @<Set |r| to the rightmost knot in polygon~|h|@>=
-r:=h;
-p:=link(h);
-while p<>h do
- begin if x_coord(p)>=x_coord(r) then
- if (x_coord(p)>x_coord(r)) or (y_coord(p)>y_coord(r)) then
- r:=p;
- p:=link(p);
- end
-
-@ @<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 do
- begin q:=link(p);
- if ab_vs_cd(dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 then
- move_knot(p,r);
- p:=q;
- end
-
-@ The |move_knot| procedure removes |p| from a doubly linked list and inserts
-it after |q|.
-
-@ @<Declare a procedure called |move_knot|@>=
-procedure move_knot(@!p,@!q:pointer);
-begin link(knil(p)):=link(p);
-knil(link(p)):=knil(p);@/
-knil(p):=q;
-link(p):=link(q);
-link(q):=p;
-knil(link(p)):=p;
-end;
-
-@ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
-p:=s;
-while p<>l do
- begin q:=link(p);
- if ab_vs_cd(dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 then
- move_knot(p,l);
- p:=q;
- end
-
-@ 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 do
- begin q:=knil(p);
- while x_coord(q)>x_coord(p) do q:=knil(q);
- while x_coord(q)=x_coord(p) do
- if y_coord(q)>y_coord(p) then q:=knil(q) else goto done1;
-done1:
- if q=knil(p) then p:=link(p)
- else begin p:=link(p); move_knot(knil(p),q);
- end;
- end
-
-@ @<Sort the path from |r| to |l| by decreasing $x$@>=
-p:=link(r);
-while p<>l do
- begin q:=knil(p);
- while x_coord(q)<x_coord(p) do q:=knil(q);
- while x_coord(q)=x_coord(p) do
- if y_coord(q)<y_coord(p) then q:=knil(q) else goto done2;
-done2:
- if q=knil(p) then p:=link(p)
- else begin p:=link(p); move_knot(knil(p),q);
- end;
- end
-
-@ 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...@>=
-begin p:=l; q:=link(l);
-loop @+begin dx:=x_coord(q)-x_coord(p);
- dy:=y_coord(q)-y_coord(p);
- p:=q; q:=link(q);
- if p=l then goto done3;
- if p<>r then
- if ab_vs_cd(dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 then
- @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
- end;
-done3: do_nothing;
-end
-
-@ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
-begin s:=knil(p);
-free_node(p,knot_node_size);
-link(s):=q; knil(q):=s;
-if s=l then p:=s
-else begin p:=knil(s); q:=s;
- end;
-end
-
-@ 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.
-
-@p procedure find_offset(@!x,@!y:scaled;@!h:pointer);
-var @!p,@!q:pointer; {consecutive knots}
-@!wx,@!wy,@!hx,@!hy:scaled;
- {the transformation matrix for an elliptical pen}
-@!xx,@!yy:fraction; {untransformed offset for an elliptical pen}
-@!d:fraction; {a temporary register}
-begin if pen_is_elliptical(h) then
- @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
-else begin q:=h;
- repeat p:=q; q:=link(q);
- until ab_vs_cd(x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0;
- repeat p:=q; q:=link(q);
- until ab_vs_cd(x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0;
- cur_x:=x_coord(p);
- cur_y:=y_coord(p);
- end;
-end;
-
-@ @<Glob...@>=
-@!cur_x,@!cur_y:scaled; {all-purpose return value registers}
-
-@ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
-if (x=0) and (y=0) then
- begin cur_x:=x_coord(h); cur_y:=y_coord(h); @+end
-else begin @<Find the non-constant part of the transformation for |h|@>;
- while (abs(x)<fraction_half) and (abs(y)<fraction_half) do
- begin double(x); double(y); @+end;
- @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
- untransformed version of |(x,y)|@>;
- cur_x:=x_coord(h)+take_fraction(xx,wx)+take_fraction(yy,hx);
- cur_y:=y_coord(h)+take_fraction(xx,wy)+take_fraction(yy,hy);
- end
-
-@ @<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:=-(take_fraction(x,hy)+take_fraction(y,-hx));@/
-xx:=take_fraction(x,-wy)+take_fraction(y,wx);@/
-d:=pyth_add(xx,yy);@/
-if d>0 then
- begin xx:=half(make_fraction(xx,d));
- yy:=half(make_fraction(yy,d));
- end
-
-@ 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|.
-
-@p procedure pen_bbox(@!h:pointer);
-var @!p:pointer; {for scanning the knot list}
-begin if pen_is_elliptical(h) then
- @<Find the bounding box of an elliptical pen@>
-else begin minx:=x_coord(h); maxx:=minx;
- miny:=y_coord(h); maxy:=miny;@/
- p:=link(h);
- while p<>h do
- begin if x_coord(p)<minx then minx:=x_coord(p);
- if y_coord(p)<miny then miny:=y_coord(p);
- if x_coord(p)>maxx then maxx:=x_coord(p);
- if y_coord(p)>maxy then maxy:=y_coord(p);
- p:=link(p);
- end;
- end;
-end;
-
-@ @<Find the bounding box of an elliptical pen@>=
-begin find_offset(0,fraction_one,h);
-maxx:=cur_x;
-minx:=2*x_coord(h)-cur_x;@/
-find_offset(-fraction_one,0,h);
-maxy:=cur_y;
-miny:=2*y_coord(h)-cur_y;
-end
-
-@* \[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.
-
-@ 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(#)==link(#+1)
- {a pointer to the path that needs filling}
-@d pen_p(#)==info(#+1)
- {a pointer to the pen to fill or stroke with}
-@d color_model(#)==type(#+2) { the color model }
-@d obj_red_loc(#)==#+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(#)==mem[#+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(#)==mem[#+4].sc
- {the green component of the color in the range $0\ldots1$}
-@d magenta_val==green_val
-@d blue_val(#)==mem[#+5].sc
- {the blue component of the color in the range $0\ldots1$}
-@d yellow_val==blue_val
-@d black_val(#)==mem[#+6].sc
- {the blue component of the color in the range $0\ldots1$}
-@d ljoin_val(#)==name_type(#) {the value of \&{linejoin}}
-@:linejoin_}{\&{linejoin} primitive@>
-@d miterlim_val(#)==mem[#+7].sc {the value of \&{miterlimit}}
-@:miterlimit_}{\&{miterlimit} primitive@>
-@d obj_color_part(#)==mem[#+3-red_part].sc
- {interpret an object pointer that has been offset by |red_part..blue_part|}
-@d pre_script(#)==mem[#+8].hh.lh
-@d post_script(#)==mem[#+8].hh.rh
-@d fill_node_size=9
-@d fill_code=1
-
-@p function new_fill_node(@!p: pointer): pointer;
- {make a fill node for cyclic path |p| and color black}
-var @!t:pointer; {the new node}
-begin t:=get_node(fill_node_size);
- type(t):=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):=uninitialized_model;
- pre_script(t):=null;
- post_script(t):=null;
- @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
- new_fill_node:=t;
-end;
-
-@ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
-if internal[linejoin]>unity then ljoin_val(t):=2
-else if internal[linejoin]>0 then ljoin_val(t):=1
-else ljoin_val(t):=0;
-if internal[miterlimit]<unity then
- miterlim_val(t):=unity
-else miterlim_val(t):=internal[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(#)==link(#+9)
- {a pointer to the edge structure that gives the dash pattern}
-@d lcap_val(#)==type(#+9)
- {the value of \&{linecap}}
-@:linecap_}{\&{linecap} primitive@>
-@d dash_scale(#)==mem[#+10].sc {dash lengths are scaled by this factor}
-@d stroked_node_size=11
-@d stroked_code=2
-
-@p function new_stroked_node(@!p:pointer): pointer;
- {make a stroked node for path |p| with |pen_p(p)| temporarily |null|}
-var @!t:pointer; {the new node}
-begin t:=get_node(stroked_node_size);
- type(t):=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):=uninitialized_model;
- pre_script(t):=null;
- post_script(t):=null;
- @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
- if internal[linecap]>unity then lcap_val(t):=2
- else if internal[linecap]>0 then lcap_val(t):=1
- else lcap_val(t):=0;
- new_stroked_node:=t;
-end;
-
-@ 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|@>=
-function sqrt_det(a,b,c,d:scaled):scaled;
-var @!maxabs:scaled; {$max(|a|,|b|,|c|,|d|)$}
-@!s:integer; {amount by which the result of |square_rt| needs to be scaled}
-begin @<Initialize |maxabs|@>;
-s:=64;
-while (maxabs<fraction_one) and (s>1) do
- begin double(a); double(b); double(c); double(d);@/
- double(maxabs); s:=halfp(s);
- end;
-sqrt_det:=s*square_rt(abs(take_fraction(a,d)-take_fraction(b,c)));
-end;
-@#
-function get_pen_scale(p:pointer):scaled;
-begin get_pen_scale:=sqrt_det(
- left_x(p)-x_coord(p), right_x(p)-x_coord(p),@/
- left_y(p)-y_coord(p), right_y(p)-y_coord(p));
-end;
-
-@ @<Initialize |maxabs|@>=
-maxabs:=abs(a);
-if abs(b)>maxabs then maxabs:=abs(b);
-if abs(c)>maxabs then maxabs:=abs(c);
-if abs(d)>maxabs then 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(#)==link(#+1) {a string pointer for the text to display}
-@d font_n(#)==info(#+1) {the font number}
-@d width_val(#)==mem[#+7].sc {unscaled width of the text}
-@d height_val(#)==mem[#+9].sc {unscaled height of the text}
-@d depth_val(#)==mem[#+10].sc {unscaled depth of the text}
-@d text_tx_loc(#)==#+11
- {the first of six locations for transformation parameters}
-@d tx_val(#)==mem[#+11].sc {$x$ shift amount}
-@d ty_val(#)==mem[#+12].sc {$y$ shift amount}
-@d txx_val(#)==mem[#+13].sc {|txx| transformation parameter}
-@d txy_val(#)==mem[#+14].sc {|txy| transformation parameter}
-@d tyx_val(#)==mem[#+15].sc {|tyx| transformation parameter}
-@d tyy_val(#)==mem[#+16].sc {|tyy| transformation parameter}
-@d text_trans_part(#)==mem[#+11-x_part].sc
- {interpret a text node ponter that has been offset by |x_part..yy_part|}
-@d text_node_size=17
-@d text_code=3
-
-@p @<Declare text measuring subroutines@>@;
-function new_text_node(f,s:str_number):pointer;
- {make a text node for font |f| and text string |s|}
-var @!t:pointer; {the new node}
-begin t:=get_node(text_node_size);
- type(t):=text_code;
- text_p(t):=s;
- font_n(t):=find_font(f); {this identifies the font}
- red_val(t):=0;
- green_val(t):=0;
- blue_val(t):=0;
- black_val(t):=0;
- color_model(t):=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;
- set_text_box(t); {this finds the bounding box}
- new_text_node:=t;
-end;
-
-@ 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_clip_code=4 {|type| of a node that starts clipping}
-@d start_bounds_size=2
-@d start_bounds_code=5 {|type| of a node that gives a \&{setbounds} path}
-@d stop_clip_size=2 {the second word is not used here}
-@d stop_clip_code=6 {|type| of a node that stops clipping}
-@d stop_bounds_size=2 {the second word is not used here}
-@d stop_bounds_code=7 {|type| of a node that stops \&{setbounds}}
-@#
-@d stop_type(#)==(#+2)
- {matching |type| for |start_clip_code| or |start_bounds_code|}
-@d has_color(#)==(type(#)<start_clip_code)
- {does a graphical object have color fields?}
-@d has_pen(#)==(type(#)<text_code)
- {does a graphical object have a |pen_p| field?}
-@d is_start_or_stop(#)==(type(#)>=start_clip_code)
-@d is_stop(#)==(type(#)>=stop_clip_code)
-
-@p function new_bounds_node(@!p:pointer; c:small_number):pointer;
- {make a node of type |c| where |p| is the clipping or \&{setbounds} path}
-var @!t:pointer; {the new node}
-begin t:=get_node(gr_object_size[c]);
- type(t):=c;
- path_p(t):=p;
- new_bounds_node:=t;
-end;
-
-@ We need an array to keep track of the sizes of graphical objects.
-
-@<Glob...@>=
-gr_object_size: array[fill_code..stop_bounds_code] of small_number;
-
-@ @<Set init...@>=
-gr_object_size[fill_code]:=fill_node_size;
-gr_object_size[stroked_code]:=stroked_node_size;
-gr_object_size[text_code]:=text_node_size;
-gr_object_size[start_clip_code]:=start_clip_size;
-gr_object_size[stop_clip_code]:=stop_clip_size;
-gr_object_size[start_bounds_code]:=start_bounds_size;
-gr_object_size[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(#)==mem[#+1].sc {the starting $x$~coordinate in a dash node}
-@d stop_x(#)==mem[#+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(#)==mem[#+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
-|start_bounds_code| depends on the value of \&{truecorners}, the bounding box
-@: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(#)==mem[#+2].sc
-@d miny_val(#)==mem[#+3].sc
-@d maxx_val(#)==mem[#+4].sc
-@d maxy_val(#)==mem[#+5].sc
-@d bblast(#)==link(#+6) {last item considered in bounding box computation}
-@d bbtype(#)==info(#+6) {tells how bounding box data depends on \&{truecorners}}
-@d dummy_loc(#)==#+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$}
-
-@p procedure init_bbox(@!h:pointer);
- {Initialize the bounding box information in edge structure |h|}
-begin 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;
-end;
-
-@ 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(#)==info(#+7) {points to the last entry in the object list}
-@d edge_header_size=8
-
-@p procedure init_edges(@!h:pointer);
- {initialize an edge header to null values}
-begin dash_list(h):=null_dash;
-obj_tail(h):=dummy_loc(h);
-link(dummy_loc(h)):=null;
-ref_count(h):=null;
-init_bbox(h);
-end;
-
-@ 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(#)==incr(ref_count(#))
-@d delete_edge_ref(#)==if ref_count(#)=null then toss_edges(#)
- else decr(ref_count(#))
-
-@<Declare the recycling subroutines@>=
-@<Declare subroutines needed by |toss_edges|@>@;
-procedure toss_edges(@!h:pointer);
-var @!p,@!q:pointer; {pointers that scan the list being recycled}
-@!r:pointer; {an edge structure that object |p| refers to}
-begin flush_dash_list(h);
-q:=link(dummy_loc(h));
-while (q<>null) do
- begin p:=q; q:=link(q);
- r:=toss_gr_object(p);
- if r<>null then delete_edge_ref(r);
- end;
-free_node(h,edge_header_size);
-end;
-
-@ @<Declare subroutines needed by |toss_edges|@>=
-procedure flush_dash_list(h:pointer);
-var @!p,@!q:pointer; {pointers that scan the list being recycled}
-begin q:=dash_list(h);
-while q<>null_dash do
- begin p:=q; q:=link(q);
- free_node(p,dash_node_size);
- end;
-dash_list(h):=null_dash;
-end;
-
-@ @<Declare subroutines needed by |toss_edges|@>=
-function toss_gr_object(@!p:pointer):pointer;
- {returns an edge structure that needs to be dereferenced}
-var @!e:pointer; {the edge structure to return}
-begin e:=null;
-@<Prepare to recycle graphical object |p|@>;
-free_node(p,gr_object_size[type(p)]);@/
-toss_gr_object:=e;
-end;
-
-@ @<Prepare to recycle graphical object |p|@>=
-case type(p) of
-fill_code: begin toss_knot_list(path_p(p));
- if pen_p(p)<>null then toss_knot_list(pen_p(p));
- if pre_script(p)<>null then delete_str_ref(pre_script(p));
- if post_script(p)<>null then delete_str_ref(post_script(p));
- end;
-stroked_code: begin toss_knot_list(path_p(p));
- if pen_p(p)<>null then toss_knot_list(pen_p(p));
- if pre_script(p)<>null then delete_str_ref(pre_script(p));
- if post_script(p)<>null then delete_str_ref(post_script(p));
- e:=dash_p(p);
- end;
-text_code: begin
- delete_str_ref(text_p(p));
- if pre_script(p)<>null then delete_str_ref(pre_script(p));
- if post_script(p)<>null then delete_str_ref(post_script(p));
- end;
-start_clip_code,start_bounds_code: toss_knot_list(path_p(p));
-stop_clip_code,stop_bounds_code: do_nothing;
-end; {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.
-
-@p @<Declare a function called |copy_objects|@>@;
-function private_edges(h:pointer):pointer;
- {make a private copy of the edge structure headed by |h|}
-var @!hh:pointer; {the edge header for the new copy}
- @!p,@!pp: pointer; {pointers for copying the dash list}
-begin if ref_count(h)=null then private_edges:=h
-else begin decr(ref_count(h));
- hh:=copy_objects(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@>;
- private_edges:=hh;
- end;
-end;
-
-@ 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) do
- begin link(pp):=get_node(dash_node_size);
- pp:=link(pp);@/
- start_x(pp):=start_x(p);
- stop_x(pp):=stop_x(p);
- p:=link(p);
- end;
-link(pp):=null_dash;
-dash_y(hh):=dash_y(h)
-
-@ @<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)) do
- begin if p=null then confusion("bblast");
-@:this can't happen bblast}{\quad bblast@>
- p:=link(p); pp:=link(pp);
- end;
-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|@>=
-function copy_objects(p, q:pointer):pointer;
-var @!hh: pointer; {the new edge header}
- @!pp:pointer; {the last newly copied object}
- @!k:small_number; {temporary register}
-begin hh:=get_node(edge_header_size);
-dash_list(hh):=null_dash;
-ref_count(hh):=null;@/
-pp:=dummy_loc(hh);
-while (p<>q) do
- @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
-obj_tail(hh):=pp;
-link(pp):=null;
-copy_objects:=hh;
-end;
-
-@ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
-begin k:=gr_object_size[type(p)];@/
-link(pp):=get_node(k);
-pp:=link(pp);
-while (k>0) do
- begin decr(k); mem[pp+k]:=mem[p+k]; @+end;
-@<Fix anything in graphical object |pp| that should differ from the
- corresponding field in |p|@>;
-p:=link(p);
-end
-
-@ @<Fix anything in graphical object |pp| that should differ from the...@>=
-case type(p) of
-start_clip_code,start_bounds_code: path_p(pp):=copy_path(path_p(p));
-fill_code: begin path_p(pp):=copy_path(path_p(p));
- if pre_script(p)<>null then add_str_ref(pre_script(pp));
- if post_script(p)<>null then add_str_ref(post_script(pp));
- if pen_p(p)<>null then pen_p(pp):=copy_pen(pen_p(p));
- end;
-stroked_code: begin path_p(pp):=copy_path(path_p(p));
- if pre_script(p)<>null then add_str_ref(pre_script(pp));
- if post_script(p)<>null then add_str_ref(post_script(pp));
- pen_p(pp):=copy_pen(pen_p(p));
- if dash_p(p)<>null then add_edge_ref(dash_p(pp));
- end;
-text_code: begin
- if pre_script(p)<>null then add_str_ref(pre_script(pp));
- if post_script(p)<>null then add_str_ref(post_script(pp));
- add_str_ref(text_p(pp));
- end;
-stop_clip_code,stop_bounds_code: do_nothing;
-end {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(#)==if not is_start_or_stop(#) then #:=link(#)
- else if not is_stop(#) then #:=skip_1component(#)
- else skipc_end
-@d skipc_end(#)==#
-
-@p function skip_1component(p:pointer):pointer;
-var @!lev:integer; {current nesting level}
-begin lev:=0;
-repeat if is_start_or_stop(p) then
- if is_stop(p) then decr(lev) @+else incr(lev);
-p:=link(p);
-until lev=0;
-skip_1component:=p;
-end;
-
-@ Here is a diagnostic routine for printing an edge structure in symbolic form.
-
-@<Declare subroutines for printing expressions@>=
-@<Declare subroutines needed by |print_edges|@>@;
-procedure print_edges(@!h:pointer;@!s:str_number;@!nuline:boolean);
-var @!p:pointer; {a graphical object to be printed}
-@!hh,@!pp:pointer; {temporary pointers}
-@!scf:scaled; {a scale factor for the dash pattern}
-@!ok_to_dash:boolean; {|false| for polygonal pen strokes}
-begin print_diagnostic("Edge structure",s,nuline);
-p:=dummy_loc(h);
-while link(p)<>null do
- begin p:=link(p);
- print_ln;
- case type(p) of
- @<Cases for printing graphical object node |p|@>@;
- othercases begin print("[unknown object type!]");
- end
- endcases;@/
- end;
-print_nl("End edges");
-if p<>obj_tail(h) then print("?");
-@.End edges?@>
-end_diagnostic(true);
-end;
-
-@ @<Cases for printing graphical object node |p|@>=
-fill_code: begin print("Filled contour ");
- print_obj_color(p);
- print_char(":"); print_ln;
- pr_path(path_p(p)); print_ln;
- if (pen_p(p)<>null) then
- begin @<Print join type for graphical object |p|@>;
- print(" with pen"); print_ln;
- pr_pen(pen_p(p));
- end;
- end;
-
-@ @<Print join type for graphical object |p|@>=
-case ljoin_val(p) of
-0:begin print("mitered joins limited ");
- print_scaled(miterlim_val(p));
- end;
-1:print("round joins");
-2:print("beveled joins");
-othercases print("?? joins");
-@.??@>
-endcases
-
-@ For stroked nodes, we need to print |lcap_val(p)| as well.
-
-@<Print join and cap types for stroked node |p|@>=
-case lcap_val(p) of
-0:print("butt");
-1:print("round");
-2:print("square");
-othercases print("??")
-@.??@>
-endcases;
-print(" 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|@>@;
-procedure print_obj_color(@!p:pointer);
-begin if color_model(p)=grey_model then
- if grey_val(p)>0 then
- begin print("greyed ");
- print_compact_node(obj_grey_loc(p),1);
- end
- else if color_model(p)=cmyk_model then
- if (cyan_val(p)>0) or (magenta_val(p)>0) or (yellow_val(p)>0) or (black_val(p)>0) then
- begin print("colored ");
- print_compact_node(obj_cyan_loc(p),4);
- end
- else if color_model(p)=rgb_model then
- if (red_val(p)>0) or (green_val(p)>0) or (blue_val(p)>0) then
- begin print("processcolored ");
- print_compact_node(obj_red_loc(p),3);
- end;
-end;
-
-@ 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|@>=
-procedure print_compact_node(@!p:pointer;k:small_number);
-var @!q:pointer; {last location to print}
-begin q:=p+k-1;
-print_char("(");
-while p<=q do
- begin print_scaled(mem[p].sc);
- if p<q then print_char(",");
- incr(p);
- end;
-print_char(")");
-end;
-
-@ @<Cases for printing graphical object node |p|@>=
-stroked_code: begin print("Filled pen stroke ");
- print_obj_color(p);
- print_char(":"); print_ln;
- pr_path(path_p(p));
- if dash_p(p)<>null then
- begin print_nl("dashed (");
- @<Finish printing the dash pattern that |p| refers to@>;
- end;
- print_ln;
- @<Print join and cap types for stroked node |p|@>;
- print(" with pen"); print_ln;
- if pen_p(p)=null then print("???") {shouldn't happen}
-@.???@>
- else pr_pen(pen_p(p));
- end;
-
-@ 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 not ok_to_dash then scf:=unity
-else scf:=dash_scale(p);
-hh:=dash_p(p);
-pp:=dash_list(hh);
-if (pp=null_dash) or (dash_y(hh)<0) then print(" ??")
-else begin start_x(null_dash):=start_x(pp)+dash_y(hh);
- while pp<>null_dash do
- begin print("on ");
- print_scaled(take_scaled(stop_x(pp)-start_x(pp),scf));
- print(" off ");
- print_scaled(take_scaled(start_x(link(pp))-stop_x(pp),scf));
- pp := link(pp);
- if pp<>null_dash then print_char(" ");
- end;
- print(") shifted ");
- print_scaled(-take_scaled(dash_offset(hh),scf));
- if not ok_to_dash or (dash_y(hh)=0) then print(" (this will be ignored)");
- end
-
-@ @<Declare subroutines needed by |print_edges|@>=
-function dash_offset(h:pointer):scaled;
-var @!x:scaled; {the answer}
-begin if (dash_list(h)=null_dash) or (dash_y(h)<0) then confusion("dash0");
-@:this can't happen dash0}{\quad dash0@>
-if dash_y(h)=0 then x:=0
-else begin x:=-(start_x(dash_list(h)) mod dash_y(h));
- if x<0 then x:=x+dash_y(h);
- end;
-dash_offset:=x;
-end;
-
-@ @<Cases for printing graphical object node |p|@>=
-text_code: begin print_char(""""); print(text_p(p));
- print(""" infont """); print(font_name[font_n(p)]);
- print_char(""""); print_ln;
- print_obj_color(p);
- print("transformed ");
- print_compact_node(text_tx_loc(p),6);
-end;
-
-@ @<Cases for printing graphical object node |p|@>=
-start_clip_code: begin print("clipping path:");
- print_ln;
- pr_path(path_p(p));
- end;
-stop_clip_code: print("stop clipping");
-
-@ @<Cases for printing graphical object node |p|@>=
-start_bounds_code: begin print("setbounds path:");
- print_ln;
- pr_path(path_p(p));
- end;
-stop_bounds_code: print("end of setbounds");
-
-@ 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$.
-
-@p @<Declare a procedure called |x_retrace_error|@>@;
-function make_dashes(h:pointer):pointer; {returns |h| or |null|}
-label exit, found, not_found;
-var @!p:pointer; {this scans the stroked nodes in the object list}
-@!y0:scaled; {the initial $y$ coordinate}
-@!p0:pointer; {if not |null| this points to the first stroked node}
-@!pp,@!qq,@!rr:pointer; {pointers into |path_p(p)|}
-@!d,@!dd:pointer; {pointers used to create the dash list}
-@<Other local variables in |make_dashes|@>@;
-begin if dash_list(h)<>null_dash then goto found;
-p0:=null; y0:=0;
-p:=link(dummy_loc(h));
-while p<>null do
- begin if type(p)<>stroked_code then
- @<Compain that the edge structure contains a node of the wrong type
- and |goto not_found|@>;
- pp:=path_p(p);
- if p0=null then
- begin p0:=p; y0:=y_coord(pp); @+end;
- @<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);
- end;
-if dash_list(h)=null_dash then 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@>;
-found:make_dashes:=h; return;
-not_found: @<Flush the dash list, recycle |h| and return |null|@>;
-exit:end;
-
-@ @<Compain that the edge structure contains a node of the wrong type...@>=
-begin 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.");@/
-put_get_error;
-goto not_found;
-end
-
-@ A similar error occurs when monotonicity fails.
-
-@<Declare a procedure called |x_retrace_error|@>=
-procedure x_retrace_error;
-begin 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.");
-put_get_error;
-end;
-
-@ 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 then
- repeat qq:=rr; rr:=link(rr);
- @<Check for retracing between knots |qq| and |rr| and |goto not_found|
- if there is a problem@>;
- until right_type(rr)=endpoint;
-d:=get_node(dash_node_size);
-if dash_p(p)=0 then info(d):=0 @+else info(d):=p;
-if x_coord(pp)<x_coord(rr) then
- begin start_x(d):=x_coord(pp);
- stop_x(d):=x_coord(rr);
- end
-else begin start_x(d):=x_coord(rr);
- stop_x(d):=x_coord(pp);
- end;
-
-@ 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) or (x1>x2) or (x2>x3) then
- if (x0<x1) or (x1<x2) or (x2<x3) then
- if ab_vs_cd(x2-x1,x2-x1,x1-x0,x3-x2)>0 then
- begin x_retrace_error; goto not_found;
- end;
-if (x_coord(pp)>x0) or (x0>x3) then
- if (x_coord(pp)<x0) or (x0<x3) then
- begin x_retrace_error; goto not_found;
- end
-
-@ @<Other local variables in |make_dashes|@>=
-@!x0,@!x1,@!x2,@!x3:scaled; {$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)) or (black_val(p)<>black_val(p0)) or@|
- (green_val(p)<>green_val(p0)) or (blue_val(p)<>blue_val(p0)) then
- begin 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.");@/
- put_get_error;
- goto not_found;
- end
-
-@ @<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) do
- dd:=link(dd);
-if dd<>h then
- if (stop_x(dd)>start_x(d)) then
- begin x_retrace_error; goto not_found; @+end;
-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) do
- d:=link(d);
-dd:=dash_list(h);
-dash_y(h):=stop_x(d)-start_x(dd);
-if abs(y0)>dash_y(h) then
- dash_y(h):=abs(y0)
-else if d<>dd then
- begin dash_list(h):=link(dd);
- stop_x(d):=stop_x(dd)+dash_y(h);
- free_node(dd,dash_node_size);
- end
-
-@ 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|@>=
-flush_dash_list(h);
-delete_edge_ref(h);
-make_dashes:=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 do
- begin ds:=info(link(d));
- if ds=null then d:=link(d)
- else begin
- hh:=dash_p(ds);
- hsf:=dash_scale(ds);
- if (hh=null) then confusion("dash1");
-@:this can't happen dash0}{\quad dash1@>
- if dash_y(hh)=0 then d:=link(d)
- else begin if dash_list(hh)=null then confusion("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|@>;
- end;
- end;
- end
-
-@ @<Other local variables in |make_dashes|@>=
-@!dln:pointer; {|link(d)|}
-@!hh:pointer; {an edge header that tells how to break up |dln|}
-@!hsf:scaled; {the dash pattern from |hh| gets scaled by this}
-@!ds:pointer; {the stroked node from which |hh| and |hsf| are derived}
-@!xoff:scaled; {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)-take_scaled(hsf,start_x(dd))-
- take_scaled(hsf,dash_offset(hh));
-start_x(null_dash):=take_scaled(hsf,start_x(dd))+take_scaled(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) do
- begin @<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+take_scaled(hsf,start_x(dd));
- end;
-link(d):=link(dln);
-free_node(dln,dash_node_size)
-
-@ The name of this module is a bit of a lie because we actually 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+take_scaled(hsf,stop_x(dd))<start_x(dln) do
- dd:=link(dd)
-
-@ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
-if dd=null_dash then
- begin dd:=dash_list(hh);
- xoff:=xoff+take_scaled(hsf,dash_y(hh));
- end
-
-@ 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+take_scaled(hsf,start_x(dd))<=stop_x(dln) then
- begin link(d):=get_node(dash_node_size);
- d:=link(d);
- link(d):=dln;
- if start_x(dln)>xoff+take_scaled(hsf,start_x(dd))
- then start_x(d):=start_x(dln)
- else start_x(d):=xoff+take_scaled(hsf,start_x(dd));
- if stop_x(dln)<xoff+take_scaled(hsf,stop_x(dd)) then stop_x(d):=stop_x(dln)
- else stop_x(d):=xoff+take_scaled(hsf,stop_x(dd));
- end
-
-@ 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|.)
-
-@p procedure adjust_bbox(h:pointer);
-begin if minx<minx_val(h) then minx_val(h):=minx;
-if miny<miny_val(h) then miny_val(h):=miny;
-if maxx>maxx_val(h) then maxx_val(h):=maxx;
-if maxy>maxy_val(h) then maxy_val(h):=maxy;
-end;
-
-@ 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|.
-
-@p procedure box_ends(@!p, @!pp, @!h:pointer);
-label exit;
-var @!q:pointer; {a knot node adjacent to knot |p|}
-@!dx,@!dy:fraction; {a unit vector in the direction out of the path at~|p|}
-@!d:scaled; {a factor for adjusting the length of |(dx,dy)|}
-@!z:scaled; {a coordinate being tested against the bounding box}
-@!xx,@!yy:scaled; {the extreme pen vertex in the |(dx,dy)| direction}
-@!i:integer; {a loop counter}
-begin if right_type(p)<>endpoint then
- begin q:=link(p);
- loop @+begin @<Make |(dx,dy)| the final direction for the path segment from
- |q| to~|p|; set~|d|@>;
- d:=pyth_add(dx,dy);
- if d>0 then
- begin @<Normalize the direction |(dx,dy)| and find the pen offset
- |(xx,yy)|@>;
- for i:=1 to 2 do
- begin @<Use |(dx,dy)| to generate a vertex of the square end cap and
- update the bounding box to accommodate it@>;@/
- dx:=-dx; dy:=-dy;
- end;
- end;
- if right_type(p)=endpoint then return
- else @<Advance |p| to the end of the path and make |q| the previous knot@>;
- end;
- end;
-exit: ;
-end;
-
-@ @<Make |(dx,dy)| the final direction for the path segment from...@>=
-if q=link(p) then
- begin dx:=x_coord(p)-right_x(p);
- dy:=y_coord(p)-right_y(p);
- if (dx=0)and(dy=0) then
- begin dx:=x_coord(p)-left_x(q);
- dy:=y_coord(p)-left_y(q);
- end;
- end
-else begin dx:=x_coord(p)-left_x(p);
- dy:=y_coord(p)-left_y(p);
- if (dx=0)and(dy=0) then
- begin dx:=x_coord(p)-right_x(q);
- dy:=y_coord(p)-right_y(q);
- end;
- end;
-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:=make_fraction(dx,d);
-dy:=make_fraction(dy,d);@/
-find_offset(-dy,dx,pp);
-xx:=cur_x; yy:=cur_y
-
-@ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
-find_offset(dx,dy,pp);
-d:=take_fraction(xx-cur_x,dx)+take_fraction(yy-cur_y,dy);
-if (d<0)and(i=1) or (d>0)and(i=2) then confusion("box_ends");
-@:this can't happen box ends}{\quad\\{box_ends}@>
-z:=x_coord(p)+cur_x+take_fraction(d,dx);
-if z<minx_val(h) then minx_val(h):=z;
-if z>maxx_val(h) then maxx_val(h):=z;
-z:=y_coord(p)+cur_y+take_fraction(d,dy);
-if z<miny_val(h) then miny_val(h):=z;
-if z>maxy_val(h) then maxy_val(h):=z
-
-@ @<Advance |p| to the end of the path and make |q| the previous knot@>=
-repeat q:=p;
-p:=link(p);
-until right_type(p)=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.
-
-@p procedure set_bbox(@!h:pointer;top_level:boolean);
-label exit;
-var @!p:pointer; {a graphical object being considered}
-@!sminx,@!sminy,@!smaxx,@!smaxy:scaled;
- {for saving the bounding box during recursive calls}
-@!x0,@!x1,@!y0,@!y1:scaled; {temporary registers}
-@!lev:integer; {nesting level for |start_bounds_code| nodes}
-begin @<Wipe out any existing bounding box information if |bbtype(h)| is
- incompatible with |internal[true_corners]|@>;
-while link(bblast(h))<>null do
- begin p:=link(bblast(h));
- bblast(h):=p;
- case type(p) of
- stop_clip_code: if top_level then confusion("bbox") @+else return;
-@:this can't happen bbox}{\quad bbox@>
- @<Other cases for updating the bounding box based on the type of object |p|@>@;
- end; {all cases are enumerated above}
- end;
-if not top_level then confusion("bbox");
-exit:end;
-
-@ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
-case bbtype(h) of
-no_bounds: do_nothing;
-bounds_set: if internal[true_corners]>0 then init_bbox(h);
-bounds_unset: if internal[true_corners]<=0 then init_bbox(h);
-end {there are no other cases}
-
-@ @<Other cases for updating the bounding box...@>=
-fill_code: begin path_bbox(path_p(p));
- if pen_p(p)<>null then
- begin x0:=minx; y0:=miny;
- x1:=maxx; y1:=maxy;
- pen_bbox(pen_p(p));
- minx:=minx+x0;
- miny:=miny+y0;
- maxx:=maxx+x1;
- maxy:=maxy+y1;
- end;
- adjust_bbox(h);
- end;
-
-@ @<Other cases for updating the bounding box...@>=
-start_bounds_code: if internal[true_corners]>0 then bbtype(h):=bounds_unset
- else begin bbtype(h):=bounds_set;
- path_bbox(path_p(p));
- adjust_bbox(h);
- @<Scan to the matching |stop_bounds_code| node and update |p| and
- |bblast(h)|@>;
- end;
-stop_bounds_code: if internal[true_corners]<=0 then confusion("bbox2");
-@:this can't happen bbox2}{\quad bbox2@>
-
-@ @<Scan to the matching |stop_bounds_code| node and update |p| and...@>=
-lev:=1;
-while lev<>0 do
- begin if link(p)=null then confusion("bbox2");
-@:this can't happen bbox2}{\quad bbox2@>
- p:=link(p);
- if type(p)=start_bounds_code then incr(lev)
- else if type(p)=stop_bounds_code then decr(lev);
- end;
-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...@>=
-stroked_code: begin path_bbox(path_p(p));
- x0:=minx; y0:=miny;
- x1:=maxx; y1:=maxy;
- pen_bbox(pen_p(p));
- minx:=minx+x0;
- miny:=miny+y0;
- maxx:=maxx+x1;
- maxy:=maxy+y1;
- adjust_bbox(h);
- if (left_type(path_p(p))=endpoint)and(lcap_val(p)=2) then
- box_ends(path_p(p), pen_p(p), h);
- end;
-
-@ 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...@>=
-text_code: begin x1:=take_scaled(txx_val(p),width_val(p));
- y0:=take_scaled(txy_val(p),-depth_val(p));
- y1:=take_scaled(txy_val(p),height_val(p));
- minx:=tx_val(p);
- maxx:=minx;
- if y0<y1 then
- begin minx:=minx+y0; maxx:=maxx+y1; @+end
- else begin minx:=minx+y1; maxx:=maxx+y0; @+end;
- if x1<0 then minx:=minx+x1 @+else maxx:=maxx+x1;
- x1:=take_scaled(tyx_val(p),width_val(p));
- y0:=take_scaled(tyy_val(p),-depth_val(p));
- y1:=take_scaled(tyy_val(p),height_val(p));
- miny:=ty_val(p);
- maxy:=miny;
- if y0<y1 then
- begin miny:=miny+y0; maxy:=maxy+y1; @+end
- else begin miny:=miny+y1; maxy:=maxy+y0; @+end;
- if x1<0 then miny:=miny+x1 @+else maxy:=maxy+x1;
- adjust_bbox(h);
- end;
-
-@ This case involves a recursive call that advances |bblast(h)| to the node of
-type |stop_clip_code| that matches |p|.
-
-@<Other cases for updating the bounding box...@>=
-start_clip_code: begin path_bbox(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;
- adjust_bbox(h);
- end;
-
-@ @<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;@/
-set_bbox(h,false)
-
-@ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
-if minx_val(h)<x0 then minx_val(h):=x0;
-if miny_val(h)<y0 then miny_val(h):=y0;
-if maxx_val(h)>x1 then maxx_val(h):=x1;
-if maxy_val(h)>y1 then 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...@>=
-spec_offset:integer; {number of pen edges between |h| and the initial offset}
-
-@ @p @t\4@>@<Declare subroutines needed by |offset_prep|@>@;
-function offset_prep(@!c,@!h:pointer):pointer;
-label not_found;
-var @!n:halfword; {the number of vertices in the pen polygon}
-@!p,@!q,@!q0,@!c0,@!r,@!w,@!ww:pointer; {for list manipulation}
-@!k_needed:integer; {amount to be added to |info(p)| when it is computed}
-@!w0:pointer; {a pointer to pen offset to use just before |p|}
-@!dxin,@!dyin:scaled; {the direction into knot |p|}
-@!turn_amt:integer; {change in pen offsets for the current cubic}
-@<Other local variables for |offset_prep|@>@;
-begin @<Initialize the pen size~|n|@>;
-@<Initialize the incoming direction and pen offset at |c|@>;
-p:=c; c0:=c; k_needed:=0;
-repeat 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@>;
-@<Advance |p| to node |q|, removing any ``dead'' cubics that
- might have been introduced by the splitting process@>;
-until q=c;
-@<Fix the offset change in |info(c)| and set the return value of
- |offset_prep|@>;
-end;
-
-@ 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...@>=
-@!spec_p1,@!spec_p2:pointer; {pointers to distinguished knots}
-
-@ @<Set init...@>=
-spec_p1:=null; spec_p2:=null;
-
-@ @<Initialize the pen size~|n|@>=
-n:=0; p:=h;
-repeat incr(n);
-p:=link(p);
-until 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)and(dyin=0) then
- begin dxin:=y_coord(knil(h))-y_coord(h);
- dyin:=x_coord(h)-x_coord(knil(h));
- end;
-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;
-repeat r:=link(p);
-if x_coord(p)=right_x(p) then if y_coord(p)=right_y(p) then
- if x_coord(p)=left_x(r) then if y_coord(p)=left_y(r) then
- if x_coord(p)=x_coord(r) then if y_coord(p)=y_coord(r) then
- if r<>p then
- @<Remove the cubic following |p| and update the data structures
- to merge |r| into |p|@>;
-p:=r;
-until p=q;
-{ Check if we removed too much }
-if (q<>q0) and ((q<>c) or (c=c0)) then q:=link(q)
-
-@ @<Remove the cubic following |p| and update the data structures...@>=
-begin k_needed:=info(p)-zero_off;
-if r=q then q:=p
-else begin info(p):=k_needed+info(r);
- k_needed:=0;
- end;
-if r=c then
- begin info(p):=info(c); c:=p;
- end;
-if r=spec_p1 then spec_p1:=p;
-if r=spec_p2 then spec_p2:=p;
-r:=p; remove_cubic(p);
-end
-
-@ Not setting the |info| field of the newly created knot allows the splitting
-routine to work for paths.
-
-@<Declare subroutines needed by |offset_prep|@>=
-procedure split_cubic(@!p:pointer;@!t:fraction); {splits the cubic after |p|}
-var @!v:scaled; {an intermediate value}
-@!q,@!r:pointer; {for list manipulation}
-begin q:=link(p); r:=get_node(knot_node_size); link(p):=r; link(r):=q;@/
-originator(r):=program_code;@/
-left_type(r):=explicit; right_type(r):=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));
-end;
-
-@ This does not set |info(p)| or |right_type(p)|.
-
-@<Declare subroutines needed by |offset_prep|@>=
-procedure remove_cubic(@!p:pointer); {removes the dead cubic following~|p|}
-var @!q:pointer; {the node that disappears}
-begin q:=link(p); link(p):=link(q);@/
-right_x(p):=right_x(q); right_y(p):=right_y(q);@/
-free_node(q,knot_node_size);
-end;
-
-@ 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:=pen_walk(w0,turn_amt);
-not_found: do_nothing
-
-@ @<Declare subroutines needed by |offset_prep|@>=
-function pen_walk(@!w:pointer;@!k:integer):pointer;
- {walk |k| steps around a pen from |w|}
-begin while k>0 do begin w:=link(w); decr(k); @+end;
-while k<0 do begin w:=knil(w); incr(k); @+end;
-pen_walk:=w;
-end;
-
-@ 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|@>=
-@!x0,@!x1,@!x2,@!y0,@!y1,@!y2:integer; {representatives of derivatives}
-@!t0,@!t1,@!t2:integer; {coefficients of polynomial for slope testing}
-@!du,@!dv,@!dx,@!dy:integer; {for directions of the pen and the curve}
-@!dx0,@!dy0:integer; {initial direction for the first cubic in the curve}
-@!max_coef:integer; {used while scaling}
-@!x0a,@!x1a,@!x2a,@!y0a,@!y1a,@!y2a:integer; {intermediate values}
-@!t:fraction; {where the derivative passes through zero}
-@!s:fraction; {a temporary value}
-
-@ @<Prepare for derivative computations...@>=
-dx0:=0; dy0:=0;
-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 then max_coef:=abs(x1);
-if abs(x2)>max_coef then max_coef:=abs(x2);
-if abs(y0)>max_coef then max_coef:=abs(y0);
-if abs(y1)>max_coef then max_coef:=abs(y1);
-if abs(y2)>max_coef then max_coef:=abs(y2);
-if max_coef=0 then goto not_found;
-while max_coef<fraction_half do
- begin double(max_coef);
- double(x0); double(x1); double(x2);
- double(y0); double(y1); double(y2);
- end
-
-@ 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|@>=
-procedure fin_offset_prep(@!p:pointer;@!w:pointer;
- @!x0,@!x1,@!x2,@!y0,@!y1,@!y2:integer;@!rise,@!turn_amt:integer);
-label exit;
-var @!ww:pointer; {for list manipulation}
-@!du,@!dv:scaled; {for slope calculation}
-@!t0,@!t1,@!t2:integer; {test coefficients}
-@!t:fraction; {place where the derivative passes a critical slope}
-@!s:fraction; {slope or reciprocal slope}
-@!v:integer; {intermediate value for updating |x0..y2|}
-@!q:pointer; {original |link(p)|}
-begin q:=link(p);
-loop @+begin if rise>0 then 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:=crossing_point(t0,t1,t2);
- if t>=fraction_one then
- if turn_amt>0 then t:=fraction_one @+else return;
- @<Split the cubic at $t$,
- and split off another cubic if the derivative crosses back@>;
- w:=ww;
- end;
-exit:end;
-
-@ 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) then {$s_{k-1}\le1$ or $s_k\le1$}
- begin s:=make_fraction(dv,du);
- t0:=take_fraction(x0,s)-y0;
- t1:=take_fraction(x1,s)-y1;
- t2:=take_fraction(x2,s)-y2;
- if du<0 then begin negate(t0); negate(t1); negate(t2); @+end
- end
-else begin s:=make_fraction(du,dv);
- t0:=x0-take_fraction(y0,s);
- t1:=x1-take_fraction(y1,s);
- t2:=x2-take_fraction(y2,s);
- if dv<0 then begin negate(t0); negate(t1); negate(t2); @+end
- end;
-if t0<0 then 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...@>=
-begin split_cubic(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 then
- begin t1:=t_of_the_way(t1)(t2);
- if t1>0 then t1:=0; {without rounding error, |t1| would be |<=0|}
- t:=crossing_point(0,-t1,-t2);
- if t>fraction_one then t:=fraction_one;
- incr(turn_amt);
- if (t=fraction_one)and(link(p)<>q) then
- info(link(p)):=info(link(p))-rise
- else begin split_cubic(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);@/
- end;
- end;
-end
-
-@ 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 then if dy=0 then
- begin dx:=x1; dy:=y1;
- if dx=0 then if dy=0 then
- begin dx:=x2; dy:=y2;
- end;
- end;
-if p=c then begin dx0:=dx; dy0:=dy; @+end
-
-@ @<Find the final direction |(dxin,dyin)|@>=
-dxin:=x2; dyin:=y2;
-if dxin=0 then if dyin=0 then
- begin dxin:=x1; dyin:=y1;
- if dxin=0 then if dyin=0 then
- begin dxin:=x0; dyin:=y0;
- end;
- end
-
-@ 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:=get_turn_amt(w0, dx, dy, ab_vs_cd(dy,dxin,dx,dyin)>=0);
-w:=pen_walk(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|@>=
-function get_turn_amt(@!w:pointer; @!dx,@!dy:scaled; ccw:boolean):integer;
-label done;
-var @!ww:pointer; {a neighbor of knot~|w|}
-@!s:integer; {turn amount so far}
-@!t:integer; {|ab_vs_cd| result}
-begin s:=0;
-if ccw then
- begin ww:=link(w);
- repeat t:=ab_vs_cd(dy,x_coord(ww)-x_coord(w),@| dx,y_coord(ww)-y_coord(w));
- if t<0 then goto done;
- incr(s);
- w:=ww; ww:=link(ww);
- until t<=0;
- done: end
-else begin ww:=knil(w);
- while ab_vs_cd(dy,x_coord(w)-x_coord(ww),@|
- dx,y_coord(w)-y_coord(ww))<0 do
- begin decr(s);
- w:=ww; ww:=knil(ww);
- end;
- end;
-get_turn_amt:=s;
-end;
-
-@ 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(#)==info(c):=info(c)+#
-
-@<Fix the offset change in |info(c)| and set the return value of...@>=
-spec_offset:=info(c)-zero_off;
-if link(c)=c then info(c):=zero_off+n
-else begin fix_by(k_needed);
- while w0<>h do
- begin fix_by(1); w0:=link(w0); @+end;
- while info(c)<=zero_off-n do fix_by(n);
- while info(c)>zero_off do fix_by(-n);
- if (info(c)<>zero_off)and(ab_vs_cd(dy0,dxin,dx0,dyin)>=0) then fix_by(n);
- end;
-offset_prep:=c
-
-@ 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 then
- fin_offset_prep(p,w,x0,x1,x2,y0,y1,y2,1,turn_amt)
-else begin split_cubic(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);@/
- fin_offset_prep(p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0:=x2a; y0:=y2a;
- info(r):=zero_off-1;
- if turn_amt>=0 then
- begin t1:=t_of_the_way(t1)(t2);
- if t1>0 then t1:=0;
- t:=crossing_point(0,-t1,-t2);
- if t>fraction_one then t:=fraction_one;
- @<Split off another rising cubic for |fin_offset_prep|@>;
- fin_offset_prep(r,ww,x0,x1,x2,y0,y1,y2,-1,0);
- end
- else fin_offset_prep(r,ww,x0,x1,x2,y0,y1,y2,-1,-1-turn_amt);
- end
-
-@ @<Split off another rising cubic for |fin_offset_prep|@>=
-split_cubic(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);@/
-fin_offset_prep(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:=crossing_point(t0,t1,t2);
-if turn_amt>=0 then
- if t2<0 then t:=fraction_one+1
- else begin u0:=t_of_the_way(x0)(x1);
- u1:=t_of_the_way(x1)(x2);
- ss:=take_fraction(-du,t_of_the_way(u0)(u1));@/
- v0:=t_of_the_way(y0)(y1);
- v1:=t_of_the_way(y1)(y2);
- ss:=ss+take_fraction(-dv,t_of_the_way(v0)(v1));@/
- if ss<0 then t:=fraction_one+1;
- end
-else if t>fraction_one then t:=fraction_one;
-
-@ @<Other local variables for |offset_prep|@>=
-@!u0,@!u1,@!v0,@!v1:integer; {intermediate values for $d(t)$ calculation}
-@!ss:integer; {the part of the dot product computed so far}
-@!d_sign:-1..1; {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:=ab_vs_cd(dx,dyin, dxin,dy);
-if d_sign=0 then
- @<Check rotation direction based on node position@>;
-if d_sign=0 then
- if dx=0 then
- if dy>0 then d_sign:=1 @+else d_sign:=-1
- else if dx>0 then 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:=get_turn_amt(w, dxin, dyin, d_sign>0);
-if ss<0 then 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@>=
-begin
-u0:=x_coord(q)-x_coord(p);
-u1:=y_coord(q)-y_coord(p);
-d_sign:=half(ab_vs_cd(dx, u1, u0, dy)+ab_vs_cd(u0, dyin, dxin, u1));
-end
-
-
-@ 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(take_fraction(x0,y2))-half(take_fraction(x2,y0));@/
-t1:=half(take_fraction(x1,y0+y2))-half(take_fraction(y1,x0+x2));@/
-if t0=0 then t0:=d_sign; {path reversal always negates |d_sign|}
-if t0>0 then
- begin t:=crossing_point(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);
- end
-else begin t:=crossing_point(-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);
- end;
-ss:=take_fraction(x0+x2,t_of_the_way(u0)(u1))+@|
- take_fraction(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.
-
-@p procedure print_spec(@!cur_spec,@!cur_pen:pointer;@!s:str_number);
-var @!p,@!q:pointer; {list traversal}
-@!w:pointer; {the current pen offset}
-begin print_diagnostic("Envelope spec",s,true);
-p:=cur_spec; w:=pen_walk(cur_pen,spec_offset);
-print_ln;@/
-print_two(x_coord(cur_spec),y_coord(cur_spec));
-print(" % beginning with offset ");
-print_two(x_coord(w),y_coord(w));
-repeat
- repeat q:=link(p);
- @<Print the cubic between |p| and |q|@>;
- p:=q;
- until (p=cur_spec) or (info(p)<>zero_off);
- if info(p)<>zero_off then
- @<Update |w| as indicated by |info(p)| and print an explanation@>;
-until p=cur_spec;
-print_nl(" & cycle");
-end_diagnostic(true);
-end;
-
-@ @<Update |w| as indicated by |info(p)| and print an explanation@>=
-begin w:=pen_walk(w,info(p)-zero_off);
-print(" % ");
-if info(p)>zero_off then print("counter");
-print("clockwise to offset ");
-print_two(x_coord(w),y_coord(w));
-end
-
-@ @<Print the cubic between |p| and |q|@>=
-begin print_nl(" ..controls ");
-print_two(right_x(p),right_y(p));
-print(" and ");
-print_two(left_x(q),left_y(q));
-print_nl(" ..");
-print_two(x_coord(q),y_coord(q));
-end
-
-@ 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|.
-
-@p @t\4@>@<Declare a function called |insert_knot|@>@;
-function make_envelope(@!c,@!h:pointer;@!ljoin,@!lcap:small_number;
- @!miterlim:scaled):pointer;
-label done;
-var @!p,@!q,@!r,@!q0:pointer; {for manipulating the path}
-@!join_type:0..3; {codes |0..3| for mitered, round, beveled, or square}
-@!w,@!w0:pointer; {the pen knot for the current offset}
-@!qx,@!qy:scaled; {unshifted coordinates of |q|}
-@!k,@!k0:halfword; {controls pen edge insertion}
-@<Other local variables for |make_envelope|@>@;
-begin spec_p1:=null; spec_p2:=null;
-if left_type(c)=endpoint then
- @<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;
-repeat q:=link(p); q0:=q;
-qx:=x_coord(q); qy:=y_coord(q);
-k:=info(q);@/
-k0:=k; w0:=w;
-dxin:=0;
-if k<>zero_off then
- @<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 do
- begin @<Step |w| and move |k| one step closer to |zero_off|@>;
- if (join_type=1)or(k=zero_off) then
- q:=insert_knot(q,qx+x_coord(w),qy+y_coord(w));
- end;
-if q<>link(p) then @<Set |p=link(p)| and add knots between |p| and |q| as
- requred by |join_type|@>;
-p:=q;
-until q0=c;
-make_envelope:=c;
-end;
-
-@ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
-c:=offset_prep(c,h);
-if internal[tracing_specs]>0 then print_spec(c,h,"");
-h:=pen_walk(h,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|@>=
-dxin:=0; dyin:=0; dxout:=0; dyout:=0; join_type:=0;
-if k<zero_off then join_type:=2
-else begin if (q<>spec_p1)and(q<>spec_p2) then join_type:=ljoin
- else if lcap=2 then join_type:=3
- else join_type:=2-lcap;
- if (join_type=0)or(join_type=3) then
- begin @<Set the incoming and outgoing directions at |q|; in case of
- degeneracy set |join_type:=2|@>;
- if join_type=0 then
- @<If |miterlim| is less than the secant of half the angle at |q|
- then set |join_type:=2|@>;
- end;
- end
-
-@ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
-begin tmp:=take_fraction(miterlim,fraction_half+@|
- half(take_fraction(dxin,dxout)+take_fraction(dyin,dyout)));
-if tmp<unity then
- if take_scaled(miterlim,tmp)<unity then join_type:=2;
-end
-
-@ @<Other local variables for |make_envelope|@>=
-@!dxin,@!dyin,@!dxout,@!dyout:fraction;
- {directions at |q| when square or mitered}
-@!tmp:scaled; {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):=explicit;
-right_type(q):=explicit
-
-@ @<Step |w| and move |k| one step closer to |zero_off|@>=
-if k>zero_off then
- begin w:=link(w); decr(k); @+end
-else begin w:=knil(w); incr(k); @+end
-
-@ 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|@>=
-function insert_knot(@!q:pointer;@!x,@!y:scaled):pointer;
- {returns the inserted knot}
-var @!r:pointer; {the new knot}
-begin r:=get_node(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):=explicit;
-right_type(r):=explicit;
-originator(r):=program_code;@/
-insert_knot:=r;
-end;
-
-@ 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...@>=
-begin p:=link(p);
-if (join_type=0)or(join_type=3) then
- begin if join_type=0 then
- @<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 then
- begin right_x(r):=x_coord(r);
- right_y(r):=y_coord(r);
- end;
- end;
-end
-
-@ 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@>=
-begin det:=take_fraction(dyout,dxin)-take_fraction(dxout,dyin);
-if abs(det)<26844 then r:=null {sine $<10^{-4}$}
-else begin tmp:=take_fraction(x_coord(q)-x_coord(p),dyout)-@|
- take_fraction(y_coord(q)-y_coord(p),dxout);
- tmp:=make_fraction(tmp,det);
- r:=insert_knot(p,x_coord(p)+take_fraction(tmp,dxin),@|
- y_coord(p)+take_fraction(tmp,dyin));
- end;
-end
-
-@ @<Other local variables for |make_envelope|@>=
-@!det:fraction; {a determinant used for mitered join calculations}
-
-@ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
-begin ht_x:=y_coord(w)-y_coord(w0);
-ht_y:=x_coord(w0)-x_coord(w);
-while (abs(ht_x)<fraction_half)and(abs(ht_y)<fraction_half) do
- begin double(ht_x); double(ht_y);
- end;
-@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
- product with |(ht_x,ht_y)|@>;
-tmp:=make_fraction(max_ht,take_fraction(dxin,ht_x)+take_fraction(dyin,ht_y));
-r:=insert_knot(p,x_coord(p)+take_fraction(tmp,dxin),@|
- y_coord(p)+take_fraction(tmp,dyin));
-tmp:=make_fraction(max_ht,take_fraction(dxout,ht_x)+take_fraction(dyout,ht_y));
-r:=insert_knot(r,x_coord(q)+take_fraction(tmp,dxout),@|
- y_coord(q)+take_fraction(tmp,dyout));
-end
-
-@ @<Other local variables for |make_envelope|@>=
-@!ht_x,@!ht_y:fraction; {perpendicular to the segment from |p| to |q|}
-@!max_ht:scaled; {maximum height of the pen polygon above the |w0|-|w| line}
-@!kk:halfword; {keeps track of the pen vertices being scanned}
-@!ww:pointer; {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;
-loop @+begin @<Step |ww| and move |kk| one step closer to |k0|@>;
- if kk=k0 then goto done;
- tmp:=take_fraction(x_coord(ww)-x_coord(w0),ht_x)+@|
- take_fraction(y_coord(ww)-y_coord(w0),ht_y);
- if tmp>max_ht then max_ht:=tmp;
- end;
-done:do_nothing
-
-@ @<Step |ww| and move |kk| one step closer to |k0|@>=
-if kk>k0 then
- begin ww:=link(ww); decr(kk); @+end
-else begin ww:=knil(ww); incr(kk); @+end
-
-@ @<Double the path |c|, and set |spec_p1| and |spec_p2|@>=
-begin spec_p1:=htap_ypoc(c);
-spec_p2:=path_tail;
-originator(spec_p1):=program_code;
-link(spec_p2):=link(spec_p1);
-link(spec_p1):=c;@/
-remove_cubic(spec_p1);
-c:=spec_p1;
-if c<>link(c) then begin
-originator(spec_p2):=program_code;
-remove_cubic(spec_p2);
-end
-else @<Make |c| look like a cycle of length one@>;
-end
-
-@ @<Make |c| look like a cycle of length one@>=
-begin left_type(c):=explicit; right_type(c):=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);
-end;
-
-@ 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)and(dyin=0) then
- begin dxin:=x_coord(q)-right_x(p);
- dyin:=y_coord(q)-right_y(p);
- if (dxin=0)and(dyin=0) then
- begin dxin:=x_coord(q)-x_coord(p);
- dyin:=y_coord(q)-y_coord(p);
- if p<>c then {the coordinates of |p| have been offset by |w|}
- begin dxin:=dxin+x_coord(w);
- dyin:=dyin+y_coord(w);
- end;
- end;
- end;
-tmp:=pyth_add(dxin,dyin);
-if tmp=0 then join_type:=2
-else begin dxin:=make_fraction(dxin,tmp);
- dyin:=make_fraction(dyin,tmp);
- @<Set the outgoing direction at |q|@>;
- end
-
-@ 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)and(dyout=0) then
- begin r:=link(q);
- dxout:=left_x(r)-x_coord(q);
- dyout:=left_y(r)-y_coord(q);
- if (dxout=0)and(dyout=0) then
- begin dxout:=x_coord(r)-x_coord(q);
- dyout:=y_coord(r)-y_coord(q);
- end;
- end;
-if q=c then
- begin dxout:=dxout-x_coord(h);
- dyout:=dyout-y_coord(h);
- end;
-tmp:=pyth_add(dxout,dyout);
-if tmp=0 then confusion("degenerate spec");
-@:this can't happen degerate spec}{\quad degenerate spec@>
-dxout:=make_fraction(dxout,tmp);
-dyout:=make_fraction(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.''
-
-@p function find_direction_time(@!x,@!y:scaled;@!h:pointer):scaled;
-label exit,found,not_found,done;
-var @!max:scaled; {$\max\bigl(\vert x\vert,\vert y\vert\bigr)$}
-@!p,@!q:pointer; {for list traversal}
-@!n:scaled; {the direction time at knot |p|}
-@!tt:scaled; {the direction time within a cubic}
-@<Other local variables for |find_direction_time|@>@;
-begin @<Normalize the given direction for better accuracy;
- but |return| with zero result if it's zero@>;
-n:=0; p:=h;
-loop@+ begin if right_type(p)=endpoint then goto not_found;
- 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 |goto not_found| if an entire cyclic path has been traversed@>;
- p:=q; n:=n+unity;
- end;
-not_found: find_direction_time:=-unity; return;
-found: find_direction_time:=n+tt;
-exit:end;
-
-@ @<Normalize the given direction for better accuracy...@>=
-if abs(x)<abs(y) then
- begin x:=make_fraction(x,abs(y));
- if y>0 then y:=fraction_one@+else y:=-fraction_one;
- end
-else if x=0 then
- begin find_direction_time:=0; return;
- end
-else begin y:=make_fraction(y,abs(x));
- if x>0 then x:=fraction_one@+else x:=-fraction_one;
- end
-
-@ 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 then if x1>=0 then goto found;
-if n>0 then
- begin @<Exit to |found| if an eastward direction occurs at knot |p|@>;
- if p=h then goto not_found;
- end;
-if (x3<>0)or(y3<>0) then phi:=n_arg(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|@>=
-@!x1,@!x2,@!x3,@!y1,@!y2,@!y3:scaled; {multiples of rotated derivatives}
-@!theta,@!phi:angle; {angles of exit and entry at a knot}
-@!t:fraction; {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 then max:=abs(x2);
-if abs(x3)>max then max:=abs(x3);
-if abs(y1)>max then max:=abs(y1);
-if abs(y2)>max then max:=abs(y2);
-if abs(y3)>max then max:=abs(y3);
-if max=0 then goto found;
-while max<fraction_half do
- begin double(max); double(x1); double(x2); double(x3);
- double(y1); double(y2); double(y3);
- end;
-t:=x1; x1:=take_fraction(x1,x)+take_fraction(y1,y);
-y1:=take_fraction(y1,x)-take_fraction(t,y);@/
-t:=x2; x2:=take_fraction(x2,x)+take_fraction(y2,y);
-y2:=take_fraction(y2,x)-take_fraction(t,y);@/
-t:=x3; x3:=take_fraction(x3,x)+take_fraction(y3,y);
-y3:=take_fraction(y3,x)-take_fraction(t,y)
-
-@ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
-theta:=n_arg(x1,y1);
-if theta>=0 then if phi<=0 then if phi>=theta-one_eighty_deg then goto found;
-if theta<=0 then if phi>=0 then if phi<=theta+one_eighty_deg then 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 then if x2<0 then if x3<0 then goto done;
-if ab_vs_cd(y1,y3,y2,y2)=0 then
- @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
- either |goto found| or |goto done|@>;
-if y1<=0 then
- if y1<0 then
- begin y1:=-y1; y2:=-y2; y3:=-y3;
- end
- else if y2>0 then
- begin y2:=-y2; y3:=-y3;
- end;
-@<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==begin tt:=(t+@'4000) div @'10000; goto found;
- end
-
-@<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
-t:=crossing_point(y1,y2,y3);
-if t>fraction_one then 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 then we_found_it;
-if y2>0 then y2:=0;
-tt:=t; t:=crossing_point(0,-y2,-y3);
-if t>fraction_one then goto done;
-x1:=t_of_the_way(x1)(x2);
-x2:=t_of_the_way(x2)(x3);
-if t_of_the_way(x1)(x2)>=0 then
- begin t:=t_of_the_way(tt)(fraction_one); we_found_it;
- end
-
-@ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
- either |goto found| or |goto done|@>=
-begin if ab_vs_cd(y1,y2,0,0)<0 then
- begin t:=make_fraction(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 then we_found_it;
- end
-else if y3=0 then
- if y1=0 then
- @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>
- else if x3>=0 then
- begin tt:=unity; goto found;
- end;
-goto done;
-end
-
-@ 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|...@>=
-begin t:=crossing_point(-x1,-x2,-x3);
-if t<=fraction_one then we_found_it;
-if ab_vs_cd(x1,x3,x2,x2)<=0 then
- begin t:=make_fraction(x1,x1-x2); we_found_it;
- end;
-end
-
-@ 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...@>=
-@!tol_step:0..6; {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(#)==bisect_stack[#] {$U_1$, $V_1$, $X_1$, or $Y_1$}
-@d stack_2(#)==bisect_stack[#+1] {$U_2$, $V_2$, $X_2$, or $Y_2$}
-@d stack_3(#)==bisect_stack[#+2] {$U_3$, $V_3$, $X_3$, or $Y_3$}
-@d stack_min(#)==bisect_stack[#+3]
- {$U\submin$, $V\submin$, $X\submin$, or $Y\submin$}
-@d stack_max(#)==bisect_stack[#+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(#)==#-5
-@d v_packet(#)==#-10
-@d x_packet(#)==#-15
-@d y_packet(#)==#-20
-@d l_packets==bisect_ptr-int_packets
-@d r_packets==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==bisect_stack[bisect_ptr] {stacked value of |delx|}
-@d stack_dy==bisect_stack[bisect_ptr+1] {stacked value of |dely|}
-@d stack_tol==bisect_stack[bisect_ptr+2] {stacked value of |tol|}
-@d stack_uv==bisect_stack[bisect_ptr+3] {stacked value of |uv|}
-@d stack_xy==bisect_stack[bisect_ptr+4] {stacked value of |xy|}
-@d int_increment=int_packets+int_packets+5 {number of stack words per level}
-
-@<Glob...@>=
-bisect_stack:array[0..bistack_size] of integer;
-bisect_ptr:0..bistack_size;
-
-@ @<Check the ``constant''...@>=
-if int_packets+17*int_increment>bistack_size then 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(#)==
- if stack_1(#)<0 then
- if stack_3(#)>=0 then
- begin if stack_2(#)<0 then stack_min(#):=stack_1(#)+stack_2(#)
- else stack_min(#):=stack_1(#);
- stack_max(#):=stack_1(#)+stack_2(#)+stack_3(#);
- if stack_max(#)<0 then stack_max(#):=0;
- end
- else begin stack_min(#):=stack_1(#)+stack_2(#)+stack_3(#);
- if stack_min(#)>stack_1(#) then stack_min(#):=stack_1(#);
- stack_max(#):=stack_1(#)+stack_2(#);
- if stack_max(#)<0 then stack_max(#):=0;
- end
- else if stack_3(#)<=0 then
- begin if stack_2(#)>0 then stack_max(#):=stack_1(#)+stack_2(#)
- else stack_max(#):=stack_1(#);
- stack_min(#):=stack_1(#)+stack_2(#)+stack_3(#);
- if stack_min(#)>0 then stack_min(#):=0;
- end
- else begin stack_max(#):=stack_1(#)+stack_2(#)+stack_3(#);
- if stack_max(#)<stack_1(#) then stack_max(#):=stack_1(#);
- stack_min(#):=stack_1(#)+stack_2(#);
- if stack_min(#)>0 then stack_min(#):=0;
- end
-
-@ 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...@>=
-@!cur_t,@!cur_tt:integer; {controls and results of |cubic_intersection|}
-@!time_to_go:integer; {this many backtracks before giving up}
-@!max_t:integer; {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.
-
-@p procedure cubic_intersection(@!p,@!pp:pointer);
-label continue, not_found, exit;
-var @!q,@!qq:pointer; {|link(p)|, |link(pp)|}
-begin time_to_go:=max_patience; max_t:=2;
-@<Initialize for intersections at level zero@>;
-loop@+ begin continue:
- if delx-tol<=stack_max(x_packet(xy))-stack_min(u_packet(uv)) then
- if delx+tol>=stack_min(x_packet(xy))-stack_max(u_packet(uv)) then
- if dely-tol<=stack_max(y_packet(xy))-stack_min(v_packet(uv)) then
- if dely+tol>=stack_min(y_packet(xy))-stack_max(v_packet(uv)) then
- begin if cur_t>=max_t then
- begin if max_t=two then {we've done 17 bisections}
- begin cur_t:=halfp(cur_t+1); cur_tt:=halfp(cur_tt+1); return;
- end;
- double(max_t); appr_t:=cur_t; appr_tt:=cur_tt;
- end;
- @<Subdivide for a new level of intersection@>;
- goto continue;
- end;
- if time_to_go>0 then decr(time_to_go)
- else begin while appr_t<unity do
- begin double(appr_t); double(appr_tt);
- end;
- cur_t:=appr_t; cur_tt:=appr_tt; return;
- end;
- @<Advance to the next pair |(cur_t,cur_tt)|@>;
- end;
-exit:end;
-
-@ 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...@>=
-@!delx,@!dely:integer; {the components of $\Delta=2^l(w_0-z_0)$}
-@!tol:integer; {bound on the uncertainty in the overlap test}
-@!uv,@!xy:0..bistack_size; {pointers to the current packets of interest}
-@!three_l:integer; {|tol_step| times the bisection level}
-@!appr_t,@!appr_tt:integer; {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); 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);@/
-delx:=x_coord(p)-x_coord(pp); dely:=y_coord(p)-y_coord(pp);@/
-tol:=0; uv:=r_packets; xy:=r_packets; three_l:=0; cur_t:=1; cur_tt:=1
-
-@ @<Subdivide for a new level of intersection@>=
-stack_dx:=delx; stack_dy:=dely; stack_tol:=tol; stack_uv:=uv; stack_xy:=xy;
-bisect_ptr:=bisect_ptr+int_increment;@/
-double(cur_t); double(cur_tt);@/
-u1l:=stack_1(u_packet(uv)); u3r:=stack_3(u_packet(uv));
-u2l:=half(u1l+stack_2(u_packet(uv)));
-u2r:=half(u3r+stack_2(u_packet(uv)));
-u3l:=half(u2l+u2r); u1r:=u3l;
-set_min_max(ul_packet); set_min_max(ur_packet);@/
-v1l:=stack_1(v_packet(uv)); v3r:=stack_3(v_packet(uv));
-v2l:=half(v1l+stack_2(v_packet(uv)));
-v2r:=half(v3r+stack_2(v_packet(uv)));
-v3l:=half(v2l+v2r); v1r:=v3l;
-set_min_max(vl_packet); set_min_max(vr_packet);@/
-x1l:=stack_1(x_packet(xy)); x3r:=stack_3(x_packet(xy));
-x2l:=half(x1l+stack_2(x_packet(xy)));
-x2r:=half(x3r+stack_2(x_packet(xy)));
-x3l:=half(x2l+x2r); x1r:=x3l;
-set_min_max(xl_packet); set_min_max(xr_packet);@/
-y1l:=stack_1(y_packet(xy)); y3r:=stack_3(y_packet(xy));
-y2l:=half(y1l+stack_2(y_packet(xy)));
-y2r:=half(y3r+stack_2(y_packet(xy)));
-y3l:=half(y2l+y2r); y1r:=y3l;
-set_min_max(yl_packet); set_min_max(yr_packet);@/
-uv:=l_packets; xy:=l_packets;
-double(delx); double(dely);@/
-tol:=tol-three_l+tol_step; double(tol); three_l:=three_l+tol_step
-
-@ @<Advance to the next pair |(cur_t,cur_tt)|@>=
-not_found: if odd(cur_tt) then
- if odd(cur_t) then @<Descend to the previous level and |goto not_found|@>
- else begin incr(cur_t);
- delx:=delx+stack_1(u_packet(uv))+stack_2(u_packet(uv))
- +stack_3(u_packet(uv));
- dely:=dely+stack_1(v_packet(uv))+stack_2(v_packet(uv))
- +stack_3(v_packet(uv));
- uv:=uv+int_packets; {switch from |l_packets| to |r_packets|}
- decr(cur_tt); xy:=xy-int_packets; {switch from |r_packets| to |l_packets|}
- delx:=delx+stack_1(x_packet(xy))+stack_2(x_packet(xy))
- +stack_3(x_packet(xy));
- dely:=dely+stack_1(y_packet(xy))+stack_2(y_packet(xy))
- +stack_3(y_packet(xy));
- end
-else begin incr(cur_tt); tol:=tol+three_l;
- delx:=delx-stack_1(x_packet(xy))-stack_2(x_packet(xy))
- -stack_3(x_packet(xy));
- dely:=dely-stack_1(y_packet(xy))-stack_2(y_packet(xy))
- -stack_3(y_packet(xy));
- xy:=xy+int_packets; {switch from |l_packets| to |r_packets|}
- end
-
-@ @<Descend to the previous level...@>=
-begin cur_t:=halfp(cur_t); cur_tt:=halfp(cur_tt);
-if cur_t=0 then return;
-bisect_ptr:=bisect_ptr-int_increment; three_l:=three_l-tol_step;
-delx:=stack_dx; dely:=stack_dy; tol:=stack_tol; uv:=stack_uv; xy:=stack_xy;@/
-goto not_found;
-end
-
-@ 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|.
-
-@p procedure path_intersection(@!h,@!hh:pointer);
-label exit;
-var @!p,@!pp:pointer; {link registers that traverse the given paths}
-@!n,@!nn:integer; {integer parts of intersection times, minus |unity|}
-begin @<Change one-point paths into dead cycles@>;
-tol_step:=0;
-repeat n:=-unity; p:=h;
- repeat if right_type(p)<>endpoint then
- begin nn:=-unity; pp:=hh;
- repeat if right_type(pp)<>endpoint then
- begin cubic_intersection(p,pp);
- if cur_t>0 then
- begin cur_t:=cur_t+n; cur_tt:=cur_tt+nn; return;
- end;
- end;
- nn:=nn+unity; pp:=link(pp);
- until pp=hh;
- end;
- n:=n+unity; p:=link(p);
- until p=h;
-tol_step:=tol_step+3;
-until tol_step>3;
-cur_t:=-unity; cur_tt:=-unity;
-exit:end;
-
-@ @<Change one-point paths...@>=
-if right_type(h)=endpoint then
- begin 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):=explicit;
- end;
-if right_type(hh)=endpoint then
- begin 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):=explicit;
- end;
-
-@* \[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)=known| is the nice case, when |value(p)| is the |scaled| value
-of the variable whose address is~|p|.
-
-\smallskip\hang
-|type(p)=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)=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)=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
-|independent|; once |independent|, it never again becomes |numeric_type|;
-and once |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 |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(#)== {create a new independent variable}
- begin if serial_no>el_gordo-s_scale then
- overflow("independent variables",serial_no div s_scale);
-@:METAPOST capacity exceeded independent variables}{\quad independent variables@>
- type(#):=independent; serial_no:=serial_no+s_scale;
- value(#):=serial_no;
- end
-
-@<Glob...@>=
-@!serial_no:integer; {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)=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(#)==link(value_loc(#))
- {half of the |value| field in a |dependent| variable}
-@d prev_dep(#)==info(value_loc(#))
- {the other half; makes a doubly linked list}
-@d dep_node_size=2 {the number of words per dependency node}
-
-@<Initialize table entries...@>= 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 |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 |proto_dependent|,
-to indicate the scaling of the coefficients.
-
-@<Declare subroutines for printing expressions@>=
-procedure print_dependency(@!p:pointer;@!t:small_number);
-label exit;
-var @!v:integer; {a coefficient}
-@!pp,@!q:pointer; {for list manipulation}
-begin pp:=p;
-loop@+ begin v:=abs(value(p)); q:=info(p);
- if q=null then {the constant term}
- begin if (v<>0)or(p=pp) then
- begin if value(p)>0 then if p<>pp then print_char("+");
- print_scaled(value(p));
- end;
- return;
- end;
- @<Print the coefficient, unless it's $\pm1.0$@>;
- if type(q)<>independent then confusion("dep");
-@:this can't happen dep}{\quad dep@>
- print_variable_name(q); v:=value(q) mod s_scale;
- while v>0 do
- begin print("*4"); v:=v-2;
- end;
- p:=link(p);
- end;
-exit:end;
-
-@ @<Print the coefficient, unless it's $\pm1.0$@>=
-if value(p)<0 then print_char("-")
-else if p<>pp then print_char("+");
-if t=dependent then v:=round_fraction(v);
-if v<>unity then print_scaled(v)
-
-@ The maximum absolute value of a coefficient in a given dependency list
-is returned by the following simple function.
-
-@p function max_coef(@!p:pointer):fraction;
-var @!x:fraction; {the maximum so far}
-begin x:=0;
-while info(p)<>null do
- begin if abs(value(p))>x then x:=abs(value(p));
- p:=link(p);
- end;
-max_coef:=x;
-end;
-
-@ 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==@'4525252525 {|fraction| approximation to 7/3}
-@d independent_needing_fix=0
-
-@<Glob...@>=
-@!fix_needed:boolean; {does at least one |independent| variable need scaling?}
-@!watch_coefs:boolean; {should we scale coefficients that exceed |coef_bound|?}
-@!dep_final:pointer; {location of the constant term and final link}
-
-@ @<Set init...@>=
-fix_needed:=false; watch_coefs:=true;
-
-@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
-set to |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 |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@>=
-function p_plus_fq(@!p:pointer;@!f:integer;@!q:pointer;
- @!t,@!tt:small_number):pointer;
-label done;
-var @!pp,@!qq:pointer; {|info(p)| and |info(q)|, respectively}
-@!r,@!s:pointer; {for list manipulation}
-@!threshold:integer; {defines a neighborhood of zero}
-@!v:integer; {temporary register}
-begin if t=dependent then threshold:=fraction_threshold
-else threshold:=scaled_threshold;
-r:=temp_head; pp:=info(p); qq:=info(q);
-loop@+ if pp=qq then
- if pp=null then goto done
- else @<Contribute a term from |p|, plus |f| times the
- corresponding term from |q|@>
- else if value(pp)<value(qq) then
- @<Contribute a term from |q|, multiplied by~|f|@>
- else begin link(r):=p; r:=p; p:=link(p); pp:=info(p);
- end;
-done: if t=dependent then
- value(p):=slow_add(value(p),take_fraction(value(q),f))
-else value(p):=slow_add(value(p),take_scaled(value(q),f));
-link(r):=p; dep_final:=p; p_plus_fq:=link(temp_head);
-end;
-
-@ @<Contribute a term from |p|, plus |f|...@>=
-begin if tt=dependent then v:=value(p)+take_fraction(f,value(q))
-else v:=value(p)+take_scaled(f,value(q));
-value(p):=v; s:=p; p:=link(p);
-if abs(v)<threshold then free_node(s,dep_node_size)
-else begin if abs(v)>=coef_bound then if watch_coefs then
- begin type(qq):=independent_needing_fix; fix_needed:=true;
- end;
- link(r):=s; r:=s;
- end;
-pp:=info(p); q:=link(q); qq:=info(q);
-end
-
-@ @<Contribute a term from |q|, multiplied by~|f|@>=
-begin if tt=dependent then v:=take_fraction(f,value(q))
-else v:=take_scaled(f,value(q));
-if abs(v)>halfp(threshold) then
- begin s:=get_node(dep_node_size); info(s):=qq; value(s):=v;
- if abs(v)>=coef_bound then if watch_coefs then
- begin type(qq):=independent_needing_fix; fix_needed:=true;
- end;
- link(r):=s; r:=s;
- end;
-q:=link(q); qq:=info(q);
-end
-
-@ 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 |proto_dependent|).
-
-@p function p_plus_q(@!p:pointer;@!q:pointer;@!t:small_number):pointer;
-label done;
-var @!pp,@!qq:pointer; {|info(p)| and |info(q)|, respectively}
-@!r,@!s:pointer; {for list manipulation}
-@!threshold:integer; {defines a neighborhood of zero}
-@!v:integer; {temporary register}
-begin if t=dependent then threshold:=fraction_threshold
-else threshold:=scaled_threshold;
-r:=temp_head; pp:=info(p); qq:=info(q);
-loop@+ if pp=qq then
- if pp=null then goto done
- else @<Contribute a term from |p|, plus the
- corresponding term from |q|@>
- else if value(pp)<value(qq) then
- begin s:=get_node(dep_node_size); info(s):=qq; value(s):=value(q);
- q:=link(q); qq:=info(q); link(r):=s; r:=s;
- end
- else begin link(r):=p; r:=p; p:=link(p); pp:=info(p);
- end;
-done: value(p):=slow_add(value(p),value(q));
-link(r):=p; dep_final:=p; p_plus_q:=link(temp_head);
-end;
-
-@ @<Contribute a term from |p|, plus the...@>=
-begin v:=value(p)+value(q);
-value(p):=v; s:=p; p:=link(p); pp:=info(p);
-if abs(v)<threshold then free_node(s,dep_node_size)
-else begin if abs(v)>=coef_bound then if watch_coefs then
- begin type(qq):=independent_needing_fix; fix_needed:=true;
- end;
- link(r):=s; r:=s;
- end;
-q:=link(q); qq:=info(q);
-end
-
-@ 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=dependent| and |t1=proto_dependent|
-and |v_is_scaled=true|.
-
-@p function p_times_v(@!p:pointer;@!v:integer;
- @!t0,@!t1:small_number;@!v_is_scaled:boolean):pointer;
-var @!r,@!s:pointer; {for list manipulation}
-@!w:integer; {tentative coefficient}
-@!threshold:integer;
-@!scaling_down:boolean;
-begin if t0<>t1 then scaling_down:=true@+else scaling_down:=not v_is_scaled;
-if t1=dependent then threshold:=half_fraction_threshold
-else threshold:=half_scaled_threshold;
-r:=temp_head;
-while info(p)<>null do
- begin if scaling_down then w:=take_fraction(v,value(p))
- else w:=take_scaled(v,value(p));
- if abs(w)<=threshold then
- begin s:=link(p); free_node(p,dep_node_size); p:=s;
- end
- else begin if abs(w)>=coef_bound then
- begin fix_needed:=true; type(info(p)):=independent_needing_fix;
- end;
- link(r):=p; r:=p; value(p):=w; p:=link(p);
- end;
- end;
-link(r):=p;
-if v_is_scaled then value(p):=take_scaled(value(p),v)
-else value(p):=take_fraction(value(p),v);
-p_times_v:=link(temp_head);
-end;
-
-@ Similarly, we sometimes need to divide a dependency list
-by a given |scaled| constant.
-
-@<Declare basic dependency-list subroutines@>=
-function p_over_v(@!p:pointer;@!v:scaled;
- @!t0,@!t1:small_number):pointer;
-var @!r,@!s:pointer; {for list manipulation}
-@!w:integer; {tentative coefficient}
-@!threshold:integer;
-@!scaling_down:boolean;
-begin if t0<>t1 then scaling_down:=true@+else scaling_down:=false;
-if t1=dependent then threshold:=half_fraction_threshold
-else threshold:=half_scaled_threshold;
-r:=temp_head;
-while info(p)<>null do
- begin if scaling_down then
- if abs(v)<@'2000000 then w:=make_scaled(value(p),v*@'10000)
- else w:=make_scaled(round_fraction(value(p)),v)
- else w:=make_scaled(value(p),v);
- if abs(w)<=threshold then
- begin s:=link(p); free_node(p,dep_node_size); p:=s;
- end
- else begin if abs(w)>=coef_bound then
- begin fix_needed:=true; type(info(p)):=independent_needing_fix;
- end;
- link(r):=p; r:=p; value(p):=w; p:=link(p);
- end;
- end;
-link(r):=p; value(p):=make_scaled(value(p),v);
-p_over_v:=link(temp_head);
-end;
-
-@ 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 |proto_dependent|. However, the global variable |dep_final|
-is not altered if |x| does not occur in list~|p|.
-
-@p function p_with_x_becoming_q(@!p,@!x,@!q:pointer;@!t:small_number):pointer;
-var @!r,@!s:pointer; {for list manipulation}
-@!v:integer; {coefficient of |x|}
-@!sx:integer; {serial number of |x|}
-begin s:=p; r:=temp_head; sx:=value(x);
-while value(info(s))>sx do
- begin r:=s; s:=link(s);
- end;
-if info(s)<>x then p_with_x_becoming_q:=p
-else begin link(temp_head):=p; link(r):=link(s); v:=value(s);
- free_node(s,dep_node_size);
- p_with_x_becoming_q:=p_plus_fq(link(temp_head),v,q,t,dependent);
- end;
-end;
-
-@ 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@>=
-procedure val_too_big(@!x:scaled);
-begin if internal[warning_check]>0 then
- begin print_err("Value is too large ("); print_scaled(x); print_char(")");
-@.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.)");
- error;
- end;
-end;
-
-@ 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@>=
-procedure make_known(@!p,@!q:pointer);
-var @!t:dependent..proto_dependent; {the previous type}
-begin prev_dep(link(q)):=prev_dep(p);
-link(prev_dep(p)):=link(q); t:=type(p);
-type(p):=known; value(p):=value(q); free_node(q,dep_node_size);
-if abs(value(p))>=fraction_one then val_too_big(value(p));
-if internal[tracing_equations]>0 then if interesting(p) then
- begin begin_diagnostic; print_nl("#### ");
-@:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
- print_variable_name(p); print_char("="); print_scaled(value(p));
- end_diagnostic(false);
- end;
-if cur_exp=p then if cur_type=t then
- begin cur_type:=known; cur_exp:=value(p);
- free_node(p,value_node_size);
- end;
-end;
-
-@ 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@>=
-procedure fix_dependencies;
-label done;
-var @!p,@!q,@!r,@!s,@!t:pointer; {list manipulation registers}
-@!x:pointer; {an independent variable}
-begin r:=link(dep_head); s:=null;
-while r<>dep_head do
- begin 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) then make_known(t,q);
- end;
-while s<>null do
- begin p:=link(s); x:=info(s); free_avail(s); s:=p;
- type(x):=independent; value(x):=value(x)+2;
- end;
-fix_needed:=false;
-end;
-
-@ @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)|}
-loop@+ begin q:=link(r); x:=info(q);
- if x=null then goto done;
- if type(x)<=independent_being_fixed then
- begin if type(x)<independent_being_fixed then
- begin p:=get_avail; link(p):=s; s:=p;
- info(s):=x; type(x):=independent_being_fixed;
- end;
- value(q):=value(q) div 4;
- if value(q)=0 then
- begin link(r):=link(q); free_node(q,dep_node_size); q:=r;
- end;
- end;
- r:=q;
- end;
-done:
-
-@ 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|.
-
-@p procedure new_dep(@!q,@!p:pointer);
-var @!r:pointer; {what used to be the first dependency}
-begin dep_list(q):=p; prev_dep(q):=dep_head;
-r:=link(dep_head); link(dep_final):=r; prev_dep(r):=dep_final;
-link(dep_head):=q;
-end;
-
-@ 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.
-
-@p function const_dependency(@!v:scaled):pointer;
-begin dep_final:=get_node(dep_node_size);
-value(dep_final):=v; info(dep_final):=null;
-const_dependency:=dep_final;
-end;
-
-@ 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|.
-
-@p function single_dependency(@!p:pointer):pointer;
-var @!q:pointer; {the new dependency list}
-@!m:integer; {the number of doublings}
-begin m:=value(p) mod s_scale;
-if m>28 then single_dependency:=const_dependency(0)
-else begin q:=get_node(dep_node_size);
- value(q):=two_to_the[28-m]; info(q):=p;@/
- link(q):=const_dependency(0); single_dependency:=q;
- end;
-end;
-
-@ We sometimes need to make an exact copy of a dependency list.
-
-@p function copy_dep_list(@!p:pointer):pointer;
-label done;
-var @!q:pointer; {the new dependency list}
-begin q:=get_node(dep_node_size); dep_final:=q;
-loop@+ begin info(dep_final):=info(p); value(dep_final):=value(p);
- if info(dep_final)=null then goto done;
- link(dep_final):=get_node(dep_node_size);
- dep_final:=link(dep_final); p:=link(p);
- end;
-done:copy_dep_list:=q;
-end;
-
-@ 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 |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.
-
-@p procedure linear_eq(@!p:pointer;@!t:small_number);
-var @!q,@!r,@!s:pointer; {for link manipulation}
-@!x:pointer; {the variable that loses its independence}
-@!n:integer; {the number of times |x| had been halved}
-@!v:integer; {the coefficient of |x| in list |p|}
-@!prev_r:pointer; {lags one step behind |r|}
-@!final_node:pointer; {the constant term of the new dependency list}
-@!w:integer; {a tentative coefficient}
-begin @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
-x:=info(q); n:=value(x) mod s_scale;@/
-@<Divide list |p| by |-v|, removing node |q|@>;
-if internal[tracing_equations]>0 then @<Display the new dependency@>;
-@<Simplify all existing dependencies by substituting for |x|@>;
-@<Change variable |x| from |independent| to |dependent| or |known|@>;
-if fix_needed then fix_dependencies;
-end;
-
-@ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
-q:=p; r:=link(p); v:=value(q);
-while info(r)<>null do
- begin if abs(value(r))>abs(v) then
- begin q:=r; v:=value(r);
- end;
- r:=link(r);
- end
-
-@ 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=dependent|.
-
-@<Divide list |p| by |-v|, removing node |q|@>=
-s:=temp_head; link(s):=p; r:=p;
-repeat if r=q then
- begin link(s):=link(r); free_node(r,dep_node_size);
- end
-else begin w:=make_fraction(value(r),v);
- if abs(w)<=half_fraction_threshold then
- begin link(s):=link(r); free_node(r,dep_node_size);
- end
- else begin value(r):=-w; s:=r;
- end;
- end;
-r:=link(s);
-until info(r)=null;
-if t=proto_dependent then value(r):=-make_scaled(value(r),v)
-else if v<>-fraction_one then value(r):=-make_fraction(value(r),v);
-final_node:=r; p:=link(temp_head)
-
-@ @<Display the new dependency@>=
-if interesting(x) then
- begin begin_diagnostic; print_nl("## "); print_variable_name(x);
-@:]]]\#\#_}{\.{\#\#}@>
- w:=n;
- while w>0 do
- begin print("*4"); w:=w-2;
- end;
- print_char("="); print_dependency(p,dependent); end_diagnostic(false);
- end
-
-@ @<Simplify all existing dependencies by substituting for |x|@>=
-prev_r:=dep_head; r:=link(dep_head);
-while r<>dep_head do
- begin s:=dep_list(r); q:=p_with_x_becoming_q(s,x,p,type(r));
- if info(q)=null then make_known(r,q)
- else begin dep_list(r):=q;
- repeat q:=link(q);
- until info(q)=null;
- prev_r:=q;
- end;
- r:=link(prev_r);
- end
-
-@ @<Change variable |x| from |independent| to |dependent| or |known|@>=
-if n>0 then @<Divide list |p| by $2^n$@>;
-if info(p)=null then
- begin type(x):=known;
- value(x):=value(p);
- if abs(value(x))>=fraction_one then val_too_big(value(x));
- free_node(p,dep_node_size);
- if cur_exp=x then if cur_type=independent then
- begin cur_exp:=value(x); cur_type:=known;
- free_node(x,value_node_size);
- end;
- end
-else begin type(x):=dependent; dep_final:=final_node; new_dep(x,p);
- if cur_exp=x then if cur_type=independent then cur_type:=dependent;
- end
-
-@ @<Divide list |p| by $2^n$@>=
-begin s:=temp_head; link(temp_head):=p; r:=p;
-repeat if n>30 then w:=0
-else w:=value(r) div two_to_the[n];
-if (abs(w)<=half_fraction_threshold)and(info(r)<>null) then
- begin link(s):=link(r);
- free_node(r,dep_node_size);
- end
-else begin value(r):=w; s:=r;
- end;
-r:=link(s);
-until info(s)=null;
-p:=link(temp_head);
-end
-
-@ 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 do
- begin if prev_dep(p)<>q then
- begin print_nl("Bad PREVDEP at "); print_int(p);
-@.Bad PREVDEP...@>
- end;
- p:=dep_list(p);
- loop @+begin r:=info(p); q:=p; p:=link(q);
- if r=null then goto done3;
- if value(info(p))>=value(r) then
- begin print_nl("Out of order at "); print_int(p);
-@.Out of order...@>
- end;
- end;
-done3: do_nothing;
- end
-
-@* \[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 |unknown_boolean|;
-similarly, there are variables whose type is |unknown_string|, |unknown_pen|,
-|unknown_path|, and |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).
-
-@p function new_ring_entry(@!p:pointer):pointer;
-var q:pointer; {the new capsule node}
-begin q:=get_node(value_node_size); name_type(q):=capsule;
-type(q):=type(p);
-if value(p)=null then value(q):=p@+else value(q):=value(p);
-value(p):=q;
-new_ring_entry:=q;
-end;
-
-@ 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@>=
-procedure ring_delete(@!p:pointer);
-var @!q:pointer;
-begin q:=value(p);
-if q<>null then if q<>p then
- begin while value(q)<>p do q:=value(q);
- value(q):=value(p);
- end;
-end;
-
-@ 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.
-
-@p procedure nonlinear_eq(@!v:integer;@!p:pointer;@!flush_p:boolean);
-var @!t:small_number; {the type of ring |p|}
-@!q,@!r:pointer; {link manipulation registers}
-begin t:=type(p)-unknown_tag; q:=value(p);
-if flush_p then type(p):=vacuous@+else p:=q;
-repeat r:=value(q); type(q):=t;
-case t of
-boolean_type: value(q):=v;
-string_type: begin value(q):=v; add_str_ref(v);
- end;
-pen_type: value(q):=copy_pen(v);
-path_type: value(q):=copy_path(v);
-picture_type: begin value(q):=v; add_edge_ref(v);
- end;
-end; {there ain't no more cases}
-q:=r;
-until q=p;
-end;
-
-@ 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.
-
-@p procedure ring_merge(@!p,@!q:pointer);
-label exit;
-var @!r:pointer; {traverses one list}
-begin r:=value(p);
-while r<>p do
- begin if r=q then
- begin @<Exclaim about a redundant equation@>;
- return;
- end;
- r:=value(r);
- end;
-r:=value(p); value(p):=value(q); value(q):=r;
-exit:end;
-
-@ @<Exclaim about a redundant equation@>=
-begin 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.");@/
-put_get_error;
-end
-
-@* \[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...@>=
-@!cur_cmd: eight_bits; {current command set by |get_next|}
-@!cur_mod: integer; {operand of current command}
-@!cur_sym: halfword; {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|@>=
-procedure print_cmd_mod(@!c,@!m:integer);
-begin case c of
-@t\4@>@<Cases of |print_cmd_mod| for symbolic printing of primitives@>@/
-othercases print("[unknown command code!]")
-endcases;
-end;
-
-@ Here is a procedure that displays a given command in braces, in the
-user's transcript file.
-
-@d show_cur_cmd_mod==show_cmd_mod(cur_cmd,cur_mod)
-
-@p procedure show_cmd_mod(@!c,@!m:integer);
-begin begin_diagnostic; print_nl("{");
-print_cmd_mod(c,m); print_char("}");
-end_diagnostic(false);
-end;
-
-@* \[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...@>=
-@!in_state_record = record
- @!index_field: quarterword;
- @!start_field,@!loc_field, @!limit_field, @!name_field: halfword;
- 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}
-
-@ 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==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 name==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==input_file[index] {the current |alpha_file| variable}
-@d line==line_stack[index] {current line number in the current source file}
-@d in_name==iname_stack[index] {a string used to construct \.{MPX} file names}
-@d in_area==iarea_stack[index] {another string for naming \.{MPX} files}
-@d absent=1 {|name_field| value for unused |mpx_in_stack| entries}
-@d mpx_reading==(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...@>=
-@!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_stack : array[0..max_in_open] of integer; {the line number for each file}
-@!iname_stack : array[0..max_in_open] of str_number;
- {used for naming \.{MPX} files}
-@!iarea_stack : array[0..max_in_open] of str_number;
- {used for naming \.{MPX} files}
-@!mpx_name : array[0..max_in_open] of halfword;
-
-@ 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>max_in_open) {are we scanning a token list?}
-@d file_state==(index<=max_in_open) {are we scanning a file line?}
-@d param_start==limit {base of macro parameters in |param_stack|}
-@d forever_text=max_in_open+1 {|token_type| code for loop texts}
-@d loop_text=max_in_open+2 {|token_type| code for loop texts}
-@d parameter=max_in_open+3 {|token_type| code for parameter texts}
-@d backed_up=max_in_open+4 {|token_type| code for texts to be reread}
-@d inserted=max_in_open+5 {|token_type| code for inserted texts}
-@d macro=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...@>=
-@!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|}
-
-@ 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|@>=
-function true_line: integer;
-var @!k:0..stack_size; {an index into the input stack}
-begin if file_state and (name>max_spec_src) then true_line:=line
-else begin k:=input_ptr;
- while (k>0)and(input_stack[k].index_field>max_in_open)or@|
- (input_stack[k].name_field<=max_spec_src) do
- decr(k);
- true_line:=line_stack[k];
- end;
-end;
-
-@ 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...@>=
-@!file_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}
-@<Local variables for formatting calculations@>@/
-begin file_ptr:=input_ptr; input_stack[file_ptr]:=cur_input;
- {store current state}
-loop@+begin cur_input:=input_stack[file_ptr]; {enter into the context}
- @<Display the current context@>;
- if file_state then
- if (name>max_spec_src) or (file_ptr=0) then goto done;
- decr(file_ptr);
- end;
-done: cur_input:=input_stack[input_ptr]; {restore original state}
-end;
-
-@ @<Display the current context@>=
-if (file_ptr=input_ptr) or file_state 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 file_state 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@>;
- 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>max_spec_src then
- begin print_nl("l."); print_int(true_line);
- end
-else if terminal_input then
- if file_ptr=0 then print_nl("<*>") @+else print_nl("<insert>")
-else if name=is_scantok then print_nl("<scantokens>")
-else print_nl("<read>");
-print_char(" ")
-
-@ @<Print type of token list@>=
-case token_type of
-forever_text: print_nl("<forever> ");
-loop_text: @<Print the current loop value@>;
-parameter: print_nl("<argument> ");
-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;
- if name<>null then print(text(name))
- else @<Print the name of a \&{vardef}'d macro@>;
- print("->");
- end;
-othercases print_nl("?") {this should never happen}
-@.?\relax@>
-endcases
-
-@ 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.
-
-@d void==null+1 {a null pointer different from |null|}
-
-@<Print the current loop value@>=
-begin print_nl("<for("); p:=param_stack[param_start];
-if p<>null then
- if link(p)=void then print_exp(p,0) {we're in a \&{for} loop}
- else show_token_list(p,null,20,tally);
-print(")> ");
-end
-
-@ 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@>=
-begin p:=param_stack[param_start];
-if p=null then show_token_list(param_stack[param_start+1],null,20,tally)
-else begin q:=p;
- while link(q)<>null do q:=link(q);
- link(q):=param_stack[param_start+1];
- show_token_list(p,null,20,tally);
- link(q):=null;
- end;
-end
-
-@ 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...@>=
-@!i:0..buf_size; {index into |buffer|}
-@!l:integer; {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 tells the print routines to 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 limit>0 then for i:=start to limit-1 do
- begin if i=loc then set_trick_count;
- print(buffer[i]);
- end
-
-@ @<Pseudoprint the token list@>=
-begin_pseudoprint;
-if token_type<>macro then show_token_list(start,loc,100000,0)
-else show_macro(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==@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);
-@:MetaPost capacity exceeded input stack size}{\quad input stack size@>
- end;
- input_stack[input_ptr]:=cur_input; {stack the record}
- 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|, reset~|loc|, and increase the macro's reference count.
-
-@d back_list(#)==begin_token_list(#,backed_up) {backs up a simple token list}
-
-@p procedure begin_token_list(@!p:pointer;@!t:quarterword);
-begin push_input; start:=p; token_type:=t;
-param_start:=param_ptr; loc:=p;
-end;
-
-@ When a token list has been fully scanned, the following computations
-should be done as we leave that level of input.
-@^inner loop@>
-
-@p procedure end_token_list; {leave a token-list input level}
-label done;
-var @!p:pointer; {temporary register}
-begin if token_type>=backed_up then {token list to be deleted}
- if token_type<=inserted then
- begin flush_token_list(start); goto done;
- end
- else delete_mac_ref(start); {update reference count}
-while param_ptr>param_start do {parameters must be flushed}
- begin decr(param_ptr);
- p:=param_stack[param_ptr];
- if p<>null then
- if link(p)=void then {it's an \&{expr} parameter}
- begin recycle_value(p); free_node(p,value_node_size);
- end
- else flush_token_list(p); {it's a \&{suffix} or \&{text} parameter}
- end;
-done: pop_input; check_interrupt;
-end;
-
-@ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
-token by the |cur_tok| routine.
-@^inner loop@>
-
-@p @t\4@>@<Declare the procedure called |make_exp_copy|@>@;@/
-function cur_tok:pointer;
-var @!p:pointer; {a new token node}
-@!save_type:small_number; {|cur_type| to be restored}
-@!save_exp:integer; {|cur_exp| to be restored}
-begin if cur_sym=0 then
- if cur_cmd=capsule_token then
- begin save_type:=cur_type; save_exp:=cur_exp;
- make_exp_copy(cur_mod); p:=stash_cur_exp; link(p):=null;
- cur_type:=save_type; cur_exp:=save_exp;
- end
- else begin p:=get_node(token_node_size);
- value(p):=cur_mod; name_type(p):=token;
- if cur_cmd=numeric_token then type(p):=known
- else type(p):=string_type;
- end
-else begin fast_get_avail(p); info(p):=cur_sym;
- end;
-cur_tok:=p;
-end;
-
-@ 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.
-
-@p procedure back_input; {undoes one token of input}
-var @!p:pointer; {a token list of length one}
-begin p:=cur_tok;
-while token_state and(loc=null) do end_token_list; {conserve stack space}
-back_list(p);
-end;
-
-@ 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.
-
-@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);
-@:MetaPost capacity exceeded text input levels}{\quad text input levels@>
-if first=buf_size then overflow("buffer size",buf_size);
-@:MetaPost capacity exceeded buffer size}{\quad buffer size@>
-incr(in_open); push_input; index:=in_open;
-mpx_name[index]:=absent;
-start:=first;
-name:=is_term; {|terminal_input| is now |true|}
-end;
-
-@ 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.
-
-@p procedure end_file_reading;
-begin if in_open>index then
- if (mpx_name[in_open]=absent)or(name<=max_spec_src) then confusion("endinput")
-@:this can't happen endinput}{\quad endinput@>
- else begin a_close(input_file[in_open]); {close an \.{MPX} file}
- delete_str_ref(mpx_name[in_open]);
- decr(in_open);
- end;
-first:=start;
-if index<>in_open then confusion("endinput");
-if name>max_spec_src then
- begin a_close(cur_file);
- delete_str_ref(name);
- delete_str_ref(in_name); delete_str_ref(in_area);
- end;
-pop_input; decr(in_open);
-end;
-
-@ 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.
-
-@p function begin_mpx_reading:boolean;
-begin if in_open<>index+1 then begin_mpx_reading:=false
-else begin if mpx_name[in_open]<=absent then confusion("mpx");
-@:this can't happen mpx}{\quad mpx@>
- if first=buf_size then overflow("buffer size",buf_size);
-@:MetaPost capacity exceeded buffer size}{\quad buffer size@>
- push_input; index:=in_open;
- start:=first;
- name:=mpx_name[in_open]; add_str_ref(name);
- @<Put an empty line in the input buffer@>;
- begin_mpx_reading:=true;
- end;
-end;
-
-@ This procedure temporarily stops reading an \.{MPX} file.
-
-@p procedure end_mpx_reading;
-begin if in_open<>index then confusion("mpx");
-@:this can't happen mpx}{\quad mpx@>
-if loc<limit then
- @<Complain that we are not at the end of a line in the \.{MPX} file@>;
-first:=start;
-pop_input;
-end;
-
-@ 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@>=
-begin 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.");@/
-error;
-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 file_state and terminal_input and@|
- (input_ptr>0)and(loc=limit) do end_file_reading;
-print_ln; clear_terminal;
-end;
-
-@ To get \MP'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;
-param_ptr:=0; max_param_stack:=0;
-first:=1;
-start:=1; index:=0; line:=0; name:=is_term;
-mpx_name[0]:=absent;
-force_eof:=false;
-if not init_terminal then goto final_end;
-limit:=last; first:=last+1; {|init_terminal| has set |loc| and |last|}
-end;
-
-@* \[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...@>=
-@!scanner_status:normal..tex_flushing; {are we scanning at high speed?}
-@!warning_info:integer; {if so, what else do we need to know,
- in case an error occurs?}
-
-@ @<Initialize the input routines@>=
-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.
-
-@p function check_outer_validity:boolean;
-var @!p:pointer; {points to inserted token list}
-begin if scanner_status=normal then check_outer_validity:=true
-else if scanner_status=tex_flushing then
- @<Check if the file has ended while flushing \TeX\ material and set the
- result value for |check_outer_validity|@>
-else begin deletions_allowed:=false;
- @<Back up an outer symbolic token so that it can be reread@>;
- if scanner_status>skipping then
- @<Tell the user what has run away and try to recover@>
- else begin print_err("Incomplete if; all text was ignored after line ");
-@.Incomplete if...@>
- print_int(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 cur_sym=0 then help_line[2]:=@|
- "The file ended while I was skipping conditional text.";
- cur_sym:=frozen_fi; ins_error;
- end;
- deletions_allowed:=true; check_outer_validity:=false;
- end;
-end;
-
-@ @<Check if the file has ended while flushing \TeX\ material and set...@>=
-if cur_sym<>0 then check_outer_validity:=true
-else begin deletions_allowed:=false;
- print_err("TeX mode didn't end; all text was ignored after line ");
- print_int(warning_info);
- help2("The file ended while I was looking for the `etex' to")@/
- ("finish this TeX material. I've inserted `etex' now.");@/
- cur_sym := frozen_etex;
- ins_error;@/
- deletions_allowed:=true; check_outer_validity:=false;
- end
-
-@ @<Back up an outer symbolic token so that it can be reread@>=
-if cur_sym<>0 then
- begin p:=get_avail; info(p):=cur_sym;
- back_list(p); {prepare to read the symbolic token again}
- end
-
-@ @<Tell the user what has run away...@>=
-begin runaway; {print the definition-so-far}
-if cur_sym=0 then print_err("File ended")
-@.File ended while scanning...@>
-else begin print_err("Forbidden token found");
-@.Forbidden token found...@>
- end;
-print(" 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.");@/
-case scanner_status of
-@t\4@>@<Complete the error message,
- and set |cur_sym| to a token that might help recover from the error@>@;
-end; {there are no other cases}
-ins_error;
-end
-
-@ 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,...@>=
-flushing: begin print("to the end of the statement");
- help_line[3]:="A previous error seems to have propagated,";
- cur_sym:=frozen_semicolon;
- end;
-absorbing: begin print("a text argument");
- help_line[3]:="It seems that a right delimiter was left out,";
- if warning_info=0 then cur_sym:=frozen_end_group
- else begin cur_sym:=frozen_right_delimiter;
- equiv(frozen_right_delimiter):=warning_info;
- end;
- end;
-var_defining, op_defining: begin print("the definition of ");
- if scanner_status=op_defining then print(text(warning_info))
- else print_variable_name(warning_info);
- cur_sym:=frozen_end_def;
- end;
-loop_defining: begin print("the text of a "); print(text(warning_info));
- print(" loop");
- help_line[3]:="I suspect you have forgotten an `endfor',";
- cur_sym:=frozen_end_for;
- end;
-
-@ 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|@>=
-procedure runaway;
-begin if scanner_status>flushing then
- begin print_nl("Runaway ");
- case scanner_status of
- absorbing: print("text?");
- var_defining,op_defining: print("definition?");
- loop_defining: print("loop?");
- end; {there are no other cases}
- print_ln; show_token_list(link(hold_head),null,error_line-10,0);
- end;
-end;
-
-@ We need to mention a procedure that may be called by |get_next|.
-
-@p procedure@?firm_up_the_line; forward;
-
-@ 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.
-
-@d switch=25 {a label in |get_next|}
-@d start_numeric_token=85 {another}
-@d start_decimal_token=86 {and another}
-@d fin_numeric_token=87
- {and still another, although |goto| is considered harmful}
-
-@p procedure get_next; {sets |cur_cmd|, |cur_mod|, |cur_sym| to next token}
-@^inner loop@>
-label 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}
-var @!k:0..buf_size; {an index into |buffer|}
-@!c:ASCII_code; {the current character in the buffer}
-@!class:ASCII_code; {its class number}
-@!n,@!f:integer; {registers for decimal-to-binary conversion}
-begin restart: cur_sym:=0;
-if file_state then
-@<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@>;
-exit:end;
-
-@ 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|...@>=
-cur_cmd:=eq_type(cur_sym); cur_mod:=equiv(cur_sym);
-if cur_cmd>=outer_tag then
- if check_outer_validity then cur_cmd:=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;...@>=
-begin switch: c:=buffer[loc]; incr(loc); class:=char_class[c];
-case class of
-digit_class: goto start_numeric_token;
-period_class: begin class:=char_class[buffer[loc]];
- if class>period_class then goto switch
- else if class<period_class then {|class=digit_class|}
- begin n:=0; goto start_decimal_token;
- end;
-@:. }{\..\ token@>
- end;
-space_class: goto switch;
-percent_class: begin if scanner_status=tex_flushing then
- if loc<limit then goto switch;
- @<Move to next line of file, or |goto restart| if there is no next line@>;
- check_interrupt;
- goto switch;
- end;
-string_class: if scanner_status=tex_flushing then goto switch
- else @<Get a string token and |return|@>;
-isolated_classes: begin k:=loc-1; goto found;
- end;
-invalid_class: if scanner_status=tex_flushing then goto switch
- else @<Decry the invalid character and |goto restart|@>;
-othercases do_nothing {letters, etc.}
-endcases;@/
-k:=loc-1;
-while char_class[buffer[loc]]=class do 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: cur_sym:=id_lookup(k,loc-k);
-end
-
-@ 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...@>=
-begin 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.");@/
-deletions_allowed:=false; error; deletions_allowed:=true;
-goto restart;
-end
-
-@ @<Get a string token and |return|@>=
-begin if buffer[loc]="""" then cur_mod:=""
-else begin k:=loc; buffer[limit+1]:="""";
- repeat incr(loc);
- until buffer[loc]="""";
- if loc>limit then @<Decry the missing string delimiter and |goto restart|@>;
- if loc=k+1 then cur_mod:=buffer[k]
- else begin str_room(loc-k);
- repeat append_char(buffer[k]); incr(k);
- until k=loc;
- cur_mod:=make_string;
- end;
- end;
-incr(loc); cur_cmd:=string_token; return;
-end
-
-@ 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|@>=
-begin 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""'.");@/
-deletions_allowed:=false; error; deletions_allowed:=true; goto restart;
-end
-
-@ @<Get the integer part |n| of a numeric token...@>=
-n:=c-"0";
-while char_class[buffer[loc]]=digit_class do
- begin if n<32768 then n:=10*n+buffer[loc]-"0";
- incr(loc);
- end;
-if buffer[loc]="." then if char_class[buffer[loc+1]]=digit_class then goto done;
-f:=0; goto fin_numeric_token;
-done: incr(loc)
-
-@ @<Get the fraction part |f| of a numeric token@>=
-k:=0;
-repeat if k<17 then {digits for |k>=17| cannot affect the result}
- begin dig[k]:=buffer[loc]-"0"; incr(k);
- end;
-incr(loc);
-until char_class[buffer[loc]]<>digit_class;
-f:=round_decimals(k);
-if f=unity then
- begin incr(n); f:=0;
- end
-
-@ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
-if n<32768 then @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably
- large@>
-else if scanner_status<>tex_flushing then
- begin 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.");@/
- deletions_allowed:=false; error; deletions_allowed:=true;
- cur_mod:=el_gordo;
- end;
-cur_cmd:=numeric_token; return
-
-@ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
-begin cur_mod:=n*unity+f;
-if cur_mod>=fraction_one then
- if (internal[warning_check]>0) and (scanner_status<>tex_flushing) then
- begin print_err("Number is too large (");
- print_scaled(cur_mod);
- print_char(")");
- 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.)");
- error;
- end;
-end
-
-@ Let's consider now what happens when |get_next| is looking at a token list.
-@^inner loop@>
-
-@<Input from token list;...@>=
-if loc>=hi_mem_min then {one-word token}
- begin cur_sym:=info(loc); loc:=link(loc); {move to next}
- if cur_sym>=expr_base then
- if cur_sym>=suffix_base then
- @<Insert a suffix or text parameter and |goto restart|@>
- else begin cur_cmd:=capsule_token;
- cur_mod:=param_stack[param_start+cur_sym-(expr_base)];
- cur_sym:=0; return;
- end;
- end
-else if loc>null then
- @<Get a stored numeric or string or capsule token and |return|@>
-else begin {we are done with this token list}
- end_token_list; goto restart; {resume previous level}
- end
-
-@ @<Insert a suffix or text parameter...@>=
-begin if cur_sym>=text_base then cur_sym:=cur_sym-param_size;
- {|param_size=text_base-suffix_base|}
-begin_token_list(param_stack[param_start+cur_sym-(suffix_base)],parameter);
-goto restart;
-end
-
-@ @<Get a stored numeric or string or capsule token...@>=
-begin if name_type(loc)=token then
- begin cur_mod:=value(loc);
- if type(loc)=known then cur_cmd:=numeric_token
- else begin cur_cmd:=string_token; add_str_ref(cur_mod);
- end;
- end
-else begin cur_mod:=loc; cur_cmd:=capsule_token;
- end;
-loc:=link(loc); return;
-end
-
-@ 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 then @<Read next line of file into |buffer|, or
- |goto restart| if the file has ended@>
-else begin if input_ptr>0 then
- {text was inserted during error recovery or by \&{scantokens}}
- begin end_file_reading; goto restart; {resume previous level}
- end;
- if selector<log_only then open_log_file;
- if interaction>nonstop_mode then
- begin if limit=start then {previous line was empty}
- print_nl("(Please type a command or say `end')");
-@.Please type...@>
- print_ln; first:=start;
- prompt_input("*"); {input on-line into |buffer|}
-@.*\relax@>
- limit:=last; buffer[limit]:="%";
- first:=limit+1; loc:=start;
- end
- else fatal_error("*** (job aborted, no legal end found)");
-@.job aborted@>
- {nonstop mode, which is intended for overnight batch processing,
- never waits for on-line input}
- end
-
-@ 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?}
-
-@ 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@>=
-begin incr(line); first:=start;
-if not force_eof then
- begin if input_ln(cur_file,true) then {not end of file}
- firm_up_the_line {this sets |limit|}
- else force_eof:=true;
- end;
-if force_eof then
- begin force_eof:=false;
- decr(loc);
- if mpx_reading then
- @<Complain that the \.{MPX} file ended unexpectly; then set
- |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>
- else begin print_char(")"); decr(open_parens);
- update_terminal; {show user that file has been read}
- end_file_reading; {resume previous level}
- if check_outer_validity then goto restart @+else goto restart;
- end
- end;
-buffer[limit]:="%"; first:=limit+1; loc:=start; {ready to read}
-end
-
-@ 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...@>=
-begin 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.");@/
-deletions_allowed:=false; error; deletions_allowed:=true;
-cur_sym:=frozen_mpx_break; goto common_ending;
-end
-
-@ 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@>=
-last:=first; limit:=last; {simulate |input_ln| and |firm_up_the_line|}
-buffer[limit]:="%"; first:=limit+1; loc:=start
-
-@ 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 `\.{=>}'.
-\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.
-
-@p procedure firm_up_the_line;
-var @!k:0..buf_size; {an index into |buffer|}
-begin limit:=last;
-if internal[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;
-
-@* \[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...@>=
-primitive("btex",start_tex,btex_code);@/
-@!@:btex_}{\&{btex} primitive@>
-primitive("verbatimtex",start_tex,verbatim_code);
-@!@:verbatimtex_}{\&{verbatimtex} primitive@>
-primitive("etex",etex_marker,0); eqtb[frozen_etex]:=eqtb[cur_sym];@/
-@!@:etex_}{\&{etex} primitive@>
-primitive("mpxbreak",mpx_break,0); eqtb[frozen_mpx_break]:=eqtb[cur_sym];@/
-@!@:mpx_break_}{\&{mpxbreak} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-start_tex: if m=btex_code then print("btex")
- else print("verbatimtex");
-etex_marker: print("etex");
-mpx_break: print("mpxbreak");
-
-@ 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==begin get_next;
- if cur_cmd<=max_pre_command then t_next;
- end
-@d TeX_flush=65 {go here to flush to the next ``\&{etex}''}
-
-@p procedure@?start_mpx_input; forward;@t\2@>
-procedure t_next;
-label TeX_flush, common_ending;
-var @!old_status:normal..loop_defining; {saves the |scanner_status|}
-@!old_info:integer; {saves the |warning_info|}
-begin while cur_cmd<=max_pre_command do
- begin if cur_cmd=mpx_break then
- if not file_state or (mpx_name[index]=absent) then
- @<Complain about a misplaced \&{mpxbreak}@>
- else begin end_mpx_reading; goto TeX_flush;
- end
- else if cur_cmd=start_tex then
- if token_state or (name<=max_spec_src) then
- @<Complain that we are not reading a file@>
- else if mpx_reading then
- @<Complain that \.{MPX} files cannot contain \TeX\ material@>
- else if (cur_mod<>verbatim_code)and(mpx_name[index]<>finished) then
- begin if not begin_mpx_reading then start_mpx_input;
- end
- else goto TeX_flush
- else @<Complain about a misplaced \&{etex}@>;
- goto common_ending;
-TeX_flush: @<Flush the \TeX\ material@>;
-common_ending: get_next;
- end;
-end;
-
-@ 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:=scanner_status;
-old_info:=warning_info;
-scanner_status:=tex_flushing;
-warning_info:=line;
-repeat get_next;
-until cur_cmd=etex_marker;
-scanner_status:=old_status;
-warning_info:=old_info
-
-@ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
-begin 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.");@/
-error;
-end
-
-@ @<Complain that we are not reading a file@>=
-begin 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`.");@/
-error;
-end
-
-@ @<Complain about a misplaced \&{mpxbreak}@>=
-begin print_err("Misplaced mpxbreak");
-help2("I'll ignore this preprocessor command because it")@/
- ("doesn't belong here");@/
-error;
-end
-
-@ @<Complain about a misplaced \&{etex}@>=
-begin print_err("Extra etex will be ignored");
-help1("There is no btex or verbatimtex for this to match");@/
-error;
-end
-
-@* \[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...@>=
-primitive("def",macro_def,start_def);@/
-@!@:def_}{\&{def} primitive@>
-primitive("vardef",macro_def,var_def);@/
-@!@:var_def_}{\&{vardef} primitive@>
-primitive("primarydef",macro_def,secondary_primary_macro);@/
-@!@:primary_def_}{\&{primarydef} primitive@>
-primitive("secondarydef",macro_def,tertiary_secondary_macro);@/
-@!@:secondary_def_}{\&{secondarydef} primitive@>
-primitive("tertiarydef",macro_def,expression_tertiary_macro);@/
-@!@:tertiary_def_}{\&{tertiarydef} primitive@>
-primitive("enddef",macro_def,end_def); eqtb[frozen_end_def]:=eqtb[cur_sym];@/
-@!@:end_def_}{\&{enddef} primitive@>
-@#
-primitive("for",iteration,expr_base);@/
-@!@:for_}{\&{for} primitive@>
-primitive("forsuffixes",iteration,suffix_base);@/
-@!@:for_suffixes_}{\&{forsuffixes} primitive@>
-primitive("forever",iteration,start_forever);@/
-@!@:forever_}{\&{forever} primitive@>
-primitive("endfor",iteration,end_for); eqtb[frozen_end_for]:=eqtb[cur_sym];@/
-@!@:end_for_}{\&{endfor} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-macro_def:if m<=var_def then
- if m=start_def then print("def")
- else if m<start_def then print("enddef")
- else print("vardef")
- else if m=secondary_primary_macro then print("primarydef")
- else if m=tertiary_secondary_macro then print("secondarydef")
- else print("tertiarydef");
-iteration: if m<=start_forever then
- if m=start_forever then print("forever")@+else print("endfor")
- else if m=expr_base then print("for")@+else print("forsuffixes");
-
-@ 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)}.
-
-@p function scan_toks(@!terminator:command_code;
- @!subst_list,@!tail_end:pointer;@!suffix_count:small_number):pointer;
-label done,found;
-var @!p:pointer; {tail of the token list being built}
-@!q:pointer; {temporary for link management}
-@!balance:integer; {left delimiters minus right delimiters}
-begin p:=hold_head; balance:=1; link(hold_head):=null;
-loop@+ begin get_t_next;
- if cur_sym>0 then
- begin @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
- if cur_cmd=terminator then
- @<Adjust the balance; |goto done| if it's zero@>
- else if cur_cmd=macro_special then
- @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
- end;
- link(p):=cur_tok; p:=link(p);
- end;
-done: link(p):=tail_end; flush_node_list(subst_list);
-scan_toks:=link(hold_head);
-end;
-
-@ @<Substitute for |cur_sym|...@>=
-begin q:=subst_list;
-while q<>null do
- begin if info(q)=cur_sym then
- begin cur_sym:=value(q); cur_cmd:=relax; goto found;
- end;
- q:=link(q);
- end;
-found:end
-
-@ @<Adjust the balance; |goto done| if it's zero@>=
-if cur_mod>0 then incr(balance)
-else begin decr(balance);
- if balance=0 then goto done;
- end
-
-@ 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...@>=
-primitive("quote",macro_special,quote);@/
-@!@:quote_}{\&{quote} primitive@>
-primitive("#@@",macro_special,macro_prefix);@/
-@!@:]]]\#\AT!_}{\.{\#\AT!} primitive@>
-primitive("@@",macro_special,macro_at);@/
-@!@:]]]\AT!_}{\.{\AT!} primitive@>
-primitive("@@#",macro_special,macro_suffix);@/
-@!@:]]]\AT!\#_}{\.{\AT!\#} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-macro_special: case m of
- macro_prefix: print("#@@");
- macro_at: print_char("@@");
- macro_suffix: print("@@#");
- othercases print("quote")
- endcases;
-
-@ @<Handle quoted...@>=
-begin if cur_mod=quote then get_t_next
-else if cur_mod<=suffix_count then cur_sym:=suffix_base-1+cur_mod;
-end
-
-@ 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.
-
-@p procedure get_symbol; {sets |cur_sym| to a safe symbol}
-label restart;
-begin restart: get_t_next;
-if (cur_sym=0)or(cur_sym>frozen_inaccessible) then
- begin 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 cur_sym>0 then
- help_line[2]:="Sorry: You can't redefine my error-recovery tokens."
- else if cur_cmd=string_token then delete_str_ref(cur_mod);
- cur_sym:=frozen_inaccessible; ins_error; goto restart;
- end;
-end;
-
-@ 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.
-
-@p procedure get_clear_symbol;
-begin get_symbol; clear_symbol(cur_sym,false);
-end;
-
-@ Here's another little subroutine; it checks that an equals sign
-or assignment sign comes along at the proper place in a macro definition.
-
-@p procedure check_equals;
-begin if cur_cmd<>equals then if cur_cmd<>assignment then
- begin missing_err("=");@/
-@.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.");
- back_error;
- end;
-end;
-
-@ 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|).
-
-@p procedure make_op_def;
-var @!m:command_code; {the type of definition}
-@!p,@!q,@!r:pointer; {for list manipulation}
-begin m:=cur_mod;@/
-get_symbol; q:=get_node(token_node_size);
-info(q):=cur_sym; value(q):=expr_base;@/
-get_clear_symbol; warning_info:=cur_sym;@/
-get_symbol; p:=get_node(token_node_size);
-info(p):=cur_sym; value(p):=expr_base+1; link(p):=q;@/
-get_t_next; check_equals;@/
-scanner_status:=op_defining; q:=get_avail; ref_count(q):=null;
-r:=get_avail; link(q):=r; info(r):=general_macro;
-link(r):=scan_toks(macro_def,p,null,0);
-scanner_status:=normal; eq_type(warning_info):=m;
-equiv(warning_info):=q; get_x_next;
-end;
-
-@ Parameters to macros are introduced by the keywords \&{expr},
-\&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
-
-@<Put each...@>=
-primitive("expr",param_type,expr_base);@/
-@!@:expr_}{\&{expr} primitive@>
-primitive("suffix",param_type,suffix_base);@/
-@!@:suffix_}{\&{suffix} primitive@>
-primitive("text",param_type,text_base);@/
-@!@:text_}{\&{text} primitive@>
-primitive("primary",param_type,primary_macro);@/
-@!@:primary_}{\&{primary} primitive@>
-primitive("secondary",param_type,secondary_macro);@/
-@!@:secondary_}{\&{secondary} primitive@>
-primitive("tertiary",param_type,tertiary_macro);@/
-@!@:tertiary_}{\&{tertiary} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-param_type:if m>=expr_base then
- if m=expr_base then print("expr")
- else if m=suffix_base then print("suffix")
- else print("text")
- else if m<secondary_macro then print("primary")
- else if m=secondary_macro then print("secondary")
- else print("tertiary");
-
-@ 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|.
-
-@p @t\4@>@<Declare the procedure called |check_delimiter|@>@;
-@t\4@>@<Declare the function called |scan_declared_variable|@>@;
-procedure scan_def;
-var @!m:start_def..var_def; {the type of definition}
-@!n:0..3; {the number of special suffix parameters}
-@!k:0..param_size; {the total number of parameters}
-@!c:general_macro..text_macro; {the kind of macro we're defining}
-@!r:pointer; {parameter-substitution list}
-@!q:pointer; {tail of the macro token list}
-@!p:pointer; {temporary storage}
-@!base:halfword; {|expr_base|, |suffix_base|, or |text_base|}
-@!l_delim,@!r_delim:pointer; {matching delimiters}
-begin m:=cur_mod; c:=general_macro; link(hold_head):=null;@/
-q:=get_avail; ref_count(q):=null; r:=null;@/
-@<Scan the token or variable to be defined;
- set |n|, |scanner_status|, and |warning_info|@>;
-k:=n;
-if cur_cmd=left_delimiter then
- @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
-if cur_cmd=param_type then
- @<Absorb undelimited parameters, putting them into list |r|@>;
-check_equals;
-p:=get_avail; info(p):=c; link(q):=p;
-@<Attach the replacement text to the tail of node |p|@>;
-scanner_status:=normal; get_x_next;
-end;
-
-@ 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 then link(p):=scan_toks(macro_def,r,null,n)
-else begin q:=get_avail; info(q):=bg_loc; link(p):=q;
- p:=get_avail; info(p):=eg_loc;
- link(q):=scan_toks(macro_def,r,p,n);
- end;
-if warning_info=bad_vardef then flush_token_list(value(bad_vardef))
-
-@ @<Glob...@>=
-@!bg_loc,@!eg_loc:1..hash_end;
- {hash addresses of `\.{begingroup}' and `\.{endgroup}'}
-
-@ @<Scan the token or variable to be defined;...@>=
-if m=start_def then
- begin get_clear_symbol; warning_info:=cur_sym; get_t_next;
- scanner_status:=op_defining; n:=0;
- eq_type(warning_info):=defined_macro; equiv(warning_info):=q;
- end
-else begin p:=scan_declared_variable;
- flush_variable(equiv(info(p)),link(p),true);
- warning_info:=find_variable(p); flush_list(p);
- if warning_info=null then @<Change to `\.{a bad variable}'@>;
- scanner_status:=var_defining; n:=2;
- if cur_cmd=macro_special then if cur_mod=macro_suffix then {\.{\AT!\#}}
- begin n:=3; get_t_next;
- end;
- type(warning_info):=unsuffixed_macro-2+n; value(warning_info):=q;
- end {|suffixed_macro=unsuffixed_macro+1|}
-
-@ @<Change to `\.{a bad variable}'@>=
-begin 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.");@/
-error; warning_info:=bad_vardef;
-end
-
-@ @<Initialize table entries...@>=
-name_type(bad_vardef):=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|@>=
-repeat l_delim:=cur_sym; r_delim:=cur_mod; get_t_next;
-if (cur_cmd=param_type)and(cur_mod>=expr_base) then base:=cur_mod
-else begin print_err("Missing parameter type; `expr' will be assumed");
-@.Missing parameter type@>
- help1("You should've had `expr' or `suffix' or `text' here.");
- back_error; base:=expr_base;
- end;
-@<Absorb parameter tokens for type |base|@>;
-check_delimiter(l_delim,r_delim);
-get_t_next;
-until cur_cmd<>left_delimiter
-
-@ @<Absorb parameter tokens for type |base|@>=
-repeat link(q):=get_avail; q:=link(q); info(q):=base+k;@/
-get_symbol; p:=get_node(token_node_size); value(p):=base+k; info(p):=cur_sym;
-if k=param_size then overflow("parameter stack size",param_size);
-@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
-incr(k); link(p):=r; r:=p; get_t_next;
-until cur_cmd<>comma
-
-@ @<Absorb undelimited parameters, putting them into list |r|@>=
-begin p:=get_node(token_node_size);
-if cur_mod<expr_base then
- begin c:=cur_mod; value(p):=expr_base+k;
- end
-else begin value(p):=cur_mod+k;
- if cur_mod=expr_base then c:=expr_macro
- else if cur_mod=suffix_base then c:=suffix_macro
- else c:=text_macro;
- end;
-if k=param_size then overflow("parameter stack size",param_size);
-incr(k); get_symbol; info(p):=cur_sym; link(p):=r; r:=p; get_t_next;
-if c=expr_macro then if cur_cmd=of_token then
- begin c:=of_macro; p:=get_node(token_node_size);
- if k=param_size then overflow("parameter stack size",param_size);
- value(p):=expr_base+k; get_symbol; info(p):=cur_sym;
- link(p):=r; r:=p; get_t_next;
- end;
-end
-
-@* \[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|.
-
-@p procedure@?scan_primary; forward;@t\2@>
-procedure@?scan_secondary; forward;@t\2@>
-procedure@?scan_tertiary; forward;@t\2@>
-procedure@?scan_expression; forward;@t\2@>
-procedure@?scan_suffix; forward;@t\2@>@/
-@t\4@>@<Declare the procedure called |macro_call|@>@;@/
-procedure@?get_boolean; forward;@t\2@>
-procedure@?pass_text; forward;@t\2@>
-procedure@?conditional; forward;@t\2@>
-procedure@?start_input; forward;@t\2@>
-procedure@?begin_iteration; forward;@t\2@>
-procedure@?resume_iteration; forward;@t\2@>
-procedure@?stop_iteration; forward;@t\2@>
-
-@ An auxiliary subroutine called |expand| is used by |get_x_next|
-when it has to do exotic expansion commands.
-
-@p procedure expand;
-var @!p:pointer; {for list manipulation}
-@!k:integer; {something that we hope is |<=buf_size|}
-@!j:pool_pointer; {index into |str_pool|}
-begin if internal[tracing_commands]>unity then if cur_cmd<>defined_macro then
- show_cur_cmd_mod;
-case cur_cmd of
-if_test:conditional; {this procedure is discussed in Part 36 below}
-fi_or_else:@<Terminate the current conditional and skip to \&{fi}@>;
-input:@<Initiate or terminate input from a file@>;
-iteration:if cur_mod=end_for then
- @<Scold the user for having an extra \&{endfor}@>
- else begin_iteration; {this procedure is discussed in Part 37 below}
-repeat_loop: @<Repeat a loop@>;
-exit_test: @<Exit a loop if the proper time has come@>;
-relax: do_nothing;
-expand_after: @<Expand the token after the next token@>;
-scan_tokens: @<Put a string into the input buffer@>;
-defined_macro:macro_call(cur_mod,null,cur_sym);
-end; {there are no other cases}
-end;
-
-@ @<Scold the user...@>=
-begin 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.");@/
-error;
-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_mod|...@>=
-input: if m=0 then print("input")@+else print("endinput");
-
-@ @<Initiate or terminate input...@>=
-if cur_mod>0 then force_eof:=true
-else start_input
-
-@ 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@>=
-begin while token_state and(loc=null) do end_token_list; {conserve stack space}
-if loop_ptr=null then
- begin 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.");@/
- error;
- end
-else resume_iteration; {this procedure is in Part 37 below}
-end
-
-@ @<Exit a loop if the proper time has come@>=
-begin get_boolean;
-if internal[tracing_commands]>unity then show_cmd_mod(nullary,cur_exp);
-if cur_exp=true_code then
- if loop_ptr=null then
- begin print_err("No loop is in progress");
-@.No loop is in progress@>
- help1("Why say `exitif' when there's nothing to exit from?");
- if cur_cmd=semicolon then error@+else back_error;
- end
- else @<Exit prematurely from an iteration@>
-else if cur_cmd<>semicolon then
- begin missing_err(";");@/
-@.Missing `;'@>
- help2("After `exitif <boolean exp>' I expect to see a semicolon.")@/
- ("I shall pretend that one was there."); back_error;
- end;
-end
-
-@ Here we use the fact that |forever_text| is the only |token_type| that
-is less than |loop_text|.
-
-@<Exit prematurely...@>=
-begin p:=null;
-repeat if file_state then end_file_reading
-else begin if token_type<=loop_text then p:=start;
- end_token_list;
- end;
-until p<>null;
-if p<>info(loop_ptr) then fatal_error("*** (loop confusion)");
-@.loop confusion@>
-stop_iteration; {this procedure is in Part 34 below}
-end
-
-@ @<Expand the token after the next token@>=
-begin get_t_next;
-p:=cur_tok; get_t_next;
-if cur_cmd<min_command then expand else back_input;
-back_list(p);
-end
-
-@ @<Put a string into the input buffer@>=
-begin get_x_next; scan_primary;
-if cur_type<>string_type then
- begin disp_err(null,"Not a string");
-@.Not a string@>
- help2("I'm going to flush this expression, since")@/
- ("scantokens should be followed by a known string.");
- put_get_flush_error(0);
- end
-else begin back_input;
- if length(cur_exp)>0 then @<Pretend we're reading a new one-line file@>;
- end;
-end
-
-@ @<Pretend we're reading a new one-line file@>=
-begin begin_file_reading; name:=is_scantok;
-k:=first+length(cur_exp);
-if k>=max_buf_stack then
- begin if k>=buf_size then
- begin max_buf_stack:=buf_size;
- overflow("buffer size",buf_size);
-@:MetaPost capacity exceeded buffer size}{\quad buffer size@>
- end;
- max_buf_stack:=k+1;
- end;
-j:=str_start[cur_exp]; limit:=k;
-while first<limit do
- begin buffer[first]:=so(str_pool[j]); incr(j); incr(first);
- end;
-buffer[limit]:="%"; first:=limit+1; loc:=start; flush_cur_exp(0);
-end
-
-@ 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@>
-
-@p procedure get_x_next;
-var @!save_exp:pointer; {a capsule to save |cur_type| and |cur_exp|}
-begin get_t_next;
-if cur_cmd<min_command then
- begin save_exp:=stash_cur_exp;
- repeat if cur_cmd=defined_macro then macro_call(cur_mod,null,cur_sym)
- else expand;
- get_t_next;
- until cur_cmd>=min_command;
- unstash_cur_exp(save_exp); {that restores |cur_type| and |cur_exp|}
- end;
-end;
-
-@ 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|@>=
-@t\4@>@<Declare the procedure called |print_macro_name|@>@;
-@t\4@>@<Declare the procedure called |print_arg|@>@;
-@t\4@>@<Declare the procedure called |scan_text_arg|@>@;
-procedure macro_call(@!def_ref,@!arg_list,@!macro_name:pointer);
- {invokes a user-defined control sequence}
-label found;
-var @!r:pointer; {current node in the macro's token list}
-@!p,@!q:pointer; {for list manipulation}
-@!n:integer; {the number of arguments}
-@!l_delim,@!r_delim:pointer; {a delimiter pair}
-@!tail:pointer; {tail of the argument list}
-begin r:=link(def_ref); add_mac_ref(def_ref);
-tail:=null; l_delim:=null; r_delim:=null;
-if arg_list=null then n:=0
-else @<Determine the number |n| of arguments already supplied,
- and set |tail| to the tail of |arg_list|@>;
-if internal[tracing_macros]>0 then
- @<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@>;
-end;
-
-@ @<Show the text of the macro...@>=
-begin begin_diagnostic; print_ln; print_macro_name(arg_list,macro_name);
-if n=3 then print("@@#"); {indicate a suffixed macro}
-show_macro(def_ref,null,100000);
-if arg_list<>null then
- begin n:=0; p:=arg_list;
- repeat q:=info(p);
- print_arg(q,n,0);
- incr(n); p:=link(p);
- until p=null;
- end;
-end_diagnostic(false);
-end
-
-@ @<Declare the procedure called |print_macro_name|@>=
-procedure print_macro_name(@!a,@!n:pointer);
-var @!p,@!q:pointer; {they traverse the first part of |a|}
-begin if n<>null then print(text(n))
-else begin p:=info(a);
- if p=null then print(text(info(info(link(a)))))
- else begin q:=p;
- while link(q)<>null do q:=link(q);
- link(q):=info(link(a));
- show_token_list(p,null,1000,0);
- link(q):=null;
- end;
- end;
-end;
-
-@ @<Declare the procedure called |print_arg|@>=
-procedure print_arg(@!q:pointer;@!n:integer;@!b:pointer);
-begin if link(q)=void then print_nl("(EXPR")
-else if (b<text_base)and(b<>text_macro) then print_nl("(SUFFIX")
-else print_nl("(TEXT");
-print_int(n); print(")<-");
-if link(q)=void then print_exp(q,1)
-else show_token_list(q,null,1000,0);
-end;
-
-@ @<Determine the number |n| of arguments already supplied...@>=
-begin n:=1; tail:=arg_list;
-while link(tail)<>null do
- begin incr(n); tail:=link(tail);
- end;
-end
-
-@ @<Scan the remaining arguments, if any; set |r|...@>=
-cur_cmd:=comma+1; {anything |<>comma| will do}
-while info(r)>=expr_base do
- begin @<Scan the delimited argument represented by |info(r)|@>;
- r:=link(r);
- end;
-if cur_cmd=comma then
- begin print_err("Too many arguments to ");
-@.Too many arguments...@>
- print_macro_name(arg_list,macro_name); print_char(";");
- print_nl(" Missing `"); print(text(r_delim));
-@.Missing `)'...@>
- print("' 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.");
- error;
- end;
-if info(r)<>general_macro then @<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 cur_cmd<>comma then
- begin get_x_next;
- if cur_cmd<>left_delimiter then
- begin print_err("Missing argument to ");
-@.Missing argument...@>
- print_macro_name(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 then
- begin cur_exp:=null; cur_type:=token_list;
- end
- else begin cur_exp:=0; cur_type:=known;
- end;
- back_error; cur_cmd:=right_delimiter; goto found;
- end;
- l_delim:=cur_sym; r_delim:=cur_mod;
- end;
-@<Scan the argument represented by |info(r)|@>;
-if cur_cmd<>comma then @<Check that the proper right delimiter was present@>;
-found: @<Append the current expression to |arg_list|@>
-
-@ @<Check that the proper right delim...@>=
-if (cur_cmd<>right_delimiter)or(cur_mod<>l_delim) then
- if info(link(r))>=expr_base then
- begin missing_err(",");
-@.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.");
- back_error; cur_cmd:=comma;
- end
- else begin missing_err(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.");
- back_error;
- end
-
-@ 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|@>=
-begin p:=get_avail;
-if cur_type=token_list then info(p):=cur_exp
-else info(p):=stash_cur_exp;
-if internal[tracing_macros]>0 then
- begin begin_diagnostic; print_arg(info(p),n,info(r)); end_diagnostic(false);
- end;
-if arg_list=null then arg_list:=p
-else link(tail):=p;
-tail:=p; incr(n);
-end
-
-@ @<Scan the argument represented by |info(r)|@>=
-if info(r)>=text_base then scan_text_arg(l_delim,r_delim)
-else begin get_x_next;
- if info(r)>=suffix_base then scan_suffix
- else scan_expression;
- end
-
-@ 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|@>=
-procedure scan_text_arg(@!l_delim,@!r_delim:pointer);
-label done;
-var @!balance:integer; {excess of |l_delim| over |r_delim|}
-@!p:pointer; {list tail}
-begin warning_info:=l_delim; scanner_status:=absorbing;
-p:=hold_head; balance:=1; link(hold_head):=null;
-loop@+ begin get_t_next;
- if l_delim=0 then @<Adjust the balance for an undelimited argument;
- |goto done| if done@>
- else @<Adjust the balance for a delimited argument;
- |goto done| if done@>;
- link(p):=cur_tok; p:=link(p);
- end;
-done: cur_exp:=link(hold_head); cur_type:=token_list;
-scanner_status:=normal;
-end;
-
-@ @<Adjust the balance for a delimited argument...@>=
-begin if cur_cmd=right_delimiter then
- begin if cur_mod=l_delim then
- begin decr(balance);
- if balance=0 then goto done;
- end;
- end
-else if cur_cmd=left_delimiter then if cur_mod=r_delim then incr(balance);
-end
-
-@ @<Adjust the balance for an undelimited...@>=
-begin if end_of_statement then {|cur_cmd=semicolon|, |end_group|, or |stop|}
- begin if balance=1 then goto done
- else if cur_cmd=end_group then decr(balance);
- end
-else if cur_cmd=begin_group then incr(balance);
-end
-
-@ @<Scan undelimited argument(s)@>=
-begin if info(r)<text_macro then
- begin get_x_next;
- if info(r)<>suffix_macro then
- if (cur_cmd=equals)or(cur_cmd=assignment) then get_x_next;
- end;
-case info(r) of
-primary_macro:scan_primary;
-secondary_macro:scan_secondary;
-tertiary_macro:scan_tertiary;
-expr_macro:scan_expression;
-of_macro:@<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
-suffix_macro:@<Scan a suffix with optional delimiters@>;
-text_macro:scan_text_arg(0,0);
-end; {there are no other cases}
-back_input; @<Append the current expression to |arg_list|@>;
-end
-
-@ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
-begin scan_expression; p:=get_avail; info(p):=stash_cur_exp;
-if internal[tracing_macros]>0 then
- begin begin_diagnostic; print_arg(info(p),n,0); end_diagnostic(false);
- end;
-if arg_list=null then arg_list:=p@+else link(tail):=p;
-tail:=p;incr(n);
-if cur_cmd<>of_token then
- begin missing_err("of"); print(" for ");
-@.Missing `of'@>
- print_macro_name(arg_list,macro_name);
- help1("I've got the first argument; will look now for the other.");
- back_error;
- end;
-get_x_next; scan_primary;
-end
-
-@ @<Scan a suffix with optional delimiters@>=
-begin if cur_cmd<>left_delimiter then l_delim:=null
-else begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next;
- end;
-scan_suffix;
-if l_delim<>null then
- begin if(cur_cmd<>right_delimiter)or(cur_mod<>l_delim) then
- begin missing_err(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.");
- back_error;
- end;
- get_x_next;
- end;
-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 arguments and replacement text to the scanner@>=
-while token_state and(loc=null) do end_token_list; {conserve stack space}
-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);
-@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
- end;
-begin_token_list(def_ref,macro); name:=macro_name; loc:=r;
-if n>0 then
- begin p:=arg_list;
- repeat param_stack[param_ptr]:=info(p); incr(param_ptr); p:=link(p);
- until p=null;
- flush_list(arg_list);
- end
-
-@ It's sometimes necessary to put a single argument onto |param_stack|.
-The |stack_argument| subroutine does this.
-
-@p procedure stack_argument(@!p:pointer);
-begin if param_ptr=max_param_stack then
- begin incr(max_param_stack);
- if max_param_stack>param_size then
- overflow("parameter stack size",param_size);
-@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
- end;
-param_stack[param_ptr]:=p; incr(param_ptr);
-end;
-
-@* \[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(#)==mem[#+1].int
-@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...@>=
-@!cond_ptr:pointer; {top of the condition stack}
-@!if_limit:normal..else_if_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("if",if_test,if_code);@/
-@!@:if_}{\&{if} primitive@>
-primitive("fi",fi_or_else,fi_code); eqtb[frozen_fi]:=eqtb[cur_sym];@/
-@!@:fi_}{\&{fi} primitive@>
-primitive("else",fi_or_else,else_code);@/
-@!@:else_}{\&{else} primitive@>
-primitive("elseif",fi_or_else,else_if_code);@/
-@!@:else_if_}{\&{elseif} primitive@>
-
-@ @<Cases of |print_cmd_mod|...@>=
-if_test,fi_or_else: case m of
- if_code:print("if");
- fi_code:print("fi");
- else_code:print("else");
- othercases print("elseif")
- endcases;
-
-@ 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.
-
-@p procedure pass_text;
-label done;
-var l:integer;
-begin scanner_status:=skipping; l:=0; warning_info:=true_line;
-loop@+ begin get_t_next;
- if cur_cmd<=fi_or_else then
- if cur_cmd<fi_or_else then incr(l)
- else begin if l=0 then goto done;
- if cur_mod=fi_code then decr(l);
- end
- else @<Decrease the string reference count,
- if the current token is a string@>;
- end;
-done: scanner_status:=normal;
-end;
-
-@ @<Decrease the string reference count...@>=
-if cur_cmd=string_token then delete_str_ref(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@>=
-begin p:=get_node(if_node_size); link(p):=cond_ptr; type(p):=if_limit;
-name_type(p):=cur_if; if_line_field(p):=if_line;
-cond_ptr:=p; if_limit:=if_code; if_line:=true_line; cur_if:=if_code;
-end
-
-@ @<Pop the condition stack@>=
-begin p:=cond_ptr; if_line:=if_line_field(p);
-cur_if:=name_type(p); if_limit:=type(p); cond_ptr:=link(p);
-free_node(p,if_node_size);
-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 link(q)=p then
- begin type(q):=l; return;
- end;
- q:=link(q);
- end;
- end;
-exit:end;
-
-@ The user is supposed to put colons into the proper parts of conditional
-statements. Therefore, \MP\ has to check for their presence.
-
-@p procedure check_colon;
-begin if cur_cmd<>colon then
- begin missing_err(":");@/
-@.Missing `:'@>
- help2("There should've been a colon after the condition.")@/
- ("I shall pretend that one was there.");@;
- back_error;
- end;
-end;
-
-@ 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@>
-
-@p procedure conditional;
-label exit,done,reswitch,found;
-var @!save_cond_ptr:pointer; {|cond_ptr| corresponding to this conditional}
-@!new_if_limit:fi_code..else_if_code; {future value of |if_limit|}
-@!p:pointer; {temporary register}
-begin @<Push the condition stack@>;@+save_cond_ptr:=cond_ptr;
-reswitch: get_boolean; new_if_limit:=else_if_code;
-if internal[tracing_commands]>unity then
- @<Display the boolean value of |cur_exp|@>;
-found: check_colon;
-if cur_exp=true_code then
- begin change_if_limit(new_if_limit,save_cond_ptr);
- return; {wait for \&{elseif}, \&{else}, or \&{fi}}
- end;
-@<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
-done: cur_if:=cur_mod; if_line:=true_line;
-if cur_mod=fi_code then @<Pop the condition stack@>
-else if cur_mod=else_if_code then goto reswitch
-else begin cur_exp:=true_code; new_if_limit:=fi_code; get_x_next; goto found;
- end;
-exit:end;
-
-@ 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}...@>=
-loop@+ begin pass_text;
- if cond_ptr=save_cond_ptr then goto done
- else if cur_mod=fi_code then @<Pop the condition stack@>;
- end
-
-
-@ @<Display the boolean value...@>=
-begin begin_diagnostic;
-if cur_exp=true_code then print("{true}")@+else print("{false}");
-end_diagnostic(false);
-end
-
-@ 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 cur_mod>if_limit then
- if if_limit=if_code then {condition not yet evaluated}
- begin missing_err(":");
-@.Missing `:'@>
- back_input; cur_sym:=frozen_colon; ins_error;
- end
- else begin print_err("Extra "); print_cmd_mod(fi_or_else,cur_mod);
-@.Extra else@>
-@.Extra elseif@>
-@.Extra fi@>
- help1("I'm ignoring this; it doesn't match any if.");
- error;
- end
-else begin while cur_mod<>fi_code do pass_text; {skip to \&{fi}}
- @<Pop the condition stack@>;
- end
-
-@* \[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)=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>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(#)==#+1 {where the |loop_list| field resides}
-@d loop_type(#)==info(loop_list_loc(#)) {the type of \&{for} loop}
-@d loop_list(#)==link(loop_list_loc(#)) {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(#)==mem[#+2].sc {the step size in an arithmetic progression}
-@d final_value(#)==mem[#+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...@>=
-@!loop_ptr:pointer; {top of the loop-control-node stack}
-
-@ @<Set init...@>=
-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.
-
-@p procedure bad_for(@!s:str_number);
-begin disp_err(null,"Improper "); {show the bad expression above the message}
-@.Improper...replaced by 0@>
-print(s); print(" 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.");
-put_get_flush_error(0);
-end;
-
-@ 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.)
-
-@p procedure begin_iteration;
-label continue,done;
-var @!m:halfword; {|expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes})}
-@!n:halfword; {hash address of the current symbol}
-@!s:pointer; {the new loop-control node}
-@!p:pointer; {substitution list for |scan_toks|}
-@!q:pointer; {link manipulation register}
-@!pp:pointer; {a new progression node}
-begin m:=cur_mod; n:=cur_sym; s:=get_node(loop_node_size);
-if m=start_forever then
- begin loop_type(s):=void; p:=null; get_x_next;
- end
-else begin get_symbol; p:=get_node(token_node_size);
- info(p):=cur_sym; value(p):=m;@/
- get_x_next;
- if cur_cmd=within_token then @<Set up a picture iteration@>
- else begin @<Check for the |"="| or |":="| in a loop header@>;
- @<Scan the values to be used in the loop@>;
- end;
- end;
-@<Check for the presence of a colon@>;
-@<Scan the loop text and put it on the loop control stack@>;
-resume_iteration;
-end;
-
-@ @<Check for the |"="| or |":="| in a loop header@>=
-if (cur_cmd<>equals)and(cur_cmd<>assignment) then
- begin missing_err("=");@/
-@.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.");@/
- back_error;
- end
-
-@ @<Check for the presence of a colon@>=
-if cur_cmd<>colon then
- begin missing_err(":");@/
-@.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.");
- back_error;
- end
-
-@ 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:=get_avail; info(q):=frozen_repeat_loop;
-scanner_status:=loop_defining; warning_info:=n;
-info(s):=scan_toks(iteration,p,q,0); scanner_status:=normal;@/
-link(s):=loop_ptr; loop_ptr:=s
-
-@ @<Initialize table...@>=
-eq_type(frozen_repeat_loop):=repeat_loop+outer_tag;
-text(frozen_repeat_loop):=" ENDFOR";
-
-@ The loop text is inserted into \MP's scanning apparatus by the
-|resume_iteration| routine.
-
-@p procedure resume_iteration;
-label not_found,exit;
-var @!p,@!q:pointer; {link registers}
-begin p:=loop_type(loop_ptr);
-if p=progression_flag then
- begin p:=loop_list(loop_ptr); {now |p| points to a progression node}
- cur_exp:=value(p);
- if @<The arithmetic progression has ended@> then goto not_found;
- cur_type:=known; q:=stash_cur_exp; {make |q| an \&{expr} argument}
- value(p):=cur_exp+step_size(p); {set |value(p)| for the next iteration}
- end
-else if p=null then
- begin p:=loop_list(loop_ptr);
- if p=null then goto not_found;
- loop_list(loop_ptr):=link(p); q:=info(p); free_avail(p);
- end
-else if p=void then
- begin begin_token_list(info(loop_ptr),forever_text); return;
- end
-else @<Make |q| a capsule containing the next picture component from
- |loop_list(loop_ptr)| or |goto not_found|@>;
-begin_token_list(info(loop_ptr),loop_text);
-stack_argument(q);
-if internal[tracing_commands]>unity then @<Trace the start of a loop@>;
-return;
-not_found:stop_iteration;
-exit:end;
-
-@ @<The arithmetic progression has ended@>=
-((step_size(p)>0)and(cur_exp>final_value(p)))or@|
- ((step_size(p)<0)and(cur_exp<final_value(p)))
-
-@ @<Trace the start of a loop@>=
-begin begin_diagnostic; print_nl("{loop value=");
-@.loop value=n@>
-if (q<>null)and(link(q)=void) then print_exp(q,1)
-else show_token_list(q,null,50,0);
-print_char("}"); end_diagnostic(false);
-end
-
-@ @<Make |q| a capsule containing the next picture component from...@>=
-begin q:=loop_list(loop_ptr);
-if q=null then goto not_found;
-skip_component(q)(goto not_found);
-cur_exp:=copy_objects(loop_list(loop_ptr),q);
-init_bbox(cur_exp);
-cur_type:=picture_type;@/
-loop_list(loop_ptr):=q;
-q:=stash_cur_exp;
-end
-
-@ 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.
-
-@p procedure stop_iteration;
-var @!p,@!q:pointer; {the usual}
-begin p:=loop_type(loop_ptr);
-if p=progression_flag then free_node(loop_list(loop_ptr),progression_node_size)
-else if p=null then
- begin q:=loop_list(loop_ptr);
- while q<>null do
- begin p:=info(q);
- if p<>null then
- if link(p)=void then {it's an \&{expr} parameter}
- begin recycle_value(p); free_node(p,value_node_size);
- end
- else flush_token_list(p); {it's a \&{suffix} or \&{text} parameter}
- p:=q; q:=link(q); free_avail(p);
- end;
- end
-else if p>progression_flag then delete_edge_ref(p);
-p:=loop_ptr; loop_ptr:=link(p); flush_token_list(info(p));
-free_node(p,loop_node_size);
-end;
-
-@ 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)|}
-repeat get_x_next;
-if m<>expr_base then scan_suffix
-else begin if cur_cmd>=colon then if cur_cmd<=comma then goto continue;
- scan_expression;
- if cur_cmd=step_token then if q=loop_list_loc(s) then
- @<Prepare for step-until construction and |goto done|@>;
- cur_exp:=stash_cur_exp;
- end;
-link(q):=get_avail; q:=link(q); info(q):=cur_exp; cur_type:=vacuous;
-continue: until cur_cmd<>comma;
-done:
-
-@ @<Prepare for step-until construction and |goto done|@>=
-begin if cur_type<>known then bad_for("initial value");
-pp:=get_node(progression_node_size); value(pp):=cur_exp;@/
-get_x_next; scan_expression;
-if cur_type<>known then bad_for("step size");
-step_size(pp):=cur_exp;
-if cur_cmd<>until_token then
- begin missing_err("until");@/
-@.Missing `until'@>
- help2("I assume you meant to say `until' after `step'.")@/
- ("So I'll look for the final value and colon next.");
- back_error;
- end;
-get_x_next; scan_expression;
-if cur_type<>known then bad_for("final value");
-final_value(pp):=cur_exp; loop_list(s):=pp;
-loop_type(s):=progression_flag; goto done;
-end
-
-@ 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@>=
-begin get_x_next;
-scan_expression;
-@<Make sure the current expression is a known picture@>;
-loop_type(s):=cur_exp; cur_type:=vacuous;@/
-q:=link(dummy_loc(cur_exp));
-if q<> null then
- if is_start_or_stop(q) then
- if skip_1component(q)=null then q:=link(q);
-loop_list(s):=q;
-end
-
-@ @<Make sure the current expression is a known picture@>=
-if cur_type<>picture_type then
- begin
- disp_err(null,"Improper iteration spec has been replaced by nullpicture");
- help1("When you say `for x in p', p must be a known picture.");
- put_get_flush_error(get_node(edge_header_size));
- init_edges(cur_exp); cur_type:=picture_type;
- end
-
-@* \[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...@>=
-@!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 \.{""}}
-
-@ It is easier to maintain reference counts if we assign initial values.
-
-@<Set init...@>=
-cur_name:=""; cur_area:=""; 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...@>=
-@!area_delimiter:integer;
- {most recent `\.>' or `\.:' relative to |str_start[str_ptr]|}
-@!ext_delimiter:integer; {the relevant `\..', if any}
-
-@ Input files that can't be found in the user's area may appear in standard
-system areas called |MP_area| and |MF_area|. (The latter is used when the file
-extension is |".mf"|.) The standard system area for font metric files
-to be read is |MP_font_area|.
-This system area name will, of course, vary from place to place.
-@^system dependencies@>
-
-@d MP_area=="MPinputs:"
-@.MPinputs@>
-@d MF_area=="MFinputs:"
-@.MFinputs@>
-@d MP_font_area=="TeXfonts:"
-@.TeXfonts@>
-
-@ Here now is the first of the system-dependent routines for file name scanning.
-@^system dependencies@>
-
-@<Declare subroutines for parsing file names@>=
-procedure begin_name;
-begin delete_str_ref(cur_name); delete_str_ref(cur_area);
-delete_str_ref(cur_ext);@/
-area_delimiter:=-1; ext_delimiter:=-1;
-end;
-
-@ And here's the second.
-@^system dependencies@>
-
-@<Declare subroutines for parsing file names@>=
-function more_name(@!c:ASCII_code):boolean;
-begin if c=" " then more_name:=false
-else begin if (c=">")or(c=":") then
- begin area_delimiter:=pool_ptr-str_start[str_ptr]; ext_delimiter:=-1;
- end
- else if (c=".")and(ext_delimiter<0) then
- ext_delimiter:=pool_ptr-str_start[str_ptr];
- str_room(1); append_char(c); {contribute |c| to the current string}
- more_name:=true;
- end;
-end;
-
-@ The third.
-@^system dependencies@>
-
-@<Declare subroutines for parsing file names@>=
-procedure end_name;
-var a,@!n,@!e:pool_pointer; {length of area, name, and extension}
-begin e:=pool_ptr-str_start[str_ptr]; {total length}
-if ext_delimiter<0 then ext_delimiter:=e;
-a:=area_delimiter+1; n:=ext_delimiter-a; e:=e-ext_delimiter;
-if a=0 then cur_area:=""
-else begin cur_area:=make_string;
- chop_last_string(str_start[cur_area]+a);
- end;
-if n=0 then cur_name:=""
-else begin cur_name:=make_string;
- chop_last_string(str_start[cur_name]+n);
- end;
-if e=0 then cur_ext:="" @+ else cur_ext:=make_string;
-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 print(a); print(n); print(e);
-end;
-
-@ 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(#)==begin c:=#; incr(k);
- if k<=file_name_size then name_of_file[k]:=xchr[c];
- end
-
-@<Declare subroutines for parsing file names@>=
-procedure pack_file_name(@!n,@!a,@!e:str_number);
-var @!k:integer; {number of positions filled in |name_of_file|}
-@!c: ASCII_code; {character being packed}
-@!j:pool_pointer; {index into |str_pool|}
-begin k:=0;
-for j:=str_start[a] to str_stop(a)-1 do append_to_name(so(str_pool[j]));
-for j:=str_start[n] to str_stop(n)-1 do append_to_name(so(str_pool[j]));
-for j:=str_start[e] to str_stop(e)-1 do append_to_name(so(str_pool[j]));
-if k<=file_name_size then name_length:=k@+else name_length:=file_name_size;
-for k:=name_length+1 to file_name_size do name_of_file[k]:=' ';
-end;
-
-@ 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=15 {length of the |MP_mem_default| string}
-@d mem_area_length=6 {length of its area part}
-@d mem_ext_length=4 {length of its `\.{.mem}' part}
-@d mem_extension=".mem" {the extension, as a \.{WEB} constant}
-
-@<Glob...@>=
-@!MP_mem_default:packed array[1..mem_default_length] of char;
-
-@ @<Set init...@>=
-MP_mem_default:='MPlib:plain.mem';
-@.MPlib@>
-@.plain@>
-@^system dependencies@>
-
-@ @<Check the ``constant'' values for consistency@>=
-if mem_default_length>file_name_size then 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]|, 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@>
-
-@p procedure pack_buffered_name(@!n:small_number;@!a,@!b:integer);
-var @!k:integer; {number of positions filled in |name_of_file|}
-@!c: ASCII_code; {character being packed}
-@!j:integer; {index into |buffer| or |MP_mem_default|}
-begin if n+b-a+1+mem_ext_length>file_name_size then
- b:=a+file_name_size-n-1-mem_ext_length;
-k:=0;
-for j:=1 to n do append_to_name(xord[MP_mem_default[j]]);
-for j:=a to b do append_to_name(buffer[j]);
-for j:=mem_default_length-mem_ext_length+1 to mem_default_length do
- append_to_name(xord[MP_mem_default[j]]);
-if k<=file_name_size then name_length:=k@+else name_length:=file_name_size;
-for k:=name_length+1 to file_name_size do name_of_file[k]:=' ';
-end;
-
-@ 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]<>" "|.
-
-@<Declare the function called |open_mem_file|@>=
-function open_mem_file:boolean;
-label found,exit;
-var @!j:0..buf_size; {the first space after the 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(mem_file) then goto found;
- pack_buffered_name(mem_area_length,loc,j-1);
- {now try the system mem file area}
- if w_open_in(mem_file) then 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;
- end;
- {now pull out all the stops: try for the system \.{plain} file}
-pack_buffered_name(mem_default_length-mem_ext_length,1,0);
-if not w_open_in(mem_file) then
- begin wake_up_terminal;
- wterm_ln('I can''t find the PLAIN mem file!');
-@.I can't find PLAIN...@>
-@.plain@>
- open_mem_file:=false; return;
- end;
-found:loc:=j; open_mem_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 \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 in a \PASCAL\ program.
-@^system dependencies@>
-
-This routine might be called after string memory has overflowed, hence
-we check for this before calling `|str_room|'.
-
-@p function make_name_string:str_number;
-var @!k:1..file_name_size; {index into |name_of_file|}
-begin if str_overflowed then
- make_name_string:="?"
-else begin str_room(name_length);
- for k:=1 to name_length do append_char(xord[name_of_file[k]]);
- make_name_string:=make_string;
- end;
-end;
-function a_make_name_string(var @!f:alpha_file):str_number;
-begin a_make_name_string:=make_name_string;
-end;
-function b_make_name_string(var @!f:byte_file):str_number;
-begin b_make_name_string:=make_name_string;
-end;
-function w_make_name_string(var @!f:word_file):str_number;
-begin w_make_name_string:=make_name_string;
-end;
-
-@ 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@>
-
-@p procedure scan_file_name;
-label done;
-begin begin_name;
-while buffer[loc]=" " do incr(loc);
-loop@+begin if (buffer[loc]=";")or(buffer[loc]="%") then goto done;
- if not more_name(buffer[loc]) then goto done;
- incr(loc);
- end;
-done: end_name;
-end;
-
-@ Here is another version that takes its input from a string.
-
-@<Declare subroutines for parsing file names@>=
-procedure str_scan_file(@!s:str_number);
-label done;
-var @!p,@!q:pool_pointer; {current position and stopping point}
-begin begin_name;
-p:=str_start[s]; q:=str_stop(s);
-while p<q do
- begin if not more_name(so(str_pool[p])) then goto done;
- incr(p);
- end;
-done: end_name;
-end;
-
-@ 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...@>=
-@!job_name:str_number; {principal file name}
-@!log_opened:boolean; {has the transcript file been opened?}
-@!log_name:str_number; {full name of the log file}
-
-@ 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; 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"|, |".mem"|, |".ps"|, or .\\{nnn}}
-begin add_str_ref(s);
-delete_str_ref(cur_name); delete_str_ref(cur_area);
-delete_str_ref(cur_ext);@/
-cur_area:=""; cur_ext:=s;
-cur_name:=job_name; pack_cur_name;
-end;
-
-@ 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.
-
-@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="" 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
-
-@ 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}
-@!m:integer; {the current month}
-@!months:packed array [1..36] of char; {abbreviations of month names}
-begin old_setting:=selector;
-if job_name=0 then job_name:="mpout";
-pack_job_name(".log");
-while not a_open_out(log_file) do @<Try to get a different log file name@>;
-log_name:=a_make_name_string(log_file);
-selector:=log_only; log_opened:=true;
-@<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-1; {last position of first line}
-for k:=1 to l do print(buffer[k]);
-print_ln; {now the transcript file contains the first line of input}
-selector:=old_setting+2; {|log_only| or |term_and_log|}
-end;
-
-@ 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 |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);
-print(mem_ident); print(" ");
-print_int(round_unscaled(internal[day])); print_char(" ");
-months:='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
-m:=round_unscaled(internal[month]);
-for k:=3*m-2 to 3*m do wlog(months[k]);
-print_char(" "); print_int(round_unscaled(internal[year])); print_char(" ");
-m:=round_unscaled(internal[time]);
-print_dd(m div 60); print_char(":"); print_dd(m mod 60);
-end
-
-@ 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.
-
-@p function try_extension(@!ext:str_number):boolean;
-begin pack_file_name(cur_name,cur_area,ext);
-in_name:=cur_name; in_area:=cur_area;
-if a_open_in(cur_file) then try_extension:=true
-else begin if str_vs_str(ext,".mf")=0 then in_area:=MF_area
- else in_area:=MP_area;
- pack_file_name(cur_name,in_area,ext);
- try_extension:=a_open_in(cur_file);
- end;
-end;
-
-@ After all calls to |try_extension|, we must make sure that we count references
-for |in_name| and |in_area| if they match |cur_name| and/or |cur_area|.
-
-@<Update the string reference counts for |in_name| and |in_area|@>=
-if in_name=cur_name then add_str_ref(cur_name);
-if in_area=cur_area then add_str_ref(cur_area)
-
-@ 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; {\MP\ will \.{input} something}
-label done;
-begin @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
-loop@+ begin begin_file_reading; {set up |cur_file| and new level of input}
- if cur_ext="" then
- if try_extension(".mp") then goto done
- else if try_extension("") then goto done
- else if try_extension(".mf") then goto done
- else do_nothing
- else if try_extension(cur_ext) then goto done;
- end_file_reading; {remove the level that didn't work}
- prompt_file_name("input file name","");
- end;
-done: name:=a_make_name_string(cur_file);
-@<Update the string reference counts for |in_name| and |in_area|@>;
-if job_name=0 then
- begin job_name:=cur_name; str_ref[job_name]:=max_str_ref;
- open_log_file;
- end; {|open_log_file| doesn't |show_context|, so |limit|
- and |loc| needn't be set to meaningful values yet}
-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("("); incr(open_parens); print(name); update_terminal;
-@<Flush |name| and replace it with |cur_name| if it won't be needed@>;
-@<Read the first line of the new file@>;
-end;
-
-@ 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@>=
-flush_string(name); name:=cur_name; cur_name:=0
-
-@ Here we have to remember to tell the |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@>
-
-@<Read the first line...@>=
-begin line:=1;
-if input_ln(cur_file,false) then do_nothing;
-firm_up_the_line;
-buffer[limit]:="%"; first:=limit+1; loc:=start;
-end
-
-@ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
-while token_state and(loc=null) do end_token_list;
-if token_state then
- begin 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.");@/
- error;
- end;
-if file_state then scan_file_name
-else begin cur_name:=""; cur_ext:=""; cur_area:="";
- end
-
-@ Sometimes we need to deal with two file names at once. This procedure
-copies the given string into a special array for an old file name.
-
-@p procedure copy_old_name(s:str_number);
-var @!k:integer; {number of positions filled in |old_file_name|}
-@!j:pool_pointer; {index into |str_pool|}
-begin k:=0;
-for j:=str_start[s] to str_stop(s)-1 do
- begin incr(k);
- if k<=file_name_size then old_file_name[k]:=xchr[so(str_pool[j])];
- end;
-if k<=file_name_size then old_name_length:=k
-else old_name_length:=file_name_size;
-for k:=old_name_length+1 to file_name_size do @+old_file_name[k]:=' ';
-end;
-
-@ @<Glob...@>=
-@!old_file_name : packed array[1..file_name_size] of char;
- {analogous to |name_of_file|}
-@!old_name_length : 0..file_name_size;
- {this many relevant characters followed by blanks}
-
-@ The following simple routine starts reading the \.{MPX} file associated
-with the current input file.
-
-@p procedure start_mpx_input;
-label exit,not_found;
-var k:1..file_name_size;
-begin pack_file_name(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@>;
-begin_file_reading;
-if not a_open_in(cur_file) then
- begin end_file_reading;
- goto not_found;
- end;
-name:=a_make_name_string(cur_file);
-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|@>;
-exit:end;
-
-@ 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 |old_file_name| 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@>
-
-@<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
- |goto not_found| if there is a problem@>=
-copy_old_name(name)
-{System-dependent code should be added here}
-
-@ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
-if interaction=error_stop_mode then wake_up_terminal;
-print_nl(">> ");
-for k:=1 to old_name_length do print(xord[old_file_name[k]]);
-print_nl(">> ");
-for k:=1 to name_length do print(xord[name_of_file[k]]);
-print_nl("! 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@>=
-readf_index = 0..max_read_files;
-write_index = 0..max_write_files;
-
-@ @<Glob...@>=
-rd_file:array [readf_index] of alpha_file; {\&{readfrom} files}
-rd_fname:array [readf_index] of str_number;
- {corresponding file name or 0 if file not open}
-read_files:readf_index; {number of valid entries in the above arrays}
-wr_file:array [write_index] of alpha_file; {\&{write} files}
-wr_fname:array [write_index] of str_number;
- {corresponding file name or 0 if file not open}
-write_files:write_index; {number of valid entries in the above arrays}
-
-@ @<Set init...@>=
-read_files:=0;
-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]|.
-
-@p function start_read_input(s:str_number; n:readf_index):boolean;
-label exit,not_found;
-begin str_scan_file(s);
-pack_cur_name;
-begin_file_reading;
-if not a_open_in(rd_file[n]) then goto not_found;
-if not input_ln(rd_file[n],false) then
- begin a_close(rd_file[n]); goto not_found; end;
-rd_fname[n]:=s;
-add_str_ref(s);
-start_read_input:=true;
-return;
-not_found: end_file_reading;
-start_read_input:=false;
-exit:end;
-
-@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
-
-@p procedure open_write_file(s:str_number; n:readf_index);
-begin str_scan_file(s);
-pack_cur_name;
-while not a_open_out(wr_file[n]) do
- prompt_file_name("file name for write output","");
-wr_fname[n]:=s;
-add_str_ref(s);
-end;
-
-
-@* \[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...@>=
-@!cur_type:small_number; {the type of the expression just found}
-@!cur_exp:integer; {the value of the expression just found}
-
-@ @<Set init...@>=
-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=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=boolean_type| means that |cur_exp| is either |true_code|
-or |false_code|.
-
-\smallskip\hang
-|cur_type=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=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=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=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=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=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=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=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=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=transform_type| means that |cur_exp| points to a |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|, |proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=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|, |proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=cmykcolor_type| means that |cur_exp| points to a |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|, |proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=pair_type| means that |cur_exp| points to a capsule
-node whose type is |pair_type|. The |value| part of this capsule
-points to a pair node that contains two numeric values,
-each of which is |independent|, |dependent|, |proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=known| means that |cur_exp| is a |scaled| value.
-
-\smallskip\hang
-|cur_type=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=proto_dependent| means that |cur_exp| points to a |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=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 |numeric_type| or
-|suffixed_macro| or |unsuffixed_macro|, although variables of those types
-are allowed. Conversely, \MP\ has no variables of type |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
-|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, |unknown_boolean| to |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=token_list|.
-After the operation, |cur_type=vacuous|; hence there is no need to
-copy path lists or to update reference counts, etc.
-
-The special link |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@>=
-function stash_cur_exp:pointer;
-var @!p:pointer; {the capsule that will be returned}
-begin case cur_type of
-unknown_types,transform_type,color_type,pair_type,dependent,proto_dependent,
- independent,cmykcolor_type:p:=cur_exp;
-othercases begin p:=get_node(value_node_size); name_type(p):=capsule;
- type(p):=cur_type; value(p):=cur_exp;
- end
-endcases;@/
-cur_type:=vacuous; link(p):=void; stash_cur_exp:=p;
-end;
-
-@ 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=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...@>=
-procedure unstash_cur_exp(@!p:pointer);
-begin cur_type:=type(p);
-case cur_type of
-unknown_types,transform_type,color_type,pair_type,dependent,proto_dependent,
- independent,cmykcolor_type: cur_exp:=p;
-othercases begin cur_exp:=value(p);
- free_node(p,value_node_size);
- end
-endcases;@/
-end;
-
-@ 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@>=
-@t\4@>@<Declare the procedure called |print_dp|@>@;
-@t\4@>@<Declare the stashing/unstashing routines@>@;
-procedure print_exp(@!p:pointer;@!verbosity:small_number);
-var @!restore_cur_exp:boolean; {should |cur_exp| be restored?}
-@!t:small_number; {the type of the expression}
-@!v:integer; {the value of the expression}
-@!q:pointer; {a big node being displayed}
-begin if p<>null then restore_cur_exp:=false
-else begin p:=stash_cur_exp; restore_cur_exp:=true;
- end;
-t:=type(p); v:=0;
-if t<dependent then v:=value(p)@+else if t<independent then v:=dep_list(p);
-@<Print an abbreviated value of |v| with format depending on |t|@>;
-if restore_cur_exp then unstash_cur_exp(p);
-end;
-
-@ @<Print an abbreviated value of |v| with format depending on |t|@>=
-case t of
-vacuous:print("vacuous");
-boolean_type:if v=true_code then print("true")@+else print("false");
-unknown_types,numeric_type:@<Display a variable
- that's been declared but not defined@>;
-string_type:begin print_char(""""); print(v); print_char("""");
- end;
-pen_type,path_type,picture_type:@<Display a complex type@>;
-transform_type,color_type,pair_type,cmykcolor_type:if v=null then print_type(t)
- else @<Display a big node@>;
-known:print_scaled(v);
-dependent,proto_dependent:print_dp(t,v,verbosity);
-independent:print_variable_name(p);
-othercases confusion("exp")
-@:this can't happen exp}{\quad exp@>
-endcases
-
-@ @<Display a big node@>=
-begin print_char("("); q:=v+big_node_size[t];
-repeat if type(v)=known then print_scaled(value(v))
-else if type(v)=independent then print_variable_name(v)
-else print_dp(type(v),dep_list(v),verbosity);
-v:=v+2;
-if v<>q then print_char(",");
-until v=q;
-print_char(")");
-end
-
-@ 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 then print_type(t)
-else begin if selector=term_and_log then
- if internal[tracing_online]<=0 then
- begin selector:=term_only;
- print_type(t); print(" (see the transcript file)");
- selector:=term_and_log;
- end;
- case t of
- pen_type:print_pen(v,"",false);
- path_type:print_path(v,"",false);
- picture_type:print_edges(v,"",false);
- end; {there are no other cases}
- end
-
-@ @<Declare the procedure called |print_dp|@>=
-procedure print_dp(@!t:small_number;@!p:pointer;@!verbosity:small_number);
-var @!q:pointer; {the node following |p|}
-begin q:=link(p);
-if (info(q)=null) or (verbosity>0) then print_dependency(p,t)
-else print("linearform");
-@.linearform@>
-end;
-
-@ 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@>=
-begin print_type(t);
-if v<>null then
- begin print_char(" ");
- while (name_type(v)=capsule) and (v<>p) do v:=value(v);
- print_variable_name(v);
- end;
-end
-
-@ 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(#)==disp_err(null,#) {displays the current expression}
-
-@<Declare subroutines for printing expressions@>=
-procedure disp_err(@!p:pointer;@!s:str_number);
-begin if interaction=error_stop_mode then wake_up_terminal;
-print_nl(">> ");
-@.>>@>
-print_exp(p,1); {``medium verbose'' printing of the expression}
-if s<>"" then
- begin print_nl("! "); print(s);
-@.!\relax@>
- end;
-end;
-
-@ 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.
-
-@<Declare the procedure called |flush_cur_exp|@>=
-procedure flush_cur_exp(@!v:scaled);
-begin case cur_type of
-unknown_types,transform_type,color_type,pair_type,@|
- dependent,proto_dependent,independent,cmykcolor_type:
- begin recycle_value(cur_exp); free_node(cur_exp,value_node_size);
- end;
-string_type:delete_str_ref(cur_exp);
-pen_type,path_type: toss_knot_list(cur_exp);
-picture_type:delete_edge_ref(cur_exp);
-othercases do_nothing
-endcases;@/
-cur_type:=known; cur_exp:=v;
-end;
-
-@ 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@>=
-procedure recycle_value(@!p:pointer);
-label done;
-var @!t:small_number; {a type code}
-@!v:integer; {a value}
-@!vv:integer; {another value}
-@!q,@!r,@!s,@!pp:pointer; {link manipulation registers}
-begin t:=type(p); v:=0;
-if t<dependent then v:=value(p);
-case t of
-undefined,vacuous,boolean_type,known,numeric_type:do_nothing;
-unknown_types:ring_delete(p);
-string_type:delete_str_ref(v);
-path_type,pen_type:toss_knot_list(v);
-picture_type:delete_edge_ref(v);
-cmykcolor_type,pair_type,color_type,transform_type:@<Recycle a big node@>;
-dependent,proto_dependent:@<Recycle a dependency list@>;
-independent:@<Recycle an independent variable@>;
-token_list,structured:confusion("recycle");
-@:this can't happen recycle}{\quad recycle@>
-unsuffixed_macro,suffixed_macro:delete_mac_ref(value(p));
-end; {there are no other cases}
-type(p):=undefined;
-end;
-
-@ @<Recycle a big node@>=
-if v<>null then
- begin q:=v+big_node_size[t];
- repeat q:=q-2; recycle_value(q);
- until q=v;
- free_node(v,big_node_size[t]);
- end
-
-@ @<Recycle a dependency list@>=
-begin q:=dep_list(p);
-while info(q)<>null do q:=link(q);
-link(prev_dep(p)):=link(q);
-prev_dep(link(q)):=prev_dep(p);
-link(q):=null; flush_node_list(dep_list(p));
-end
-
-@ 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@>=
-begin max_c[dependent]:=0; max_c[proto_dependent]:=0;@/
-max_link[dependent]:=null; max_link[proto_dependent]:=null;@/
-q:=link(dep_head);
-while q<>dep_head do
- begin s:=value_loc(q); {now |link(s)=dep_list(q)|}
- loop@+ begin r:=link(s);
- if info(r)=null then goto done;
- if info(r)<>p then s:=r
- else begin t:=type(q); link(s):=link(r); info(r):=q;
- if abs(value(r))>max_c[t] then
- @<Record a new maximum coefficient of type |t|@>
- else begin link(r):=max_link[t]; max_link[t]:=r;
- end;
- end;
- end;
-done: q:=link(r);
- end;
-if (max_c[dependent]>0)or(max_c[proto_dependent]>0) then
- @<Choose a dependent variable to take the place of the disappearing
- independent variable, and change all remaining dependencies
- accordingly@>;
-end
-
-@ The code for independency removal makes use of three two-word arrays.
-
-@<Glob...@>=
-@!max_c:array[dependent..proto_dependent] of integer;
- {max coefficient magnitude}
-@!max_ptr:array[dependent..proto_dependent] of pointer;
- {where |p| occurs with |max_c|}
-@!max_link:array[dependent..proto_dependent] of pointer;
- {other occurrences of |p|}
-
-@ @<Record a new maximum coefficient...@>=
-begin if max_c[t]>0 then
- begin link(max_ptr[t]):=max_link[t]; max_link[t]:=max_ptr[t];
- end;
-max_c[t]:=abs(value(r)); max_ptr[t]:=r;
-end
-
-@ @<Choose a dependent...@>=
-begin if (max_c[dependent] div @'10000 >=
- max_c[proto_dependent]) then
- t:=dependent
-else t:=proto_dependent;
-@<Determine the dependency list |s| to substitute for the independent
- variable~|p|@>;
-t:=dependent+proto_dependent-t; {complement |t|}
-if max_c[t]>0 then {we need to pick up an unchosen dependency}
- begin link(max_ptr[t]):=max_link[t]; max_link[t]:=max_ptr[t];
- end;
-if t<>dependent then @<Substitute new dependencies in place of |p|@>
-else @<Substitute new proto-dependencies in place of |p|@>;
-flush_node_list(s);
-if fix_needed then fix_dependencies;
-check_arith;
-end
-
-@ 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:=max_ptr[t]; pp:=info(s); v:=value(s);
-if t=dependent then value(s):=-fraction_one@+else value(s):=-unity;
-r:=dep_list(pp); link(s):=r;
-while info(r)<>null do r:=link(r);
-q:=link(r); link(r):=null;
-prev_dep(q):=prev_dep(pp); link(prev_dep(pp)):=q;
-new_indep(pp);
-if cur_exp=pp then if cur_type=t then cur_type:=independent;
-if internal[tracing_equations]>0 then @<Show the transformed dependency@>
-
-@ Now $(-v)$ times the formerly independent variable~|p| is being replaced
-by the dependency list~|s|.
-
-@<Show the transformed...@>=
-if interesting(p) then
- begin begin_diagnostic; print_nl("### ");
-@:]]]\#\#\#_}{\.{\#\#\#}@>
- if v>0 then print_char("-");
- if t=dependent then vv:=round_fraction(max_c[dependent])
- else vv:=max_c[proto_dependent];
- if vv<>unity then print_scaled(vv);
- print_variable_name(p);
- while value(p) mod s_scale>0 do
- begin print("*4"); value(p):=value(p)-2;
- end;
- if t=dependent then print_char("=")@+else print(" = ");
- print_dependency(s,t);
- end_diagnostic(false);
- end
-
-@ Finally, there are dependent and proto-dependent variables whose
-dependency lists must be brought up to date.
-
-@<Substitute new dependencies...@>=
-for t:=dependent to proto_dependent do
- begin r:=max_link[t];
- while r<>null do
- begin q:=info(r);
- dep_list(q):=p_plus_fq(dep_list(q),@|
- make_fraction(value(r),-v),s,t,dependent);
- if dep_list(q)=dep_final then make_known(q,dep_final);
- q:=r; r:=link(r); free_node(q,dep_node_size);
- end;
- end
-
-@ @<Substitute new proto...@>=
-for t:=dependent to proto_dependent do
- begin r:=max_link[t];
- while r<>null do
- begin q:=info(r);
- if t=dependent then {for safety's sake, we change |q| to |proto_dependent|}
- begin if cur_exp=q then if cur_type=dependent then
- cur_type:=proto_dependent;
- dep_list(q):=p_over_v(dep_list(q),unity,dependent,proto_dependent);
- type(q):=proto_dependent; value(r):=round_fraction(value(r));
- end;
- dep_list(q):=p_plus_fq(dep_list(q),@|
- make_scaled(value(r),-v),s,proto_dependent,proto_dependent);
- if dep_list(q)=dep_final then make_known(q,dep_final);
- q:=r; r:=link(r); free_node(q,dep_node_size);
- end;
- end
-
-@ 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.)
-
-@<Declare the procedure called |flush_cur_exp|@>=
-procedure flush_error(@!v:scaled);@+begin error; flush_cur_exp(v);@+end;
-@#
-procedure@?back_error; forward;@t\2@>@/
-procedure@?get_x_next; forward;@t\2@>@/
-@#
-procedure put_get_error;@+begin back_error; get_x_next;@+end;
-@#
-procedure put_get_flush_error(@!v:scaled);@+begin put_get_error;
- flush_cur_exp(v);@+end;
-
-@ 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...@>=
-@!var_flag:0..max_command_code; {command that wants a variable}
-
-@ @<Set init...@>=
-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@>=
-procedure scan_primary;
-label restart, done, done1, done2;
-var @!p,@!q,@!r:pointer; {for list manipulation}
-@!c:quarterword; {a primitive operation code}
-@!my_var_flag:0..max_command_code; {initial value of |my_var_flag|}
-@!l_delim,@!r_delim:pointer; {hash addresses of a delimiter pair}
-@<Other local variables for |scan_primary|@>@;
-begin my_var_flag:=var_flag; var_flag:=0;
-restart:check_arith;
-@<Supply diagnostic information, if requested@>;
-case cur_cmd of
-left_delimiter:@<Scan a delimited primary@>;
-begin_group:@<Scan a grouped primary@>;
-string_token:@<Scan a string constant@>;
-numeric_token:@<Scan a primary that starts with a numeric token@>;
-nullary:@<Scan a nullary operation@>;
-unary,type_name,cycle,plus_or_minus:@<Scan a unary operation@>;
-primary_binary:@<Scan a binary operation with `\&{of}' between its operands@>;
-str_op:@<Convert a suffix to a string@>;
-internal_quantity:@<Scan an internal numeric quantity@>;
-capsule_token:make_exp_copy(cur_mod);
-tag_token:@<Scan a variable primary;
- |goto restart| if it turns out to be a macro@>;
-othercases begin bad_exp("A primary"); goto restart;
-@.A primary expression...@>
- end
-endcases;@/
-get_x_next; {the routines |goto done| if they don't want this}
-done: if cur_cmd=left_bracket then
- if cur_type>=known then @<Scan a mediation construction@>;
-end;
-
-@ Errors at the beginning of expressions are flagged by |bad_exp|.
-
-@p procedure bad_exp(@!s:str_number);
-var save_flag:0..max_command_code;
-begin print_err(s); print(" expression can't begin with `");
-print_cmd_mod(cur_cmd,cur_mod); print_char("'");
-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@>
-back_input; cur_sym:=0; cur_cmd:=numeric_token; cur_mod:=0; ins_error;@/
-save_flag:=var_flag; var_flag:=0; get_x_next;
-var_flag:=save_flag;
-end;
-
-@ @<Supply diagnostic information, if requested@>=
-debug if panicking then check_mem(false);@+gubed@;@/
-if interrupt<>0 then if OK_to_interrupt then
- begin back_input; check_interrupt; get_x_next;
- end
-
-@ @<Scan a delimited primary@>=
-begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next; scan_expression;
-if (cur_cmd=comma) and (cur_type>=known) then
- @<Scan the rest of a delimited set of numerics@>
-else check_delimiter(l_delim,r_delim);
-end
-
-@ The |stash_in| subroutine puts the current (numeric) expression into a field
-within a ``big node.''
-
-@p procedure stash_in(@!p:pointer);
-var @!q:pointer; {temporary register}
-begin type(p):=cur_type;
-if cur_type=known then value(p):=cur_exp
-else begin if cur_type=independent then
- @<Stash an independent |cur_exp| into a big node@>
- else begin mem[value_loc(p)]:=mem[value_loc(cur_exp)];
- {|dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)|}
- link(prev_dep(p)):=p;
- end;
- free_node(cur_exp,value_node_size);
- end;
-cur_type:=vacuous;
-end;
-
-@ 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|...@>=
-begin q:=single_dependency(cur_exp);
-if q=dep_final then
- begin type(p):=known; value(p):=0; free_node(q,dep_node_size);
- end
-else begin type(p):=dependent; new_dep(p,q);
- end;
-recycle_value(cur_exp);
-end
-
-@ 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@>=
-begin p:=stash_cur_exp;
-get_x_next; scan_expression;
-@<Make sure the second part of a pair or color has a numeric type@>;
-q:=get_node(value_node_size); name_type(q):=capsule;
-if cur_cmd=comma then type(q):=color_type
-else type(q):=pair_type;
-init_big_node(q); r:=value(q);
-stash_in(y_part_loc(r));
-unstash_cur_exp(p);
-stash_in(x_part_loc(r));
-if cur_cmd=comma then @<Scan the last of a triplet of numerics@>;
-if cur_cmd=comma then begin
- type(q):=cmykcolor_type;
- init_big_node(q); t:=value(q);
- mem[cyan_part_loc(t)]:=mem[red_part_loc(r)];
- value(cyan_part_loc(t)):=value(red_part_loc(r));
- mem[magenta_part_loc(t)]:=mem[green_part_loc(r)];
- value(magenta_part_loc(t)):=value(green_part_loc(r));
- mem[yellow_part_loc(t)]:=mem[blue_part_loc(r)];
- value(yellow_part_loc(t)):=value(blue_part_loc(r));
- recycle_value(r);
- r:=t;
- @<Scan the last of a quartet of numerics@>;
- end;
-check_delimiter(l_delim,r_delim);
-cur_type:=type(q);
-cur_exp:=q;
-end
-
-@ @<Make sure the second part of a pair or color has a numeric type@>=
-if cur_type<known then
- begin 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.)");
- put_get_flush_error(0);
- end
-
-@ @<Scan the last of a triplet of numerics@>=
-begin get_x_next; scan_expression;
-if cur_type<known then
- begin 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.)");@/
- put_get_flush_error(0);
- end;
-stash_in(blue_part_loc(r));
-end
-
-@ @<Scan the last of a quartet of numerics@>=
-begin get_x_next; scan_expression;
-if cur_type<known then
- begin 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.)");@/
- put_get_flush_error(0);
- end;
-stash_in(black_part_loc(r));
-end
-
-@ 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|@>=
-@!group_line:integer; {where a group began}
-
-@ @<Scan a grouped primary@>=
-begin group_line:=true_line;
-if internal[tracing_commands]>0 then show_cur_cmd_mod;
-save_boundary_item(p);
-repeat do_statement; {ends with |cur_cmd>=semicolon|}
-until cur_cmd<>semicolon;
-if cur_cmd<>end_group then
- begin print_err("A group begun on line ");
-@.A group...never ended@>
- print_int(group_line);
- print(" never ended");
- help2("I saw a `begingroup' back there that hasn't been matched")@/
- ("by `endgroup'. So I've inserted `endgroup' now.");
- back_error; cur_cmd:=end_group;
- end;
-unsave; {this might change |cur_type|, if independent variables are recycled}
-if internal[tracing_commands]>0 then show_cur_cmd_mod;
-end
-
-@ @<Scan a string constant@>=
-begin cur_type:=string_type; cur_exp:=cur_mod;
-end
-
-@ 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@>=do_nullary(cur_mod)
-
-@ @<Scan a unary operation@>=
-begin c:=cur_mod; get_x_next; scan_primary; do_unary(c); goto done;
-end
-
-@ 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|@>=
-@!num,@!denom:scaled; {for primaries that are fractions, like `1/2'}
-
-@ @<Scan a primary that starts with a numeric token@>=
-begin cur_exp:=cur_mod; cur_type:=known; get_x_next;
-if cur_cmd<>slash then
- begin num:=0; denom:=0;
- end
-else begin get_x_next;
- if cur_cmd<>numeric_token then
- begin back_input;
- cur_cmd:=slash; cur_mod:=over; cur_sym:=frozen_slash;
- goto done;
- end;
- num:=cur_exp; denom:=cur_mod;
- if denom=0 then @<Protest division by zero@>
- else cur_exp:=make_scaled(num,denom);
- check_arith; get_x_next;
- end;
-if cur_cmd>=min_primary_command then
- if cur_cmd<numeric_token then {in particular, |cur_cmd<>plus_or_minus|}
- begin p:=stash_cur_exp; scan_primary;
- if (abs(num)>=abs(denom))or(cur_type<color_type) then do_binary(p,times)
- else begin frac_mult(num,denom);
- free_node(p,value_node_size);
- end;
- end;
-goto done;
-end
-
-@ @<Protest division...@>=
-begin print_err("Division by zero");
-@.Division by zero@>
-help1("I'll pretend that you meant to divide by 1."); error;
-end
-
-@ @<Scan a binary operation with `\&{of}' between its operands@>=
-begin c:=cur_mod; get_x_next; scan_expression;
-if cur_cmd<>of_token then
- begin missing_err("of"); print(" for "); print_cmd_mod(primary_binary,c);
-@.Missing `of'@>
- help1("I've got the first argument; will look now for the other.");
- back_error;
- end;
-p:=stash_cur_exp; get_x_next; scan_primary; do_binary(p,c); goto done;
-end
-
-@ @<Convert a suffix to a string@>=
-begin get_x_next; scan_suffix; old_setting:=selector; selector:=new_string;
-show_token_list(cur_exp,null,100000,0); flush_token_list(cur_exp);
-cur_exp:=make_string; selector:=old_setting; cur_type:=string_type;
-goto done;
-end
-
-@ 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...@>=
-begin q:=cur_mod;
-if my_var_flag=assignment then
- begin get_x_next;
- if cur_cmd=assignment then
- begin cur_exp:=get_avail;
- info(cur_exp):=q+hash_end; cur_type:=token_list; goto done;
- end;
- back_input;
- end;
-cur_type:=known; cur_exp:=internal[q];
-end
-
-@ 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>=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<unsuffixed_macro|, the precise value of |tt| isn't critical.
-
-@ @<Other local variables for |scan_primary|@>=
-@!pre_head,@!post_head,@!tail:pointer;
- {prefix and suffix list variables}
-@!tt:small_number; {approximation to the type of the variable-so-far}
-@!t:pointer; {a token}
-@!macro_ref:pointer; {reference count for a suffixed macro}
-
-@ @<Scan a variable primary...@>=
-begin fast_get_avail(pre_head); tail:=pre_head; post_head:=null; tt:=vacuous;
-macro_ref:=null;
-loop@+ begin t:=cur_tok; link(tail):=t;
- if tt<>undefined then
- begin @<Find the approximate type |tt| and corresponding~|q|@>;
- if tt>=unsuffixed_macro then
- @<Either begin an unsuffixed macro call or
- prepare for a suffixed one@>;
- end;
- get_x_next; tail:=t;
- if cur_cmd=left_bracket then
- @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
- if cur_cmd>max_suffix_token then goto done1;
- if cur_cmd<min_suffix_token then goto done1;
- end; {now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token|}
-done1:@<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|@>;
-end
-
-@ @<Either begin an unsuffixed macro call or...@>=
-begin link(tail):=null;
-if tt>unsuffixed_macro then {|tt=suffixed_macro|}
- begin post_head:=get_avail; tail:=post_head; link(tail):=t;@/
- tt:=undefined; macro_ref:=value(q); add_mac_ref(macro_ref);
- end
-else @<Set up unsuffixed macro call and |goto restart|@>;
-end
-
-@ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
-begin get_x_next; scan_expression;
-if cur_cmd<>right_bracket then
- @<Put the left bracket and the expression back to be rescanned@>
-else begin if cur_type<>known then bad_subscript;
- cur_cmd:=numeric_token; cur_mod:=cur_exp; cur_sym:=0;
- end;
-end
-
-@ 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@>=
-begin back_input; {that was the token following the current expression}
-back_expr; cur_cmd:=left_bracket; cur_mod:=0; cur_sym:=frozen_left_bracket;
-end
-
-@ Here's a routine that puts the current expression back to be read again.
-
-@p procedure back_expr;
-var @!p:pointer; {capsule token}
-begin p:=stash_cur_exp; link(p):=null; back_list(p);
-end;
-
-@ Unknown subscripts lead to the following error message.
-
-@p procedure bad_subscript;
-begin 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.");
-flush_error(0);
-end;
-
-@ 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@>
-begin p:=link(pre_head); q:=info(p); tt:=undefined;
-if eq_type(q) mod outer_tag=tag_token then
- begin q:=equiv(q);
- if q=null then goto done2;
- loop@+ begin p:=link(p);
- if p=null then
- begin tt:=type(q); goto done2;
- end;
- if type(q)<>structured then goto done2;
- q:=link(attr_head(q)); {the |collective_subscript| attribute}
- if p>=hi_mem_min then {it's not a subscript}
- begin repeat q:=link(q);
- until attr_loc(q)>=info(p);
- if attr_loc(q)>info(p) then goto done2;
- end;
- end;
- end;
-done2:end
-
-@ 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.
-
-@p procedure obliterated(@!q:pointer);
-begin print_err("Variable "); show_token_list(q,null,1000,0);
-print(" 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.");
-end;
-
-@ 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 then @<Set up suffixed macro call and |goto restart|@>;
-q:=link(pre_head); free_avail(pre_head);
-if cur_cmd=my_var_flag then
- begin cur_type:=token_list; cur_exp:=q; goto done;
- end;
-p:=find_variable(q);
-if p<>null then make_exp_copy(p)
-else begin obliterated(q);@/
- help_line[2]:="While I was evaluating the suffix of this variable,";
- help_line[1]:="something was redefined, and it's no longer a variable!";
- help_line[0]:="In order to get back on my feet, I've inserted `0' instead.";
- put_get_flush_error(0);
- end;
-flush_node_list(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|@>=
-begin p:=get_avail; info(pre_head):=link(pre_head); link(pre_head):=p;
-info(p):=t; macro_call(value(q),pre_head,null); get_x_next; goto restart;
-end
-
-@ 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|@>=
-begin back_input; p:=get_avail; 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;
-macro_call(macro_ref,pre_head,null); decr(ref_count(macro_ref));
-get_x_next; goto restart;
-end
-
-@ 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|@>=
-@t\4@>@<Declare subroutines needed by |make_exp_copy|@>@;
-procedure make_exp_copy(@!p:pointer);
-label restart;
-var @!q,@!r,@!t:pointer; {registers for list manipulation}
-begin restart: cur_type:=type(p);
-case cur_type of
-vacuous,boolean_type,known:cur_exp:=value(p);
-unknown_types:cur_exp:=new_ring_entry(p);
-string_type:begin cur_exp:=value(p); add_str_ref(cur_exp);
- end;
-picture_type:begin cur_exp:=value(p);add_edge_ref(cur_exp);
- end;
-pen_type:cur_exp:=copy_pen(value(p));
-path_type:cur_exp:=copy_path(value(p));
-transform_type,color_type,cmykcolor_type,pair_type:@<Copy the big node |p|@>;
-dependent,proto_dependent:encapsulate(copy_dep_list(dep_list(p)));
-numeric_type:begin new_indep(p); goto restart;
- end;
-independent: begin q:=single_dependency(p);
- if q=dep_final then
- begin cur_type:=known; cur_exp:=0; free_node(q,dep_node_size);
- end
- else begin cur_type:=dependent; encapsulate(q);
- end;
- end;
-othercases confusion("copy")
-@:this can't happen copy}{\quad copy@>
-endcases;
-end;
-
-@ The |encapsulate| subroutine assumes that |dep_final| is the
-tail of dependency list~|p|.
-
-@<Declare subroutines needed by |make_exp_copy|@>=
-procedure encapsulate(@!p:pointer);
-begin cur_exp:=get_node(value_node_size); type(cur_exp):=cur_type;
-name_type(cur_exp):=capsule; new_dep(cur_exp,p);
-end;
-
-@ 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|, |proto_dependent|,
-or |known|.
-
-@<Copy the big node |p|@>=
-begin if value(p)=null then init_big_node(p);
-t:=get_node(value_node_size); name_type(t):=capsule; type(t):=cur_type;
-init_big_node(t);@/
-q:=value(p)+big_node_size[cur_type]; r:=value(t)+big_node_size[cur_type];
-repeat q:=q-2; r:=r-2; install(r,q);
-until q=value(p);
-cur_exp:=t;
-end
-
-@ 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|@>=
-procedure install(@!r,@!q:pointer);
-var p:pointer; {temporary register}
-begin if type(q)=known then
- begin value(r):=value(q); type(r):=known;
- end
-else if type(q)=independent then
- begin p:=single_dependency(q);
- if p=dep_final then
- begin type(r):=known; value(r):=0; free_node(p,dep_node_size);
- end
- else begin type(r):=dependent; new_dep(r,p);
- end;
- end
- else begin type(r):=type(q); new_dep(r,copy_dep_list(dep_list(q)));
- end;
-end;
-
-@ 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...@>=
-begin p:=stash_cur_exp; get_x_next; scan_expression;
-if cur_cmd<>comma then
- begin @<Put the left bracket and the expression back...@>;
- unstash_cur_exp(p);
- end
-else begin q:=stash_cur_exp; get_x_next; scan_expression;
- if cur_cmd<>right_bracket then
- begin missing_err("]");@/
-@.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.");@/
- back_error;
- end;
- r:=stash_cur_exp; make_exp_copy(q);@/
- do_binary(r,minus); do_binary(p,times); do_binary(q,plus); get_x_next;
- end;
-end
-
-@ Here is a comparatively simple routine that is used to scan the
-\&{suffix} parameters of a macro.
-
-@<Declare the basic parsing subroutines@>=
-procedure scan_suffix;
-label done;
-var @!h,@!t:pointer; {head and tail of the list being built}
-@!p:pointer; {temporary register}
-begin h:=get_avail; t:=h;
-loop@+ begin if cur_cmd=left_bracket then
- @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
- if cur_cmd=numeric_token then p:=new_num_tok(cur_mod)
- else if (cur_cmd=tag_token)or(cur_cmd=internal_quantity) then
- begin p:=get_avail; info(p):=cur_sym;
- end
- else goto done;
- link(t):=p; t:=p; get_x_next;
- end;
-done: cur_exp:=link(h); free_avail(h); cur_type:=token_list;
-end;
-
-@ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
-begin get_x_next; scan_expression;
-if cur_type<>known then bad_subscript;
-if cur_cmd<>right_bracket then
- begin missing_err("]");@/
-@.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.");@/
- back_error;
- end;
-cur_cmd:=numeric_token; cur_mod:=cur_exp;
-end
-
-@* \[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@>=
-procedure scan_secondary;
-label restart,continue;
-var @!p:pointer; {for list manipulation}
-@!c,@!d:halfword; {operation codes or modifiers}
-@!mac_name:pointer; {token defined with \&{primarydef}}
-begin restart:if(cur_cmd<min_primary_command)or@|
- (cur_cmd>max_primary_command) then
- bad_exp("A secondary");
-@.A secondary expression...@>
-scan_primary;
-continue: if cur_cmd<=max_secondary_command then
- if cur_cmd>=min_secondary_command then
- begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd;
- if d=secondary_primary_macro then
- begin mac_name:=cur_sym; add_mac_ref(c);
- end;
- get_x_next; scan_primary;
- if d<>secondary_primary_macro then do_binary(p,c)
- else begin back_input; binary_mac(p,c,mac_name);
- decr(ref_count(c)); get_x_next; goto restart;
- end;
- goto continue;
- end;
-end;
-
-@ The following procedure calls a macro that has two parameters,
-|p| and |cur_exp|.
-
-@p procedure binary_mac(@!p,@!c,@!n:pointer);
-var @!q,@!r:pointer; {nodes in the parameter list}
-begin q:=get_avail; r:=get_avail; link(q):=r;@/
-info(q):=p; info(r):=stash_cur_exp;@/
-macro_call(c,q,n);
-end;
-
-@ The next procedure, |scan_tertiary|, is pretty much the same deal.
-
-@<Declare the basic parsing subroutines@>=
-procedure scan_tertiary;
-label restart,continue;
-var @!p:pointer; {for list manipulation}
-@!c,@!d:halfword; {operation codes or modifiers}
-@!mac_name:pointer; {token defined with \&{secondarydef}}
-begin restart:if(cur_cmd<min_primary_command)or@|
- (cur_cmd>max_primary_command) then
- bad_exp("A tertiary");
-@.A tertiary expression...@>
-scan_secondary;
-continue: if cur_cmd<=max_tertiary_command then
- if cur_cmd>=min_tertiary_command then
- begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd;
- if d=tertiary_secondary_macro then
- begin mac_name:=cur_sym; add_mac_ref(c);
- end;
- get_x_next; scan_secondary;
- if d<>tertiary_secondary_macro then do_binary(p,c)
- else begin back_input; binary_mac(p,c,mac_name);
- decr(ref_count(c)); get_x_next; goto restart;
- end;
- goto continue;
- end;
-end;
-
-@ 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@>=
-procedure scan_expression;
-label restart,done,continue,continue_path,finish_path,exit;
-var @!p,@!q,@!r,@!pp,@!qq:pointer; {for list manipulation}
-@!c,@!d:halfword; {operation codes or modifiers}
-@!my_var_flag:0..max_command_code; {initial value of |var_flag|}
-@!mac_name:pointer; {token defined with \&{tertiarydef}}
-@!cycle_hit:boolean; {did a path expression just end with `\&{cycle}'?}
-@!x,@!y:scaled; {explicit coordinates or tension at a path join}
-@!t:endpoint..open; {knot type following a path join}
-begin my_var_flag:=var_flag; t:=endpoint; x:=0; y:=0; mac_name:=null;
-restart:if(cur_cmd<min_primary_command)or@|
- (cur_cmd>max_primary_command) then
- bad_exp("An");
-@.An expression...@>
-scan_tertiary;
-continue: if cur_cmd<=max_expression_command then
- if cur_cmd>=min_expression_command then
- if (cur_cmd<>equals)or(my_var_flag<>assignment) then
- begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd;
- if d=expression_tertiary_macro then
- begin mac_name:=cur_sym; add_mac_ref(c);
- end;
- if (d<ampersand)or((d=ampersand)and@|
- ((type(p)=pair_type)or(type(p)=path_type))) then
- @<Scan a path construction operation;
- but |return| if |p| has the wrong type@>
- else begin get_x_next; scan_tertiary;
- if d<>expression_tertiary_macro then do_binary(p,c)
- else begin back_input; binary_mac(p,c,mac_name);
- decr(ref_count(c)); get_x_next; goto restart;
- end;
- end;
- goto continue;
- end;
-exit:end;
-
-@ 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...@>=
-begin 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 cur_cmd=cycle then @<Get ready to close a cycle@>
-else begin scan_tertiary;
- @<Convert the right operand, |cur_exp|,
- into a partial path from |pp| to~|qq|@>;
- end;
-@<Join the partial paths and reset |p| and |q| to the head and tail
- of the result@>;
-if cur_cmd>=min_expression_command then
- if cur_cmd<=ampersand then if not cycle_hit then goto continue_path;
-finish_path:
-@<Choose control points for the path and put the result into |cur_exp|@>;
-end
-
-@ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
-begin unstash_cur_exp(p);
-if cur_type=pair_type then p:=new_knot
-else if cur_type=path_type then p:=cur_exp
-else return;
-q:=p;
-while link(q)<>p do q:=link(q);
-if left_type(p)<>endpoint then {open up a cycle}
- begin r:=copy_knot(p); link(q):=r; q:=r;
- end;
-left_type(p):=open; right_type(q):=open;
-end
-
-@ 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.
-
-@p@t\4@>@<Declare the procedure called |known_pair|@>@;
-function new_knot:pointer; {convert a pair to a knot with two endpoints}
-var @!q:pointer; {the new node}
-begin q:=get_node(knot_node_size); left_type(q):=endpoint;
-right_type(q):=endpoint; originator(q):=metapost_user; link(q):=q;@/
-known_pair; x_coord(q):=cur_x; y_coord(q):=cur_y;
-new_knot:=q;
-end;
-
-@ 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|@>=
-procedure known_pair;
-var @!p:pointer; {the pair node}
-begin if cur_type<>pair_type then
- begin 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.)");
- put_get_flush_error(0); cur_x:=0; cur_y:=0;
- end
-else begin p:=value(cur_exp);
- @<Make sure that both |x| and |y| parts of |p| are known;
- copy them into |cur_x| and |cur_y|@>;
- flush_cur_exp(0);
- end;
-end;
-
-@ @<Make sure that both |x| and |y| parts of |p| are known...@>=
-if type(x_part_loc(p))=known then cur_x:=value(x_part_loc(p))
-else begin disp_err(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.)");
- put_get_error; recycle_value(x_part_loc(p)); cur_x:=0;
- end;
-if type(y_part_loc(p))=known then cur_y:=value(y_part_loc(p))
-else begin disp_err(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.)");
- put_get_error; recycle_value(y_part_loc(p)); cur_y:=0;
- end
-
-@ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
-
-@<Determine the path join parameters...@>=
-if cur_cmd=left_brace then
- @<Put the pre-join direction information into node |q|@>;
-d:=cur_cmd;
-if d=path_join then @<Determine the tension and/or control points@>
-else if d<>ampersand then goto finish_path;
-get_x_next;
-if cur_cmd=left_brace then
- @<Put the post-join direction information into |x| and |t|@>
-else if right_type(q)<>explicit then
- begin t:=open; x:=0;
- end
-
-@ 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.
-
-@p function scan_direction:small_number;
-var @!t:given..open; {the type of information found}
-@!x:scaled; {an |x| coordinate}
-begin get_x_next;
-if cur_cmd=curl_command then @<Scan a curl specification@>
-else @<Scan a given direction@>;
-if cur_cmd<>right_brace then
- begin missing_err("}");@/
-@.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.");@/
- back_error;
- end;
-get_x_next; scan_direction:=t;
-end;
-
-@ @<Scan a curl specification@>=
-begin get_x_next; scan_expression;
-if (cur_type<>known)or(cur_exp<0) then
- begin exp_err("Improper curl has been replaced by 1");
-@.Improper curl@>
- help1("A curl must be a known, nonnegative number.");
- put_get_flush_error(unity);
- end;
-t:=curl;
-end
-
-@ @<Scan a given direction@>=
-begin scan_expression;
-if cur_type>pair_type then @<Get given directions separated by commas@>
-else known_pair;
-if (cur_x=0)and(cur_y=0) then t:=open
-else begin t:=given; cur_exp:=n_arg(cur_x,cur_y);
- end;
-end
-
-@ @<Get given directions separated by commas@>=
-begin if cur_type<>known then
- begin 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.)");
- put_get_flush_error(0);
- end;
-x:=cur_exp;
-if cur_cmd<>comma then
- begin missing_err(",");@/
-@.Missing `,'@>
- help2("I've got the x coordinate of a path direction;")@/
- ("will look for the y coordinate next.");
- back_error;
- end;
-get_x_next; scan_expression;
-if cur_type<>known then
- begin 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.)");
- put_get_flush_error(0);
- end;
-cur_y:=cur_exp; cur_x:=x;
-end
-
-@ 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...@>=
-begin t:=scan_direction;
-if t<>open then
- begin right_type(q):=t; right_given(q):=cur_exp;
- if left_type(q)=open then
- begin left_type(q):=t; left_given(q):=cur_exp;
- end; {note that |left_given(q)=left_curl(q)|}
- end;
-end
-
-@ 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...@>=
-begin t:=scan_direction;
-if right_type(q)<>explicit then x:=cur_exp
-else t:=explicit; {the direction information is superfluous}
-end
-
-@ @<Determine the tension and/or...@>=
-begin get_x_next;
-if cur_cmd=tension then @<Set explicit tensions@>
-else if cur_cmd=controls then @<Set explicit control points@>
-else begin right_tension(q):=unity; y:=unity; back_input; {default tension}
- goto done;
- end;
-if cur_cmd<>path_join then
- begin missing_err("..");@/
-@.Missing `..'@>
- help1("A path join command should end with two dots.");
- back_error;
- end;
-done:end
-
-@ @<Set explicit tensions@>=
-begin get_x_next; y:=cur_cmd;
-if cur_cmd=at_least then get_x_next;
-scan_primary;
-@<Make sure that the current expression is a valid tension setting@>;
-if y=at_least then negate(cur_exp);
-right_tension(q):=cur_exp;
-if cur_cmd=and_command then
- begin get_x_next; y:=cur_cmd;
- if cur_cmd=at_least then get_x_next;
- scan_primary;
- @<Make sure that the current expression is a valid tension setting@>;
- if y=at_least then negate(cur_exp);
- end;
-y:=cur_exp;
-end
-
-@ @d min_tension==three_quarter_unit
-
-@<Make sure that the current expression is a valid tension setting@>=
-if (cur_type<>known)or(cur_exp<min_tension) then
- begin exp_err("Improper tension has been set to 1");
-@.Improper tension@>
- help1("The expression above should have been a number >=3/4.");
- put_get_flush_error(unity);
- end
-
-@ @<Set explicit control points@>=
-begin right_type(q):=explicit; t:=explicit; get_x_next; scan_primary;@/
-known_pair; right_x(q):=cur_x; right_y(q):=cur_y;
-if cur_cmd<>and_command then
- begin x:=right_x(q); y:=right_y(q);
- end
-else begin get_x_next; scan_primary;@/
- known_pair; x:=cur_x; y:=cur_y;
- end;
-end
-
-@ @<Convert the right operand, |cur_exp|, into a partial path...@>=
-begin if cur_type<>path_type then pp:=new_knot
-else pp:=cur_exp;
-qq:=pp;
-while link(qq)<>pp do qq:=link(qq);
-if left_type(pp)<>endpoint then {open up a cycle}
- begin r:=copy_knot(pp); link(qq):=r; qq:=r;
- end;
-left_type(pp):=open; right_type(qq):=open;
-end
-
-@ 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@>=
-begin cycle_hit:=true; get_x_next; pp:=p; qq:=p;
-if d=ampersand then if p=q then
- begin d:=path_join; right_tension(q):=unity; y:=unity;
- end;
-end
-
-@ @<Join the partial paths and reset |p| and |q|...@>=
-begin if d=ampersand then
- if (x_coord(q)<>x_coord(pp))or(y_coord(q)<>y_coord(pp)) then
- begin 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.");
- put_get_error; d:=path_join; right_tension(q):=unity; y:=unity;
- end;
-@<Plug an opening in |right_type(pp)|, if possible@>;
-if d=ampersand then @<Splice independent paths together@>
-else begin @<Plug an opening in |right_type(q)|, if possible@>;
- link(q):=pp; left_y(pp):=y;
- if t<>open then
- begin left_x(pp):=x; left_type(pp):=t;
- end;
- end;
-q:=qq;
-end
-
-@ @<Plug an opening in |right_type(q)|...@>=
-if right_type(q)=open then
- if (left_type(q)=curl)or(left_type(q)=given) then
- begin right_type(q):=left_type(q); right_given(q):=left_given(q);
- end
-
-@ @<Plug an opening in |right_type(pp)|...@>=
-if right_type(pp)=open then
- if (t=curl)or(t=given) then
- begin right_type(pp):=t; right_given(pp):=x;
- end
-
-@ @<Splice independent paths together@>=
-begin if left_type(q)=open then if right_type(q)=open then
- begin left_type(q):=curl; left_curl(q):=unity;
- end;
-if right_type(pp)=open then if t=open then
- begin right_type(pp):=curl; right_curl(pp):=unity;
- end;
-right_type(q):=right_type(pp); link(q):=link(pp);@/
-right_x(q):=right_x(pp); right_y(q):=right_y(pp);
-free_node(pp,knot_node_size);
-if qq=pp then qq:=q;
-end
-
-@ @<Choose control points for the path...@>=
-if cycle_hit then
- begin if d=ampersand then p:=q;
- end
-else begin left_type(p):=endpoint;
- if right_type(p)=open then
- begin right_type(p):=curl; right_curl(p):=unity;
- end;
- right_type(q):=endpoint;
- if left_type(q)=open then
- begin left_type(q):=curl; left_curl(q):=unity;
- end;
- link(q):=p;
- end;
-make_choices(p);
-cur_type:=path_type; 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@>=
-procedure get_boolean;
-begin get_x_next; scan_expression;
-if cur_type<>boolean_type then
- begin 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'.");@/
- put_get_flush_error(false_code); cur_type:=boolean_type;
- end;
-end;
-
-@* \[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...@>=
-primitive("true",nullary,true_code);@/
-@!@:true_}{\&{true} primitive@>
-primitive("false",nullary,false_code);@/
-@!@:false_}{\&{false} primitive@>
-primitive("nullpicture",nullary,null_picture_code);@/
-@!@:null_picture_}{\&{nullpicture} primitive@>
-primitive("nullpen",nullary,null_pen_code);@/
-@!@:null_pen_}{\&{nullpen} primitive@>
-primitive("jobname",nullary,job_name_op);@/
-@!@:job_name_}{\&{jobname} primitive@>
-primitive("readstring",nullary,read_string_op);@/
-@!@:read_string_}{\&{readstring} primitive@>
-primitive("pencircle",nullary,pen_circle);@/
-@!@:pen_circle_}{\&{pencircle} primitive@>
-primitive("normaldeviate",nullary,normal_deviate);@/
-@!@:normal_deviate_}{\&{normaldeviate} primitive@>
-primitive("readfrom",unary,read_from_op);@/
-@!@:read_from_}{\&{readfrom} primitive@>
-primitive("closefrom",unary,close_from_op);@/
-@!@:close_from_}{\&{closefrom} primitive@>
-primitive("odd",unary,odd_op);@/
-@!@:odd_}{\&{odd} primitive@>
-primitive("known",unary,known_op);@/
-@!@:known_}{\&{known} primitive@>
-primitive("unknown",unary,unknown_op);@/
-@!@:unknown_}{\&{unknown} primitive@>
-primitive("not",unary,not_op);@/
-@!@:not_}{\&{not} primitive@>
-primitive("decimal",unary,decimal);@/
-@!@:decimal_}{\&{decimal} primitive@>
-primitive("reverse",unary,reverse);@/
-@!@:reverse_}{\&{reverse} primitive@>
-primitive("makepath",unary,make_path_op);@/
-@!@:make_path_}{\&{makepath} primitive@>
-primitive("makepen",unary,make_pen_op);@/
-@!@:make_pen_}{\&{makepen} primitive@>
-primitive("oct",unary,oct_op);@/
-@!@:oct_}{\&{oct} primitive@>
-primitive("hex",unary,hex_op);@/
-@!@:hex_}{\&{hex} primitive@>
-primitive("ASCII",unary,ASCII_op);@/
-@!@:ASCII_}{\&{ASCII} primitive@>
-primitive("char",unary,char_op);@/
-@!@:char_}{\&{char} primitive@>
-primitive("length",unary,length_op);@/
-@!@:length_}{\&{length} primitive@>
-primitive("turningnumber",unary,turning_op);@/
-@!@:turning_number_}{\&{turningnumber} primitive@>
-primitive("xpart",unary,x_part);@/
-@!@:x_part_}{\&{xpart} primitive@>
-primitive("ypart",unary,y_part);@/
-@!@:y_part_}{\&{ypart} primitive@>
-primitive("xxpart",unary,xx_part);@/
-@!@:xx_part_}{\&{xxpart} primitive@>
-primitive("xypart",unary,xy_part);@/
-@!@:xy_part_}{\&{xypart} primitive@>
-primitive("yxpart",unary,yx_part);@/
-@!@:yx_part_}{\&{yxpart} primitive@>
-primitive("yypart",unary,yy_part);@/
-@!@:yy_part_}{\&{yypart} primitive@>
-primitive("redpart",unary,red_part);@/
-@!@:red_part_}{\&{redpart} primitive@>
-primitive("greenpart",unary,green_part);@/
-@!@:green_part_}{\&{greenpart} primitive@>
-primitive("bluepart",unary,blue_part);@/
-@!@:blue_part_}{\&{bluepart} primitive@>
-primitive("cyanpart",unary,cyan_part);@/
-@!@:cyan_part_}{\&{cyanpart} primitive@>
-primitive("magentapart",unary,magenta_part);@/
-@!@:magenta_part_}{\&{magentapart} primitive@>
-primitive("yellowpart",unary,yellow_part);@/
-@!@:yellow_part_}{\&{yellowpart} primitive@>
-primitive("blackpart",unary,black_part);@/
-@!@:black_part_}{\&{blackpart} primitive@>
-primitive("greypart",unary,grey_part);@/
-@!@:grey_part_}{\&{greypart} primitive@>
-primitive("colormodel",unary,color_model_part);@/
-@!@:color_model_part_}{\&{colormodel} primitive@>
-primitive("fontpart",unary,font_part);@/
-@!@:font_part_}{\&{fontpart} primitive@>
-primitive("textpart",unary,text_part);@/
-@!@:text_part_}{\&{textpart} primitive@>
-primitive("pathpart",unary,path_part);@/
-@!@:path_part_}{\&{pathpart} primitive@>
-primitive("penpart",unary,pen_part);@/
-@!@:pen_part_}{\&{penpart} primitive@>
-primitive("dashpart",unary,dash_part);@/
-@!@:dash_part_}{\&{dashpart} primitive@>
-primitive("sqrt",unary,sqrt_op);@/
-@!@:sqrt_}{\&{sqrt} primitive@>
-primitive("mexp",unary,m_exp_op);@/
-@!@:m_exp_}{\&{mexp} primitive@>
-primitive("mlog",unary,m_log_op);@/
-@!@:m_log_}{\&{mlog} primitive@>
-primitive("sind",unary,sin_d_op);@/
-@!@:sin_d_}{\&{sind} primitive@>
-primitive("cosd",unary,cos_d_op);@/
-@!@:cos_d_}{\&{cosd} primitive@>
-primitive("floor",unary,floor_op);@/
-@!@:floor_}{\&{floor} primitive@>
-primitive("uniformdeviate",unary,uniform_deviate);@/
-@!@:uniform_deviate_}{\&{uniformdeviate} primitive@>
-primitive("charexists",unary,char_exists_op);@/
-@!@:char_exists_}{\&{charexists} primitive@>
-primitive("fontsize",unary,font_size);@/
-@!@:font_size_}{\&{fontsize} primitive@>
-primitive("llcorner",unary,ll_corner_op);@/
-@!@:ll_corner_}{\&{llcorner} primitive@>
-primitive("lrcorner",unary,lr_corner_op);@/
-@!@:lr_corner_}{\&{lrcorner} primitive@>
-primitive("ulcorner",unary,ul_corner_op);@/
-@!@:ul_corner_}{\&{ulcorner} primitive@>
-primitive("urcorner",unary,ur_corner_op);@/
-@!@:ur_corner_}{\&{urcorner} primitive@>
-primitive("arclength",unary,arc_length);@/
-@!@:arc_length_}{\&{arclength} primitive@>
-primitive("angle",unary,angle_op);@/
-@!@:angle_}{\&{angle} primitive@>
-primitive("cycle",cycle,cycle_op);@/
-@!@:cycle_}{\&{cycle} primitive@>
-primitive("stroked",unary,stroked_op);@/
-@!@:stroked_}{\&{stroked} primitive@>
-primitive("filled",unary,filled_op);@/
-@!@:filled_}{\&{filled} primitive@>
-primitive("textual",unary,textual_op);@/
-@!@:textual_}{\&{textual} primitive@>
-primitive("clipped",unary,clipped_op);@/
-@!@:clipped_}{\&{clipped} primitive@>
-primitive("bounded",unary,bounded_op);@/
-@!@:bounded_}{\&{bounded} primitive@>
-primitive("+",plus_or_minus,plus);@/
-@!@:+ }{\.{+} primitive@>
-primitive("-",plus_or_minus,minus);@/
-@!@:- }{\.{-} primitive@>
-primitive("*",secondary_binary,times);@/
-@!@:* }{\.{*} primitive@>
-primitive("/",slash,over); eqtb[frozen_slash]:=eqtb[cur_sym];@/
-@!@:/ }{\.{/} primitive@>
-primitive("++",tertiary_binary,pythag_add);@/
-@!@:++_}{\.{++} primitive@>
-primitive("+-+",tertiary_binary,pythag_sub);@/
-@!@:+-+_}{\.{+-+} primitive@>
-primitive("or",tertiary_binary,or_op);@/
-@!@:or_}{\&{or} primitive@>
-primitive("and",and_command,and_op);@/
-@!@:and_}{\&{and} primitive@>
-primitive("<",expression_binary,less_than);@/
-@!@:< }{\.{<} primitive@>
-primitive("<=",expression_binary,less_or_equal);@/
-@!@:<=_}{\.{<=} primitive@>
-primitive(">",expression_binary,greater_than);@/
-@!@:> }{\.{>} primitive@>
-primitive(">=",expression_binary,greater_or_equal);@/
-@!@:>=_}{\.{>=} primitive@>
-primitive("=",equals,equal_to);@/
-@!@:= }{\.{=} primitive@>
-primitive("<>",expression_binary,unequal_to);@/
-@!@:<>_}{\.{<>} primitive@>
-primitive("substring",primary_binary,substring_of);@/
-@!@:substring_}{\&{substring} primitive@>
-primitive("subpath",primary_binary,subpath_of);@/
-@!@:subpath_}{\&{subpath} primitive@>
-primitive("directiontime",primary_binary,direction_time_of);@/
-@!@:direction_time_}{\&{directiontime} primitive@>
-primitive("point",primary_binary,point_of);@/
-@!@:point_}{\&{point} primitive@>
-primitive("precontrol",primary_binary,precontrol_of);@/
-@!@:precontrol_}{\&{precontrol} primitive@>
-primitive("postcontrol",primary_binary,postcontrol_of);@/
-@!@:postcontrol_}{\&{postcontrol} primitive@>
-primitive("penoffset",primary_binary,pen_offset_of);@/
-@!@:pen_offset_}{\&{penoffset} primitive@>
-primitive("arctime",primary_binary,arc_time_of);@/
-@!@:arc_time_of_}{\&{arctime} primitive@>
-primitive("mpversion",nullary,mp_version);@/
-@!@:mp_verison_}{\&{mpversion} primitive@>
-primitive("&",ampersand,concatenate);@/
-@!@:!!!}{\.{\&} primitive@>
-primitive("rotated",secondary_binary,rotated_by);@/
-@!@:rotated_}{\&{rotated} primitive@>
-primitive("slanted",secondary_binary,slanted_by);@/
-@!@:slanted_}{\&{slanted} primitive@>
-primitive("scaled",secondary_binary,scaled_by);@/
-@!@:scaled_}{\&{scaled} primitive@>
-primitive("shifted",secondary_binary,shifted_by);@/
-@!@:shifted_}{\&{shifted} primitive@>
-primitive("transformed",secondary_binary,transformed_by);@/
-@!@:transformed_}{\&{transformed} primitive@>
-primitive("xscaled",secondary_binary,x_scaled);@/
-@!@:x_scaled_}{\&{xscaled} primitive@>
-primitive("yscaled",secondary_binary,y_scaled);@/
-@!@:y_scaled_}{\&{yscaled} primitive@>
-primitive("zscaled",secondary_binary,z_scaled);@/
-@!@:z_scaled_}{\&{zscaled} primitive@>
-primitive("infont",secondary_binary,in_font);@/
-@!@:in_font_}{\&{infont} primitive@>
-primitive("intersectiontimes",tertiary_binary,intersect);@/
-@!@:intersection_times_}{\&{intersectiontimes} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-nullary,unary,primary_binary,secondary_binary,tertiary_binary,
- expression_binary,cycle,plus_or_minus,slash,ampersand,equals,and_command:
- print_op(m);
-
-@ OK, let's look at the simplest \\{do} procedure first.
-
-@p @t\4@>@<Declare nullary action procedure@>@;
-procedure do_nullary(@!c:quarterword);
-begin check_arith;
-if internal[tracing_commands]>two then
- show_cmd_mod(nullary,c);
-case c of
-true_code,false_code:begin cur_type:=boolean_type; cur_exp:=c;
- end;
-null_picture_code:begin cur_type:=picture_type;
- cur_exp:=get_node(edge_header_size); init_edges(cur_exp);
- end;
-null_pen_code:begin cur_type:=pen_type; cur_exp:=get_pen_circle(0);
- end;
-normal_deviate:begin cur_type:=known; cur_exp:=norm_rand;
- end;
-pen_circle:begin cur_type:=pen_type; cur_exp:=get_pen_circle(unity);
- end;
-job_name_op: begin if job_name=0 then open_log_file;
- cur_type:=string_type; cur_exp:=job_name;
- end;
-mp_version: begin cur_type:=string_type; cur_exp:=metapost_version; end;
-read_string_op:@<Read a string from the terminal@>;
-end; {there are no other cases}
-check_arith;
-end;
-
-@ @<Read a string...@>=
-begin if interaction<=nonstop_mode then
- fatal_error("*** (cannot readstring in nonstop modes)");
-begin_file_reading; name:=is_read;
-limit:=start; prompt_input("");
-finish_read;
-end
-
-@ @<Declare nullary action procedure@>=
-procedure finish_read; {copy |buffer| line to |cur_exp|}
-var @!k:pool_pointer;
-begin str_room(last-start);
-for k:=start to last-1 do append_char(buffer[k]);
-end_file_reading; cur_type:=string_type; cur_exp:=make_string;
-end;
-
-@ Things get a bit more interesting when there's an operand. The
-operand to |do_unary| appears in |cur_type| and |cur_exp|.
-
-@p @t\4@>@<Declare unary action procedures@>@;
-procedure do_unary(@!c:quarterword);
-var @!p,@!q,@!r:pointer; {for list manipulation}
-@!x:integer; {a temporary register}
-begin check_arith;
-if internal[tracing_commands]>two then
- @<Trace the current unary operation@>;
-case c of
-plus:if cur_type<color_type then bad_unary(plus);
-minus:@<Negate the current expression@>;
-@t\4@>@<Additional cases of unary operators@>@;
-end; {there are no other cases}
-check_arith;
-end;
-
-@ The |nice_pair| function returns |true| if both components of a pair
-are known.
-
-@<Declare unary action procedures@>=
-function nice_pair(@!p:integer;@!t:quarterword):boolean;
-label exit;
-begin if t=pair_type then
- begin p:=value(p);
- if type(x_part_loc(p))=known then
- if type(y_part_loc(p))=known then
- begin nice_pair:=true; return;
- end;
- end;
-nice_pair:=false;
-exit:end;
-
-@ The |nice_color_or_pair| function is analogous except that it also accepts
-fully known colors.
-
-@<Declare unary action procedures@>=
-function nice_color_or_pair(@!p:integer;@!t:quarterword):boolean;
-label exit;
-var @!q,@!r:pointer; {for scanning the big node}
-begin if (t<>pair_type)and(t<>color_type)and(t<>cmykcolor_type) then
- nice_color_or_pair:=false
-else begin q:=value(p);
- r:=q+big_node_size[type(p)];
- repeat r:=r-2;
- if type(r)<>known then
- begin nice_color_or_pair:=false; return;
- end;
- until r=q;
- nice_color_or_pair:=true;
- end;
-exit:end;
-
-@ @<Declare unary action...@>=
-procedure print_known_or_unknown_type(@!t:small_number;@!v:integer);
-begin print_char("(");
-if t>known then print("unknown numeric")
-else begin if (t=pair_type)or(t=color_type)or(t=cmykcolor_type) then
- if not nice_color_or_pair(v,t) then print("unknown ");
- print_type(t);
- end;
-print_char(")");
-end;
-
-@ @<Declare unary action...@>=
-procedure bad_unary(@!c:quarterword);
-begin exp_err("Not implemented: "); print_op(c);
-@.Not implemented...@>
-print_known_or_unknown_type(cur_type,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.");
-put_get_error;
-end;
-
-@ @<Trace the current unary operation@>=
-begin begin_diagnostic; print_nl("{"); print_op(c); print_char("(");@/
-print_exp(null,0); {show the operand, but not verbosely}
-print(")}"); end_diagnostic(false);
-end
-
-@ 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@>=
-case cur_type of
-color_type,cmykcolor_type,pair_type,independent: begin
- q:=cur_exp; make_exp_copy(q);
- if cur_type=dependent then negate_dep_list(dep_list(cur_exp))
- else if cur_type<=pair_type then {|color_type| or |pair_type|}
- begin p:=value(cur_exp);
- r:=p+big_node_size[cur_type];
- repeat r:=r-2;
- if type(r)=known then negate(value(r))
- else negate_dep_list(dep_list(r));
- until r=p;
- end; {if |cur_type=known| then |cur_exp=0|}
- recycle_value(q); free_node(q,value_node_size);
- end;
-dependent,proto_dependent:negate_dep_list(dep_list(cur_exp));
-known:negate(cur_exp);
-othercases bad_unary(minus)
-endcases
-
-@ @<Declare unary action...@>=
-procedure negate_dep_list(@!p:pointer);
-label exit;
-begin loop@+begin negate(value(p));
- if info(p)=null then return;
- p:=link(p);
- end;
-exit:end;
-
-@ @<Additional cases of unary operators@>=
-not_op: if cur_type<>boolean_type then bad_unary(not_op)
- else cur_exp:=true_code+false_code-cur_exp;
-
-@ @d three_sixty_units==23592960 {that's |360*unity|}
-@d boolean_reset(#)==if # then cur_exp:=true_code@+else cur_exp:=false_code
-
-@<Additional cases of unary operators@>=
-sqrt_op,m_exp_op,m_log_op,sin_d_op,cos_d_op,floor_op,
- uniform_deviate,odd_op,char_exists_op:@t@>@;@/
- if cur_type<>known then bad_unary(c)
- else case c of
- sqrt_op:cur_exp:=square_rt(cur_exp);
- m_exp_op:cur_exp:=m_exp(cur_exp);
- m_log_op:cur_exp:=m_log(cur_exp);
- sin_d_op,cos_d_op:begin n_sin_cos((cur_exp mod three_sixty_units)*16);
- if c=sin_d_op then cur_exp:=round_fraction(n_sin)
- else cur_exp:=round_fraction(n_cos);
- end;
- floor_op:cur_exp:=floor_scaled(cur_exp);
- uniform_deviate:cur_exp:=unif_rand(cur_exp);
- odd_op: begin boolean_reset(odd(round_unscaled(cur_exp)));
- cur_type:=boolean_type;
- end;
- char_exists_op:@<Determine if a character has been shipped out@>;
- end; {there are no other cases}
-
-@ @<Additional cases of unary operators@>=
-angle_op:if nice_pair(cur_exp,cur_type) then
- begin p:=value(cur_exp);
- x:=n_arg(value(x_part_loc(p)),value(y_part_loc(p)));
- if x>=0 then flush_cur_exp((x+8)div 16)
- else flush_cur_exp(-((-x+8)div 16));
- end
- else bad_unary(angle_op);
-
-@ If the current expression is a pair, but the context wants it to
-be a path, we call |pair_to_path|.
-
-@<Declare unary action...@>=
-procedure pair_to_path;
-begin cur_exp:=new_knot; cur_type:=path_type;
-end;
-
-@
-@d pict_color_type(#)==(link(dummy_loc(cur_exp))<>null) and
- (has_color(link(dummy_loc(cur_exp)))) and
- ((color_model(link(dummy_loc(cur_exp)))=#)
- or
- (color_model(link(dummy_loc(cur_exp)))=uninitialized_model) and
- ((internal[default_color_model] div unity)=#))
-
-@<Additional cases of unary operators@>=
-x_part,y_part:if (cur_type=pair_type)or(cur_type=transform_type) then
- take_part(c)
- else if cur_type=picture_type then take_pict_part(c)
- else bad_unary(c);
-xx_part,xy_part,yx_part,yy_part: if cur_type=transform_type then take_part(c)
- else if cur_type=picture_type then take_pict_part(c)
- else bad_unary(c);
-red_part,green_part,blue_part:
- if cur_type=color_type then take_part(c)
- else if cur_type=picture_type then begin
- if pict_color_type(rgb_model) then take_pict_part(c) else bad_color_part(c);
- end else bad_unary(c);
-cyan_part,magenta_part,yellow_part,black_part:
- if cur_type=cmykcolor_type then take_part(c)
- else if cur_type=picture_type then begin
- if pict_color_type(cmyk_model) then take_pict_part(c) else bad_color_part(c);
- end else bad_unary(c);
-grey_part: if cur_type=known then cur_exp:=value(c)
- else if cur_type=picture_type then begin
- if pict_color_type(grey_model) then take_pict_part(c) else bad_color_part(c);
- end else bad_unary(c);
-color_model_part: if cur_type=picture_type then take_pict_part(c)
- else bad_unary(c);
-
-@ 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...@>=
-procedure take_part(@!c:quarterword);
-var @!p:pointer; {the big node}
-begin p:=value(cur_exp); value(temp_val):=p; type(temp_val):=cur_type;
-link(p):=temp_val; free_node(cur_exp,value_node_size);
-make_exp_copy(p+sector_offset[c+x_part_sector-x_part]);
-recycle_value(temp_val);
-end;
-
-@ The manual states that asking for the \&{redpart} of a non-colored object
-is legal, so no error is given in that case.
-
-@<Declare unary action...@>=
-procedure bad_color_part(@!c:quarterword);
-var @!p:pointer; {the big node}
-begin
- p:=link(dummy_loc(cur_exp));
- if has_color(p) then begin
- exp_err("Wrong picture color model: "); print_op(c);
-@.Wrong picture color model...@>
- if color_model(p)=grey_model then
- print(" of grey object")
- else if color_model(p)=cmyk_model then
- print(" of cmyk object")
- else if color_model(p)=rgb_model then
- print(" of rgb object")
- else if color_model(p)=no_model then
- print(" of marking object")
- else
- print(" 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.");
- error;
- end;
- if c=black_part then
- flush_cur_exp(unity)
- else
- flush_cur_exp(0);
-end;
-
-@ @<Initialize table entries...@>=
-name_type(temp_val):=capsule;
-
-@ @<Additional cases of unary operators@>=
-font_part,text_part,path_part,pen_part,dash_part:
- if cur_type=picture_type then take_pict_part(c)
- else bad_unary(c);
-
-@ @<Declare unary action...@>=
-procedure@?scale_edges; forward;@t\2@>@;@/
-procedure take_pict_part(@!c:quarterword);
-label exit, not_found;
-var @!p:pointer; {first graphical object in |cur_exp|}
-begin p:=link(dummy_loc(cur_exp));
-if p<>null then
- begin case c of
- x_part,y_part,xx_part,xy_part,yx_part,yy_part:
- if type(p)=text_code then flush_cur_exp(text_trans_part(p+c))
- else goto not_found;
- red_part,green_part,blue_part:
- if has_color(p) then flush_cur_exp(obj_color_part(p+c))
- else goto not_found;
- cyan_part,magenta_part,yellow_part,black_part:
- if has_color(p) then
- if (color_model(p)=uninitialized_model)and(c=black_part) then
- flush_cur_exp(unity)
- else
- flush_cur_exp(obj_color_part(p+c+(red_part-cyan_part)))
- else goto not_found;
- grey_part:
- if has_color(p) then
- flush_cur_exp(obj_color_part(p+c+(red_part-grey_part)))
- else goto not_found;
- color_model_part:
- if has_color(p) then
- if color_model(p)=uninitialized_model then
- flush_cur_exp(internal[default_color_model])
- else
- flush_cur_exp(color_model(p)*unity)
- else goto not_found;
- @<Handle other cases in |take_pict_part| or |goto not_found|@>@;
- end; {all cases have been enumerated}
- return;
- end;
-not_found:@<Convert the current expression to a null value appropriate
- for |c|@>;
-exit:end;
-
-@ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
-text_part: if type(p)<>text_code then goto not_found
- else begin flush_cur_exp(text_p(p));
- add_str_ref(cur_exp);
- cur_type:=string_type;
- end;
-font_part: if type(p)<>text_code then goto not_found
- else begin flush_cur_exp(font_name[font_n(p)]);
- add_str_ref(cur_exp);
- cur_type:=string_type;
- end;
-path_part:if type(p)=text_code then goto not_found
- else if is_stop(p) then confusion("pict")
-@:this can't happen pict}{\quad pict@>
- else begin flush_cur_exp(copy_path(path_p(p)));
- cur_type:=path_type;
- end;
-pen_part: if not has_pen(p) then goto not_found
- else if pen_p(p)=null then goto not_found
- else begin flush_cur_exp(copy_pen(pen_p(p)));
- cur_type:=pen_type;
- end;
-dash_part: if type(p)<>stroked_code then goto not_found
- else if dash_p(p)=null then goto not_found
- else begin add_edge_ref(dash_p(p));@/
- se_sf:=dash_scale(p);
- se_pic:=dash_p(p);
- scale_edges;
- flush_cur_exp(se_pic);
- cur_type:=picture_type;
- end;
-
-@ 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...@>=
-@!se_pic:pointer; {edge header used and updated by |scale_edges|}
-@!se_sf:scaled; {the scale factor argument to |scale_edges|}
-
-@ @<Convert the current expression to a null value appropriate...@>=
-case c of
-text_part,font_part: begin flush_cur_exp("");
- cur_type:=string_type;
- end;
-path_part: begin flush_cur_exp(get_node(knot_node_size));
- left_type(cur_exp):=endpoint;
- right_type(cur_exp):=endpoint;
- link(cur_exp):=cur_exp;
- x_coord(cur_exp):=0;
- y_coord(cur_exp):=0;
- originator(cur_exp):=metapost_user;
- cur_type:=path_type;
- end;
-pen_part: begin flush_cur_exp(get_pen_circle(0));
- cur_type:=pen_type;
- end;
-dash_part: begin flush_cur_exp(get_node(edge_header_size));
- init_edges(cur_exp);
- cur_type:=picture_type;
- end;
-othercases flush_cur_exp(0)
-endcases
-
-@ @<Additional cases of unary...@>=
-char_op: if cur_type<>known then bad_unary(char_op)
- else begin cur_exp:=round_unscaled(cur_exp) mod 256; cur_type:=string_type;
- if cur_exp<0 then cur_exp:=cur_exp+256;
- end;
-decimal: if cur_type<>known then bad_unary(decimal)
- else begin old_setting:=selector; selector:=new_string;
- print_scaled(cur_exp); cur_exp:=make_string;
- selector:=old_setting; cur_type:=string_type;
- end;
-oct_op,hex_op,ASCII_op: if cur_type<>string_type then bad_unary(c)
- else str_to_num(c);
-font_size: if cur_type<>string_type then bad_unary(font_size)
- else @<Find the design size of the font whose name is |cur_exp|@>;
-
-@ @<Declare unary action...@>=
-procedure str_to_num(@!c:quarterword); {converts a string to a number}
-var @!n:integer; {accumulator}
-@!m:ASCII_code; {current character}
-@!k:pool_pointer; {index into |str_pool|}
-@!b:8..16; {radix of conversion}
-@!bad_char:boolean; {did the string contain an invalid digit?}
-begin if c=ASCII_op then
- if length(cur_exp)=0 then n:=-1
- else n:=so(str_pool[str_start[cur_exp]])
-else begin if c=oct_op then b:=8@+else b:=16;
- n:=0; bad_char:=false;
- for k:=str_start[cur_exp] to str_stop(cur_exp)-1 do
- begin m:=so(str_pool[k]);
- if (m>="0")and(m<="9") then m:=m-"0"
- else if (m>="A")and(m<="F") then m:=m-"A"+10
- else if (m>="a")and(m<="f") then m:=m-"a"+10
- else begin bad_char:=true; m:=0;
- end;
- if m>=b then
- begin bad_char:=true; m:=0;
- end;
- if n<32768 div b then n:=n*b+m@+else n:=32767;
- end;
- @<Give error messages if |bad_char| or |n>=4096|@>;
- end;
-flush_cur_exp(n*unity);
-end;
-
-@ @<Give error messages if |bad_char|...@>=
-if bad_char then
- begin exp_err("String contains illegal digits");
-@.String contains illegal digits@>
- if c=oct_op then
- help1("I zeroed out characters that weren't in the range 0..7.")
- else help1("I zeroed out characters that weren't hex digits.");
- put_get_error;
- end;
-if (n>4095) then
- if internal[warning_check]>0 then
- begin print_err("Number too large ("); print_int(n); print_char(")");
-@.Number too large@>
- help2("I have trouble with numbers greater than 4095; watch out.")@/
- ("(Set warningcheck:=0 to suppress this message.)");
- put_get_error;
- end
-
-@ The length operation is somewhat unusual in that it applies to a variety
-of different types of operands.
-
-@<Additional cases of unary...@>=
-length_op: case cur_type of
- string_type: flush_cur_exp(length(cur_exp)*unity);
- path_type: flush_cur_exp(path_length);
- known: cur_exp:=abs(cur_exp);
- picture_type: flush_cur_exp(pict_length);
- othercases if nice_pair(cur_exp,cur_type) then
- flush_cur_exp(pyth_add(value(x_part_loc(value(cur_exp))),@|
- value(y_part_loc(value(cur_exp)))))
- else bad_unary(c)
- endcases;
-
-@ @<Declare unary action...@>=
-function path_length:scaled; {computes the length of the current path}
-var @!n:scaled; {the path length so far}
-@!p:pointer; {traverser}
-begin p:=cur_exp;
-if left_type(p)=endpoint then n:=-unity@+else n:=0;
-repeat p:=link(p); n:=n+unity;
-until p=cur_exp;
-path_length:=n;
-end;
-
-@ @<Declare unary action...@>=
-function pict_length:scaled; {counts interior components in picture |cur_exp|}
-label found;
-var @!n:scaled; {the count so far}
-@!p:pointer; {traverser}
-begin n:=0;
-p:=link(dummy_loc(cur_exp));
-if p<>null then
- begin if is_start_or_stop(p) then
- if skip_1component(p)=null then p:=link(p);
- while p<>null do
- begin skip_component(p)(goto found);
- n:=n+unity;
- end;
- end;
-found:pict_length:=n;
-end;
-
-@ Implement |turningnumber|
-
-@<Additional cases of unary...@>=
-turning_op:if cur_type=pair_type then flush_cur_exp(0)
- else if cur_type<>path_type then bad_unary(turning_op)
- else if left_type(cur_exp)=endpoint then
- flush_cur_exp(0) {not a cyclic path}
- else begin
- flush_cur_exp(turn_cycles_wrapper(cur_exp));
- end;
-
-@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
-argument is |origin|.
-
-@<Declare unary action...@>=
-function an_angle (@!xpar,@!ypar:scaled):angle;
-begin
- if (not ((xpar=0) and (ypar=0))) then
- an_angle := n_arg(xpar,ypar)
- else
- an_angle := 0;
-end;
-
-@ 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 p_nextnext==link(link(p))
-@d p_next==link(p)
-
-@d seven_twenty_deg==@'5500000000 {$720\cdot2^{20}$, represents $720^\circ$}
-
-@<Declare unary action...@>=
-function new_turn_cycles (@!c:pointer):scaled;
-label exit;
-var @!res,ang:angle; { the angles of intermediate results }
-@!turns:scaled; { the turn counter }
-@!p:pointer; { for running around the path }
-@!xp,yp:integer; { coordinates of next point }
-@!x,y:integer; { helper coordinates }
-@!in_angle,out_angle:angle; { helper angles}
-@!old_setting:0..max_selector; {saved |selector| setting}
-begin
-res:=0;
-turns:= 0;
-p:=c;
-old_setting := selector; selector:=term_only;
-if internal[tracing_commands]>unity then begin
- begin_diagnostic;
- print_nl("");
- end_diagnostic(false);
-end;
-repeat
- xp := x_coord(p_next); yp := y_coord(p_next);
- ang := bezier_slope(x_coord(p), y_coord(p), right_x(p), right_y(p),
- left_x(p_next), left_y(p_next), xp, yp, internal[tracing_commands]);
- if ang>seven_twenty_deg then begin
- print_err("Strange path");
- error;
- new_turn_cycles := 0;
- return;
- end;
- res := res + ang;
- if res > one_eighty_deg then begin
- res := res - three_sixty_deg;
- turns := turns + unity;
- end;
- if res <= -one_eighty_deg then begin
- res := res + three_sixty_deg;
- turns := turns - unity;
- end;
- { incoming angle at next point }
- x := left_x(p_next); y := left_y(p_next);
- if (xp=x)and(yp=y) then begin x := right_x(p); y := right_y(p); end;
- if (xp=x)and(yp=y) then begin x := x_coord(p); y := y_coord(p); end;
- in_angle := an_angle(xp - x, yp - y);
- { outgoing angle at next point }
- x := right_x(p_next); y := right_y(p_next);
- if (xp=x)and(yp=y) then begin x := left_x(p_nextnext); y := left_y(p_nextnext); end;
- if (xp=x)and(yp=y) then begin x := x_coord(p_nextnext); y := y_coord(p_nextnext); end;
- out_angle := an_angle(x - xp, y- yp);
- ang := (out_angle - in_angle);
- reduce_angle(ang);
- if ang<>0 then begin
- res := res + ang;
- if res >= one_eighty_deg then begin
- res := res - three_sixty_deg;
- turns := turns + unity;
- end;
- if res <= -one_eighty_deg then begin
- res := res + three_sixty_deg;
- turns := turns - unity;
- end;
- end;
- p := link(p);
-until p=c;
-new_turn_cycles := turns;
-exit:
-selector:=old_setting;
-end;
-
-
-@ 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...@>=
-function turn_cycles (@!c:pointer):scaled;
-var @!res,ang:angle; { the angles of intermediate results }
-@!turns:scaled; { the turn counter }
-@!p:pointer; { for running around the path }
-begin res:=0; turns:= 0; p:=c;
-repeat
- ang := an_angle (x_coord(p_to) - x_coord(p_here), y_coord(p_to) - y_coord(p_here))
- - an_angle (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 then begin
- res := res - three_sixty_deg;
- turns := turns + unity;
- end;
- if res <= -three_sixty_deg then begin
- res := res + three_sixty_deg;
- turns := turns - unity;
- end;
- p := link(p);
-until p=c;
-turn_cycles := turns;
-end;
-
-@ @<Declare unary action...@>=
-function turn_cycles_wrapper (@!c:pointer):scaled;
- var nval,oval:scaled;
- saved_t_o:scaled; {tracing\_online saved }
-begin
- if (link(c)=c)or(link(link(c))=c) then
- if an_angle (x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 then
- turn_cycles_wrapper := unity
- else
- turn_cycles_wrapper := -unity
- else begin
- nval := new_turn_cycles(c);
- oval := turn_cycles(c);
- if nval<>oval then begin
- saved_t_o:=internal[tracing_online];
- internal[tracing_online]:=unity;
- begin_diagnostic;
- print_nl ("Warning: the turningnumber algorithms do not agree. The current computed value is ");
- print_scaled(nval);
- print(", but the 'connect-the-dots' algorithm returned ");
- print_scaled(oval);
- end_diagnostic(false);
- internal[tracing_online]:=saved_t_o;
- end;
- turn_cycles_wrapper := nval;
- end;
-end;
-
-@ @<Declare unary action...@>=
-function count_turns(@!c:pointer):scaled;
-var @!p:pointer; {a knot in envelope spec |c|}
-@!t:integer; {total pen offset changes counted}
-begin t:=0; p:=c;
-repeat t:=t+info(p)-zero_off;
-p:=link(p);
-until p=c;
-count_turns:=(t div 3)*unity;
-end;
-
-@ @d type_test_end== flush_cur_exp(true_code)
- else flush_cur_exp(false_code);
- cur_type:=boolean_type;
- end
-@d type_range_end(#)==(cur_type<=#) then type_test_end
-@d type_range(#)==begin if (cur_type>=#) and type_range_end
-@d type_test(#)==begin if cur_type=# then type_test_end
-
-@<Additional cases of unary operators@>=
-boolean_type: type_range(boolean_type)(unknown_boolean);
-string_type: type_range(string_type)(unknown_string);
-pen_type: type_range(pen_type)(unknown_pen);
-path_type: type_range(path_type)(unknown_path);
-picture_type: type_range(picture_type)(unknown_picture);
-transform_type,color_type,cmykcolor_type,pair_type: type_test(c);
-numeric_type: type_range(known)(independent);
-known_op,unknown_op: test_known(c);
-
-@ @<Declare unary action procedures@>=
-procedure test_known(@!c:quarterword);
-label done;
-var @!b:true_code..false_code; {is the current expression known?}
-@!p,@!q:pointer; {locations in a big node}
-begin b:=false_code;
-case cur_type of
-vacuous,boolean_type,string_type,pen_type,path_type,picture_type,
- known: b:=true_code;
-transform_type,color_type,cmykcolor_type,pair_type:begin p:=value(cur_exp);
- q:=p+big_node_size[cur_type];
- repeat q:=q-2;
- if type(q)<>known then goto done;
- until q=p;
- b:=true_code;
-done: end;
-othercases do_nothing
-endcases;
-if c=known_op then flush_cur_exp(b)
-else flush_cur_exp(true_code+false_code-b);
-cur_type:=boolean_type;
-end;
-
-@ @<Additional cases of unary operators@>=
-cycle_op: begin if cur_type<>path_type then flush_cur_exp(false_code)
- else if left_type(cur_exp)<>endpoint then flush_cur_exp(true_code)
- else flush_cur_exp(false_code);
- cur_type:=boolean_type;
- end;
-
-@ @<Additional cases of unary operators@>=
-arc_length: begin if cur_type=pair_type then pair_to_path;
- if cur_type<>path_type then bad_unary(arc_length)
- else flush_cur_exp(get_arc_length(cur_exp));
- end;
-
-@ 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@>=
-filled_op,stroked_op,textual_op,clipped_op,bounded_op:
- begin if cur_type<>picture_type then flush_cur_exp(false_code)
- else if link(dummy_loc(cur_exp))=null then flush_cur_exp(false_code)
- else if type(link(dummy_loc(cur_exp)))=c+fill_code-filled_op then
- flush_cur_exp(true_code)
- else flush_cur_exp(false_code);
- cur_type:=boolean_type;
- end;
-
-@ @<Additional cases of unary operators@>=
-make_pen_op: begin if cur_type=pair_type then pair_to_path;
- if cur_type<>path_type then bad_unary(make_pen_op)
- else begin cur_type:=pen_type;
- cur_exp:=make_pen(cur_exp,true);
- end;
- end;
-make_path_op: if cur_type<>pen_type then bad_unary(make_path_op)
- else begin cur_type:=path_type;
- make_path(cur_exp);
- end;
-reverse: if cur_type=path_type then
- begin p:=htap_ypoc(cur_exp);
- if right_type(p)=endpoint then p:=link(p);
- toss_knot_list(cur_exp); cur_exp:=p;
- end
- else if cur_type=pair_type then pair_to_path
- else bad_unary(reverse);
-
-@ The |pair_value| routine changes the current expression to a
-given ordered pair of values.
-
-@<Declare unary action procedures@>=
-procedure pair_value(@!x,@!y:scaled);
-var @!p:pointer; {a pair node}
-begin p:=get_node(value_node_size); flush_cur_exp(p); cur_type:=pair_type;
-type(p):=pair_type; name_type(p):=capsule; init_big_node(p);
-p:=value(p);@/
-type(x_part_loc(p)):=known; value(x_part_loc(p)):=x;@/
-type(y_part_loc(p)):=known; value(y_part_loc(p)):=y;@/
-end;
-
-@ @<Additional cases of unary operators@>=
-ll_corner_op: if not get_cur_bbox then bad_unary(ll_corner_op)
- else pair_value(minx,miny);
-lr_corner_op: if not get_cur_bbox then bad_unary(lr_corner_op)
- else pair_value(maxx,miny);
-ul_corner_op: if not get_cur_bbox then bad_unary(ul_corner_op)
- else pair_value(minx,maxy);
-ur_corner_op: if not get_cur_bbox then bad_unary(ur_corner_op)
- else pair_value(maxx,maxy);
-
-@ 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@>=
-function get_cur_bbox: boolean;
-label exit;
-begin case cur_type of
-picture_type: begin set_bbox(cur_exp,true);
- if minx_val(cur_exp)>maxx_val(cur_exp) then
- begin minx:=0; maxx:=0; miny:=0; maxy:=0;
- end
- else begin minx:=minx_val(cur_exp);
- maxx:=maxx_val(cur_exp);
- miny:=miny_val(cur_exp);
- maxy:=maxy_val(cur_exp);
- end;
- end;
-path_type: path_bbox(cur_exp);
-pen_type: pen_bbox(cur_exp);
-othercases begin get_cur_bbox:=false;
- return;
- end
-endcases;@/
-get_cur_bbox:=true;
-exit:end;
-
-@ @<Additional cases of unary operators@>=
-read_from_op,close_from_op: if cur_type<>string_type then bad_unary(c)
-else do_read_or_close(c);
-
-@ 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.
-
-@d close_file=46 {go here when closing the file}
-
-@<Declare unary action procedures@>=
-procedure do_read_or_close(@!c:quarterword);
-label exit, continue, found, not_found, close_file;
-var @!n,@!n0:readf_index; {indices for searching |rd_fname|}
-begin @<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|@>;
-begin_file_reading;
-name:=is_read;
-if input_ln(rd_file[n],true) then goto found;
-end_file_reading;
-not_found:@<Record the end of file and set |cur_exp| to a dummy value@>;
-return;
-close_file:flush_cur_exp(0); cur_type:=vacuous; return;
-found:flush_cur_exp(0);
-finish_read;
-exit:end;
-
-@ Free slots in the |rd_file| and |rd_fname| arrays are marked with 0's in
-|rd_fname|.
-
-@<Find the |n| where |rd_fname[n]=cur_exp|...@>=
-n:=read_files;
-n0:=read_files;
-repeat
-continue:if n>0 then decr(n)
-else if c=close_from_op then goto close_file
-else @<Insert |cur_exp| at index |n0|, then call |start_read_input| and
- |goto found| or |not_found|@>;
-if rd_fname[n]=0 then
- begin n0:=n; goto continue;
- end;
-until str_vs_str(cur_exp,rd_fname[n])=0;
-if c=close_from_op then
- begin a_close(rd_file[n]); goto not_found; end
-
-@ @<Insert |cur_exp| at index |n0|, then call |start_read_input| and...@>=
-begin if n0=read_files then
- if read_files<max_read_files then incr(read_files)
- else overflow("readfrom files",max_read_files);
-n:=n0;
-if start_read_input(cur_exp,n) then goto found @+else goto not_found;
-end
-
-@ @<Record the end of file and set |cur_exp| to a dummy value@>=
-delete_str_ref(rd_fname[n]);
-rd_fname[n]:=0;
-if n=read_files-1 then read_files:=n;
-if c=close_from_op then goto close_file;
-@<Make sure |eof_line| is initialized@>;
-flush_cur_exp(eof_line);
-cur_type:=string_type
-
-@ Since the |eof_line| string contains a non-printable character, it must be
-initialized at run time and stored in a global variable.
-
-@<Glob...@>=
-eof_line:str_number; {string denoting end-of-file or 0 if uninitialized}
-
-@ @<Set init...@>=
-eof_line:=0;
-
-@ @<Make sure |eof_line| is initialized@>=
-if eof_line=0 then
- begin append_char(0);
- eof_line:=make_string;
- str_ref[eof_line]:=max_str_ref;
- end
-
-@ Finally, we have the operations that combine a capsule~|p|
-with the current expression.
-
-@p @t\4@>@<Declare binary action procedures@>@;
-procedure do_binary(@!p:pointer;@!c:quarterword);
-label done,done1,exit;
-var @!q,@!r,@!rr:pointer; {for list manipulation}
-@!old_p,@!old_exp:pointer; {capsules to recycle}
-@!v:integer; {for numeric manipulation}
-begin check_arith;
-if internal[tracing_commands]>two then
- @<Trace the current binary operation@>;
-@<Sidestep |independent| cases in capsule |p|@>;
-@<Sidestep |independent| cases in the current expression@>;
-case c of
-plus,minus:@<Add or subtract the current expression from |p|@>;
-@t\4@>@<Additional cases of binary operators@>@;
-end; {there are no other cases}
-recycle_value(p); free_node(p,value_node_size); {|return| to avoid this}
-exit:check_arith; @<Recycle any sidestepped |independent| capsules@>;
-end;
-
-@ @<Declare binary action...@>=
-procedure bad_binary(@!p:pointer;@!c:quarterword);
-begin disp_err(p,"");
-exp_err("Not implemented: ");
-@.Not implemented...@>
-if c>=min_of then print_op(c);
-print_known_or_unknown_type(type(p),p);
-if c>=min_of then print("of")@+else print_op(c);
-print_known_or_unknown_type(cur_type,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.");
-put_get_error;
-end;
-
-@ @<Trace the current binary operation@>=
-begin begin_diagnostic; print_nl("{(");
-print_exp(p,0); {show the operand, but not verbosely}
-print_char(")"); print_op(c); print_char("(");@/
-print_exp(null,0); print(")}"); end_diagnostic(false);
-end
-
-@ 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 then
- begin recycle_value(old_p); free_node(old_p,value_node_size);
- end;
-if old_exp<>null then
- begin recycle_value(old_exp); free_node(old_exp,value_node_size);
- end
-
-@ 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|@>=
-case type(p) of
-transform_type,color_type,cmykcolor_type,pair_type: old_p:=tarnished(p);
-independent: old_p:=void;
-othercases old_p:=null
-endcases;
-if old_p<>null then
- begin q:=stash_cur_exp; old_p:=p; make_exp_copy(old_p);
- p:=stash_cur_exp; unstash_cur_exp(q);
- end;
-
-@ @<Sidestep |independent| cases in the current expression@>=
-case cur_type of
-transform_type,color_type,cmykcolor_type,
-pair_type:old_exp:=tarnished(cur_exp);
-independent:old_exp:=void;
-othercases old_exp:=null
-endcases;
-if old_exp<>null then
- begin old_exp:=cur_exp; make_exp_copy(old_exp);
- end
-
-@ @<Declare binary action...@>=
-function tarnished(@!p:pointer):pointer;
-label exit;
-var @!q:pointer; {beginning of the big node}
-@!r:pointer; {current position in the big node}
-begin q:=value(p); r:=q+big_node_size[type(p)];
-repeat r:=r-2;
-if type(r)=independent then
- begin tarnished:=void; return;
- end;
-until r=q;
-tarnished:=null;
-exit:end;
-
-@ @<Add or subtract the current expression from |p|@>=
-if (cur_type<color_type)or(type(p)<color_type) then bad_binary(p,c)
-else if (cur_type>pair_type)and(type(p)>pair_type) then
- add_or_subtract(p,null,c)
- else if cur_type<>type(p) then bad_binary(p,c)
- else begin q:=value(p); r:=value(cur_exp);
- rr:=r+big_node_size[cur_type];
- while r<rr do
- begin add_or_subtract(q,r,c);
- q:=q+2; r:=r+2;
- end;
- end
-
-@ 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...@>=
-@t\4@>@<Declare the procedure called |dep_finish|@>@;
-procedure add_or_subtract(@!p,@!q:pointer;@!c:quarterword);
-label done,exit;
-var @!s,@!t:small_number; {operand types}
-@!r:pointer; {list traverser}
-@!v:integer; {second operand value}
-begin if q=null then
- begin t:=cur_type;
- if t<dependent then v:=cur_exp@+else v:=dep_list(cur_exp);
- end
-else begin t:=type(q);
- if t<dependent then v:=value(q)@+else v:=dep_list(q);
- end;
-if t=known then
- begin if c=minus then negate(v);
- if type(p)=known then
- begin v:=slow_add(value(p),v);
- if q=null then cur_exp:=v@+else value(q):=v;
- return;
- end;
- @<Add a known value to the constant term of |dep_list(p)|@>;
- end
-else begin if c=minus then negate_dep_list(v);
- @<Add operand |p| to the dependency list |v|@>;
- end;
-exit:end;
-
-@ @<Add a known value to the constant term of |dep_list(p)|@>=
-r:=dep_list(p);
-while info(r)<>null do r:=link(r);
-value(r):=slow_add(value(r),v);
-if q=null then
- begin q:=get_node(value_node_size); cur_exp:=q; cur_type:=type(p);
- name_type(q):=capsule;
- end;
-dep_list(q):=dep_list(p); type(q):=type(p);
-prev_dep(q):=prev_dep(p); link(prev_dep(p)):=q;
-type(p):=known; {this will keep the recycler from collecting non-garbage}
-
-@ We prefer |dependent| lists to |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)=known then
- @<Add the known |value(p)| to the constant term of |v|@>
-else begin s:=type(p); r:=dep_list(p);
- if t=dependent then
- begin if s=dependent then
- if max_coef(r)+max_coef(v)<coef_bound then
- begin v:=p_plus_q(v,r,dependent); goto done;
- end; {|fix_needed| will necessarily be false}
- t:=proto_dependent; v:=p_over_v(v,unity,dependent,proto_dependent);
- end;
- if s=proto_dependent then v:=p_plus_q(v,r,proto_dependent)
- else v:=p_plus_fq(v,unity,r,proto_dependent,dependent);
- done: @<Output the answer, |v| (which might have become |known|)@>;
- end
-
-@ @<Add the known |value(p)| to the constant term of |v|@>=
-begin while info(v)<>null do v:=link(v);
-value(v):=slow_add(value(p),value(v));
-end
-
-@ @<Output the answer, |v| (which might have become |known|)@>=
-if q<>null then dep_finish(v,q,t)
-else begin cur_type:=t; dep_finish(v,null,t);
- end
-
-@ 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|@>=
-procedure dep_finish(@!v,@!q:pointer;@!t:small_number);
-var @!p:pointer; {the destination}
-@!vv:scaled; {the value, if it is |known|}
-begin if q=null then p:=cur_exp@+else p:=q;
-dep_list(p):=v; type(p):=t;
-if info(v)=null then
- begin vv:=value(v);
- if q=null then flush_cur_exp(vv)
- else begin recycle_value(p); type(q):=known; value(q):=vv;
- end;
- end
-else if q=null then cur_type:=t;
-if fix_needed then fix_dependencies;
-end;
-
-@ Let's turn now to the six basic relations of comparison.
-
-@<Additional cases of binary operators@>=
-less_than,less_or_equal,greater_than,greater_or_equal,equal_to,unequal_to:
- begin check_arith; {at this point |arith_error| should be |false|?}
- if (cur_type>pair_type)and(type(p)>pair_type) then
- add_or_subtract(p,null,minus) {|cur_exp:=(p)-cur_exp|}
- else if cur_type<>type(p) then
- begin bad_binary(p,c); goto done;
- end
- else if cur_type=string_type then
- flush_cur_exp(str_vs_str(value(p),cur_exp))
- else if (cur_type=unknown_string)or(cur_type=unknown_boolean) then
- @<Check if unknowns have been equated@>
- else if (cur_type<=pair_type)and(cur_type>=transform_type) then
- @<Reduce comparison of big nodes to comparison of scalars@>
- else if cur_type=boolean_type then flush_cur_exp(cur_exp-value(p))
- else begin bad_binary(p,c); goto done;
- end;
- @<Compare the current expression with zero@>;
-done: arith_error:=false; {ignore overflow in comparisons}
- end;
-
-@ @<Compare the current expression with zero@>=
-if cur_type<>known then
- begin if cur_type<known then
- begin disp_err(p,"");
- help1("The quantities shown above have not been equated.")@/
- end
- 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...@>
- put_get_flush_error(false_code);
- end
-else case c of
- less_than: boolean_reset(cur_exp<0);
- less_or_equal: boolean_reset(cur_exp<=0);
- greater_than: boolean_reset(cur_exp>0);
- greater_or_equal: boolean_reset(cur_exp>=0);
- equal_to: boolean_reset(cur_exp=0);
- unequal_to: boolean_reset(cur_exp<>0);
- end; {there are no other cases}
- cur_type:=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@>=
-begin q:=value(cur_exp);
-while (q<>cur_exp)and(q<>p) do q:=value(q);
-if q=p then flush_cur_exp(0);
-end
-
-@ @<Reduce comparison of big nodes to comparison of scalars@>=
-begin q:=value(p); r:=value(cur_exp);
-rr:=r+big_node_size[cur_type]-2;
-loop@+ begin add_or_subtract(q,r,minus);
- if type(r)<>known then goto done1;
- if value(r)<>0 then goto done1;
- if r=rr then goto done1;
- q:=q+2; r:=r+2;
- end;
-done1:take_part(name_type(r)+x_part-x_part_sector);
-end
-
-@ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
-
-@<Additional cases of binary operators@>=
-and_op,or_op: if (type(p)<>boolean_type)or(cur_type<>boolean_type) then
- bad_binary(p,c)
- else if value(p)=c+false_code-and_op then cur_exp:=value(p);
-
-@ @<Additional cases of binary operators@>=
-times: if (cur_type<color_type)or(type(p)<color_type) then bad_binary(p,times)
- else if (cur_type=known)or(type(p)=known) then
- @<Multiply when at least one operand is known@>
- else if (nice_color_or_pair(p,type(p))and(cur_type>pair_type))
- or(nice_color_or_pair(cur_exp,cur_type)and(type(p)>pair_type)) then
- begin hard_times(p); return;
- end
- else bad_binary(p,times);
-
-@ @<Multiply when at least one operand is known@>=
-begin if type(p)=known then
- begin v:=value(p); free_node(p,value_node_size);
- end
-else begin v:=cur_exp; unstash_cur_exp(p);
- end;
-if cur_type=known then cur_exp:=take_scaled(cur_exp,v)
-else if (cur_type=pair_type)or(cur_type=color_type)or
- (cur_type=cmykcolor_type) then
- begin p:=value(cur_exp)+big_node_size[cur_type];
- repeat p:=p-2;
- dep_mult(p,v,true);
- until p=value(cur_exp);
- end
-else dep_mult(null,v,true);
-return;
-end
-
-@ @<Declare binary action...@>=
-procedure dep_mult(@!p:pointer;@!v:integer;@!v_is_scaled:boolean);
-label exit;
-var @!q:pointer; {the dependency list being multiplied by |v|}
-@!s,@!t:small_number; {its type, before and after}
-begin if p=null then q:=cur_exp
-else if type(p)<>known then q:=p
-else begin if v_is_scaled then value(p):=take_scaled(value(p),v)
- else value(p):=take_fraction(value(p),v);
- return;
- end;
-t:=type(q); q:=dep_list(q); s:=t;
-if t=dependent then if v_is_scaled then
- if ab_vs_cd(max_coef(q),abs(v),coef_bound-1,unity)>=0 then t:=proto_dependent;
-q:=p_times_v(q,v,s,t,v_is_scaled); dep_finish(q,p,t);
-exit:end;
-
-@ 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>=color_type|.
-
-@p procedure frac_mult(@!n,@!d:scaled); {multiplies |cur_exp| by |n/d|}
-var @!p:pointer; {a pair node}
-@!old_exp:pointer; {a capsule to recycle}
-@!v:fraction; {|n/d|}
-begin if internal[tracing_commands]>two then
- @<Trace the fraction multiplication@>;
-case cur_type of
-transform_type,color_type,cmykcolor_type,pair_type:old_exp:=tarnished(cur_exp);
-independent:old_exp:=void;
-othercases old_exp:=null
-endcases;
-if old_exp<>null then
- begin old_exp:=cur_exp; make_exp_copy(old_exp);
- end;
-v:=make_fraction(n,d);
-if cur_type=known then cur_exp:=take_fraction(cur_exp,v)
-else if cur_type<=pair_type then
- begin p:=value(cur_exp)+big_node_size[cur_type];
- repeat p:=p-2;
- dep_mult(p,v,false);
- until p=value(cur_exp);
- end
-else dep_mult(null,v,false);
-if old_exp<>null then
- begin recycle_value(old_exp); free_node(old_exp,value_node_size);
- end
-end;
-
-@ @<Trace the fraction multiplication@>=
-begin begin_diagnostic; print_nl("{("); print_scaled(n); print_char("/");
-print_scaled(d); print(")*("); print_exp(null,0); print(")}");
-end_diagnostic(false);
-end
-
-@ The |hard_times| routine multiplies a nice color or pair by a dependency list.
-
-@<Declare binary action procedures@>=
-procedure hard_times(@!p:pointer);
-label done;
-var @!q:pointer; {a copy of the dependent variable |p|}
-@!r:pointer; {a component of the big node for the nice color or pair}
-@!v:scaled; {the known value for |r|}
-begin if type(p)<=pair_type then
- begin q:=stash_cur_exp; unstash_cur_exp(p); p:=q;
- end; {now |cur_type=pair_type| or |cur_type=color_type|}
-r:=value(cur_exp)+big_node_size[cur_type];
-loop @+begin r:=r-2;
- v:=value(r);
- type(r):=type(p);
- if r=value(cur_exp) then goto done;
- new_dep(r,copy_dep_list(dep_list(p)));
- dep_mult(r,v,true);
- end;
-done:mem[value_loc(r)]:=mem[value_loc(p)];
-link(prev_dep(p)):=r;
-free_node(p,value_node_size);
-dep_mult(r,v,true);
-end;
-
-@ @<Additional cases of binary operators@>=
-over: if (cur_type<>known)or(type(p)<color_type) then bad_binary(p,over)
- else begin v:=cur_exp; unstash_cur_exp(p);
- if v=0 then @<Squeal about division by zero@>
- else begin if cur_type=known then cur_exp:=make_scaled(cur_exp,v)
- else if cur_type<=pair_type then
- begin p:=value(cur_exp)+big_node_size[cur_type];
- repeat p:=p-2;
- dep_div(p,v);
- until p=value(cur_exp);
- end
- else dep_div(null,v);
- end;
- return;
- end;
-
-@ @<Declare binary action...@>=
-procedure dep_div(@!p:pointer;@!v:scaled);
-label exit;
-var @!q:pointer; {the dependency list being divided by |v|}
-@!s,@!t:small_number; {its type, before and after}
-begin if p=null then q:=cur_exp
-else if type(p)<>known then q:=p
-else begin value(p):=make_scaled(value(p),v); return;
- end;
-t:=type(q); q:=dep_list(q); s:=t;
-if t=dependent then
- if ab_vs_cd(max_coef(q),unity,coef_bound-1,abs(v))>=0 then t:=proto_dependent;
-q:=p_over_v(q,v,s,t); dep_finish(q,p,t);
-exit:end;
-
-@ @<Squeal about division by zero@>=
-begin 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.");
-put_get_error;
-end
-
-@ @<Additional cases of binary operators@>=
-pythag_add,pythag_sub: if (cur_type=known)and(type(p)=known) then
- if c=pythag_add then cur_exp:=pyth_add(value(p),cur_exp)
- else cur_exp:=pyth_sub(value(p),cur_exp)
- else bad_binary(p,c);
-
-@ The next few sections of the program deal with affine transformations
-of coordinate data.
-
-@<Additional cases of binary operators@>=
-rotated_by,slanted_by,scaled_by,shifted_by,transformed_by,
- x_scaled,y_scaled,z_scaled: @t@>@;@/
- if type(p)=path_type then
- begin path_trans(c)(p); return;
- end
- else if type(p)=pen_type then
- begin pen_trans(c)(p);
- cur_exp:=convex_hull(cur_exp); {rounding error could destroy convexity}
- return;
- end
- else if (type(p)=pair_type)or(type(p)=transform_type) then big_trans(p,c)
- else if type(p)=picture_type then
- begin do_edges_trans(p,c); return;
- end
- else bad_binary(p,c);
-
-@ 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...@>=
-procedure set_up_trans(@!c:quarterword);
-label done,exit;
-var @!p,@!q,@!r:pointer; {list manipulation registers}
-begin if (c<>transformed_by)or(cur_type<>transform_type) then
- @<Put the current transform into |cur_exp|@>;
-@<If the current transform is entirely known, stash it in global variables;
- otherwise |return|@>;
-exit:end;
-
-@ @<Glob...@>=
-@!txx,@!txy,@!tyx,@!tyy,@!tx,@!ty:scaled; {current transform coefficients}
-
-@ @<Put the current transform...@>=
-begin p:=stash_cur_exp; cur_exp:=id_transform; cur_type:=transform_type;
-q:=value(cur_exp);
-case c of
-@<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@>@;
-end; {there are no other cases}
-disp_err(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.");
-put_get_error;
-done: recycle_value(p); free_node(p,value_node_size);
-end
-
-@ @<If the current transform is entirely known, ...@>=
-q:=value(cur_exp); r:=q+transform_node_size;
-repeat r:=r-2;
-if type(r)<>known then return;
-until r=q;
-txx:=value(xx_part_loc(q));
-txy:=value(xy_part_loc(q));
-tyx:=value(yx_part_loc(q));
-tyy:=value(yy_part_loc(q));
-tx:=value(x_part_loc(q));
-ty:=value(y_part_loc(q));
-flush_cur_exp(0)
-
-@ @<For each of the eight cases...@>=
-rotated_by:if type(p)=known then
- @<Install sines and cosines, then |goto done|@>;
-slanted_by:if type(p)>pair_type then
- begin install(xy_part_loc(q),p); goto done;
- end;
-scaled_by:if type(p)>pair_type then
- begin install(xx_part_loc(q),p); install(yy_part_loc(q),p); goto done;
- end;
-shifted_by:if type(p)=pair_type then
- begin r:=value(p); install(x_part_loc(q),x_part_loc(r));
- install(y_part_loc(q),y_part_loc(r)); goto done;
- end;
-x_scaled:if type(p)>pair_type then
- begin install(xx_part_loc(q),p); goto done;
- end;
-y_scaled:if type(p)>pair_type then
- begin install(yy_part_loc(q),p); goto done;
- end;
-z_scaled:if type(p)=pair_type then
- @<Install a complex multiplier, then |goto done|@>;
-transformed_by:do_nothing;
-
-@ @<Install sines and cosines, then |goto done|@>=
-begin n_sin_cos((value(p) mod three_sixty_units)*16);
-value(xx_part_loc(q)):=round_fraction(n_cos);
-value(yx_part_loc(q)):=round_fraction(n_sin);
-value(xy_part_loc(q)):=-value(yx_part_loc(q));
-value(yy_part_loc(q)):=value(xx_part_loc(q));
-goto done;
-end
-
-@ @<Install a complex multiplier, then |goto done|@>=
-begin r:=value(p);
-install(xx_part_loc(q),x_part_loc(r));
-install(yy_part_loc(q),x_part_loc(r));
-install(yx_part_loc(q),y_part_loc(r));
-if type(y_part_loc(r))=known then negate(value(y_part_loc(r)))
-else negate_dep_list(dep_list(y_part_loc(r)));
-install(xy_part_loc(q),y_part_loc(r));
-goto done;
-end
-
-@ Procedure |set_up_known_trans| is like |set_up_trans|, but it
-insists that the transformation be entirely known.
-
-@<Declare binary action...@>=
-procedure set_up_known_trans(@!c:quarterword);
-begin set_up_trans(c);
-if cur_type<>known then
- begin 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.");
- put_get_flush_error(0);
- txx:=unity; txy:=0; tyx:=0; tyy:=unity; tx:=0; ty:=0;
- end;
-end;
-
-@ Here's a procedure that applies the transform |txx..ty| to a pair of
-coordinates in locations |p| and~|q|.
-
-@<Declare binary action...@>=
-procedure trans(@!p,@!q:pointer);
-var @!v:scaled; {the new |x| value}
-begin v:=take_scaled(mem[p].sc,txx)+take_scaled(mem[q].sc,txy)+tx;
-mem[q].sc:=take_scaled(mem[p].sc,tyx)+take_scaled(mem[q].sc,tyy)+ty;
-mem[p].sc:=v;
-end;
-
-@ 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(#)==begin set_up_known_trans(#); path_trans_end
-@d path_trans_end(#)==unstash_cur_exp(#); do_path_trans(cur_exp); end
-
-@<Declare binary action...@>=
-procedure do_path_trans(@!p:pointer);
-var @!q:pointer; {list traverser}
-begin q:=p;
-repeat
-if left_type(q)<>endpoint then trans(q+3,q+4); {that's |left_x| and |left_y|}
-trans(q+1,q+2); {that's |x_coord| and |y_coord|}
-if right_type(q)<>endpoint then trans(q+5,q+6); {that's |right_x| and |right_y|}
-@^data structure assumptions@>
-q:=link(q);
-until q=p;
-end;
-
-@ Transforming a pen is very similar, except that there are no |left_type|
-and |right_type| fields.
-
-@d pen_trans(#)==begin set_up_known_trans(#); pen_trans_end
-@d pen_trans_end(#)==unstash_cur_exp(#); do_pen_trans(cur_exp); end
-
-@<Declare binary action...@>=
-procedure do_pen_trans(@!p:pointer);
-var @!q:pointer; {list traverser}
-begin if pen_is_elliptical(p) then
- begin trans(p+3,p+4); {that's |left_x| and |left_y|}
- trans(p+5,p+6); {that's |right_x| and |right_y|}
- end;
-q:=p;
-repeat
-trans(q+1,q+2); {that's |x_coord| and |y_coord|}
-@^data structure assumptions@>
-q:=link(q);
-until q=p;
-end;
-
-@ 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...@>=
-function edges_trans(@!h:pointer):pointer;
-label done1;
-var @!q:pointer; {the object being transformed}
-@!r,@!s:pointer; {for list manipulation}
-@!sx,@!sy:scaled; {saved transformation parameters}
-@!sqdet:scaled; {square root of determinant for |dash_scale|}
-@!sgndet:integer; {sign of the determinant}
-@!v:scaled; {a temporary value}
-begin h:=private_edges(h);@/
-sqdet:=sqrt_det(txx,txy,tyx,tyy);
-sgndet:=ab_vs_cd(txx,tyy,txy,tyx);
-if dash_list(h)<>null_dash then
- @<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 do
- begin @<Transform graphical object |q|@>;@/
- q:=link(q);
- end;
-edges_trans:=h;
-end;
-@#
-procedure do_edges_trans(@!p:pointer;@!c:quarterword);
-begin set_up_known_trans(c);
-value(p):=edges_trans(value(p));
-unstash_cur_exp(p);
-end;
-@#
-procedure scale_edges;
-begin txx:=se_sf; tyy:=se_sf;
-txy:=0; tyx:=0; tx:=0; ty:=0;
-se_pic:=edges_trans(se_pic);
-end;
-
-@ @<Try to transform the dash list of |h|@>=
-if (txy<>0)or(tyx<>0)or(ty<>0)or(abs(txx)<>abs(tyy)) then
- flush_dash_list(h)
-else begin if txx<0 then @<Reverse the dash list of |h|@>;
- @<Scale the dash list by |txx| and shift it by |tx|@>;
- dash_y(h):=take_scaled(dash_y(h),abs(tyy));
- end
-
-@ @<Reverse the dash list of |h|@>=
-begin r:=dash_list(h);
-dash_list(h):=null_dash;
-while r<>null_dash do
- begin 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;
- end;
-end
-
-@ @<Scale the dash list by |txx| and shift it by |tx|@>=
-r:=dash_list(h);
-while r<>null_dash do
- begin start_x(r):=take_scaled(start_x(r),txx)+tx;
- stop_x(r):=take_scaled(stop_x(r),txx)+tx;@/
- r:=link(r);
- end
-
-@ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
-if (txx=0)and(tyy=0) then
- @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>
-else if (txy<>0)or(tyx<>0) then
- begin init_bbox(h);
- goto done1;
- end;
-if minx_val(h)<=maxx_val(h) then
- @<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|@>=
-begin 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;
-end
-
-@ 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...@>=
-begin minx_val(h):=take_scaled(minx_val(h),txx+txy)+tx;@/
-maxx_val(h):=take_scaled(maxx_val(h),txx+txy)+tx;@/
-miny_val(h):=take_scaled(miny_val(h),tyx+tyy)+ty;@/
-maxy_val(h):=take_scaled(maxy_val(h),tyx+tyy)+ty;@/
-if txx+txy<0 then
- begin v:=minx_val(h); minx_val(h):=maxx_val(h); maxx_val(h):=v;
- end;
-if tyx+tyy<0 then
- begin v:=miny_val(h); miny_val(h):=maxy_val(h); maxy_val(h):=v;
- end;
-end
-
-@ Now we ready for the main task of transforming the graphical objects in edge
-structure~|h|.
-
-@<Transform graphical object |q|@>=
-case type(q) of
-fill_code,stroked_code: begin
- do_path_trans(path_p(q));
- @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
- end;
-start_clip_code,start_bounds_code: do_path_trans(path_p(q));
-text_code:begin r:=text_tx_loc(q);
- @<Transform the compact transformation starting at |r|@>;
- end;
-stop_clip_code,stop_bounds_code: do_nothing;
-end {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 then
- begin sx:=tx; sy:=ty;
- tx:=0; ty:=0;@/
- do_pen_trans(pen_p(q));
- if ((type(q)=stroked_code)and(dash_p(q)<>null)) then
- dash_scale(q):=take_scaled(dash_scale(q),sqdet);
- if not pen_is_elliptical(pen_p(q)) then
- if sgndet<0 then
- pen_p(q):=make_pen(copy_path(pen_p(q)),true); {this unreverses the pen}
- tx:=sx; ty:=sy;
- end
-
-@ 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|@>=
-trans(r,r+1);
-sx:=tx; sy:=ty;
-tx:=0; ty:=0;
-trans(r+2,r+4);
-trans(r+3,r+5);
-tx:=sx; ty:=sy
-
-@ The hard cases of transformation occur when big nodes are involved,
-and when some of their components are unknown.
-
-@<Declare binary action...@>=
-@t\4@>@<Declare subroutines needed by |big_trans|@>@;
-procedure big_trans(@!p:pointer;@!c:quarterword);
-label exit;
-var @!q,@!r,@!pp,@!qq:pointer; {list manipulation registers}
-@!s:small_number; {size of a big node}
-begin s:=big_node_size[type(p)]; q:=value(p); r:=q+s;
-repeat r:=r-2;
-if type(r)<>known then @<Transform an unknown big node and |return|@>;
-until r=q;
-@<Transform a known big node@>;
-exit:end; {node |p| will now be recycled by |do_binary|}
-
-@ @<Transform an unknown big node and |return|@>=
-begin set_up_known_trans(c); make_exp_copy(p); r:=value(cur_exp);
-if cur_type=transform_type then
- begin bilin1(yy_part_loc(r),tyy,xy_part_loc(q),tyx,0);
- bilin1(yx_part_loc(r),tyy,xx_part_loc(q),tyx,0);
- bilin1(xy_part_loc(r),txx,yy_part_loc(q),txy,0);
- bilin1(xx_part_loc(r),txx,yx_part_loc(q),txy,0);
- end;
-bilin1(y_part_loc(r),tyy,x_part_loc(q),tyx,ty);
-bilin1(x_part_loc(r),txx,y_part_loc(q),txy,tx);
-return;
-end
-
-@ 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|@>=
-procedure bilin1(@!p:pointer;@!t:scaled;@!q:pointer;@!u,@!delta:scaled);
-var @!r:pointer; {list traverser}
-begin if t<>unity then dep_mult(p,t,true);
-if u<>0 then
- if type(q)=known then delta:=delta+take_scaled(value(q),u)
- else begin @<Ensure that |type(p)=proto_dependent|@>;
- dep_list(p):=p_plus_fq(dep_list(p),u,dep_list(q),proto_dependent,type(q));
- end;
-if type(p)=known then value(p):=value(p)+delta
-else begin r:=dep_list(p);
- while info(r)<>null do r:=link(r);
- delta:=value(r)+delta;
- if r<>dep_list(p) then value(r):=delta
- else begin recycle_value(p); type(p):=known; value(p):=delta;
- end;
- end;
-if fix_needed then fix_dependencies;
-end;
-
-@ @<Ensure that |type(p)=proto_dependent|@>=
-if type(p)<>proto_dependent then
- begin if type(p)=known then new_dep(p,const_dependency(value(p)))
- else dep_list(p):=p_times_v(dep_list(p),unity,dependent,proto_dependent,true);
- type(p):=proto_dependent;
- end
-
-@ @<Transform a known big node@>=
-set_up_trans(c);
-if cur_type=known then @<Transform known by known@>
-else begin pp:=stash_cur_exp; qq:=value(pp);
- make_exp_copy(p); r:=value(cur_exp);
- if cur_type=transform_type then
- begin bilin2(yy_part_loc(r),yy_part_loc(qq),
- value(xy_part_loc(q)),yx_part_loc(qq),null);
- bilin2(yx_part_loc(r),yy_part_loc(qq),
- value(xx_part_loc(q)),yx_part_loc(qq),null);
- bilin2(xy_part_loc(r),xx_part_loc(qq),
- value(yy_part_loc(q)),xy_part_loc(qq),null);
- bilin2(xx_part_loc(r),xx_part_loc(qq),
- value(yx_part_loc(q)),xy_part_loc(qq),null);
- end;
- bilin2(y_part_loc(r),yy_part_loc(qq),
- value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
- bilin2(x_part_loc(r),xx_part_loc(qq),
- value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
- recycle_value(pp); free_node(pp,value_node_size);
- end;
-
-@ Let |p| be a |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|@>=
-procedure add_mult_dep(@!p:pointer;@!v:scaled;@!r:pointer);
-begin if type(r)=known then
- value(dep_final):=value(dep_final)+take_scaled(value(r),v)
-else begin dep_list(p):=
- p_plus_fq(dep_list(p),v,dep_list(r),proto_dependent,type(r));
- if fix_needed then fix_dependencies;
- end;
-end;
-
-@ 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)=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|@>=
-procedure bilin2(@!p,@!t:pointer;@!v:scaled;@!u,@!q:pointer);
-var @!vv:scaled; {temporary storage for |value(p)|}
-begin vv:=value(p); type(p):=proto_dependent;
-new_dep(p,const_dependency(0)); {this sets |dep_final|}
-if vv<>0 then add_mult_dep(p,vv,t); {|dep_final| doesn't change}
-if v<>0 then add_mult_dep(p,v,u);
-if q<>null then add_mult_dep(p,unity,q);
-if dep_list(p)=dep_final then
- begin vv:=value(dep_final); recycle_value(p);
- type(p):=known; value(p):=vv;
- end;
-end;
-
-@ @<Transform known by known@>=
-begin make_exp_copy(p); r:=value(cur_exp);
-if cur_type=transform_type then
- begin bilin3(yy_part_loc(r),tyy,value(xy_part_loc(q)),tyx,0);
- bilin3(yx_part_loc(r),tyy,value(xx_part_loc(q)),tyx,0);
- bilin3(xy_part_loc(r),txx,value(yy_part_loc(q)),txy,0);
- bilin3(xx_part_loc(r),txx,value(yx_part_loc(q)),txy,0);
- end;
-bilin3(y_part_loc(r),tyy,value(x_part_loc(q)),tyx,ty);
-bilin3(x_part_loc(r),txx,value(y_part_loc(q)),txy,tx);
-end
-
-@ Finally, in |bilin3| everything is |known|.
-
-@<Declare subroutines needed by |big_trans|@>=
-procedure bilin3(@!p:pointer;@!t,@!v,@!u,@!delta:scaled);
-begin if t<>unity then delta:=delta+take_scaled(value(p),t)
-else delta:=delta+value(p);
-if u<>0 then value(p):=delta+take_scaled(v,u)
-else value(p):=delta;
-end;
-
-@ @<Additional cases of binary operators@>=
-concatenate: if (cur_type=string_type)and(type(p)=string_type) then cat(p)
- else bad_binary(p,concatenate);
-substring_of: if nice_pair(p,type(p))and(cur_type=string_type) then
- chop_string(value(p))
- else bad_binary(p,substring_of);
-subpath_of: begin if cur_type=pair_type then pair_to_path;
- if nice_pair(p,type(p))and(cur_type=path_type) then
- chop_path(value(p))
- else bad_binary(p,subpath_of);
- end;
-
-@ @<Declare binary action...@>=
-procedure cat(@!p:pointer);
-var @!a,@!b:str_number; {the strings being concatenated}
-@!k:pool_pointer; {index into |str_pool|}
-begin a:=value(p); b:=cur_exp; str_room(length(a)+length(b));
-for k:=str_start[a] to str_stop(a)-1 do append_char(so(str_pool[k]));
-for k:=str_start[b] to str_stop(b)-1 do append_char(so(str_pool[k]));
-cur_exp:=make_string; delete_str_ref(b);
-end;
-
-@ @<Declare binary action...@>=
-procedure chop_string(@!p:pointer);
-var @!a,@!b:integer; {start and stop points}
-@!l:integer; {length of the original string}
-@!k:integer; {runs from |a| to |b|}
-@!s:str_number; {the original string}
-@!reversed:boolean; {was |a>b|?}
-begin a:=round_unscaled(value(x_part_loc(p)));
-b:=round_unscaled(value(y_part_loc(p)));
-if a<=b then reversed:=false
-else begin reversed:=true; k:=a; a:=b; b:=k;
- end;
-s:=cur_exp; l:=length(s);
-if a<0 then
- begin a:=0;
- if b<0 then b:=0;
- end;
-if b>l then
- begin b:=l;
- if a>l then a:=l;
- end;
-str_room(b-a);
-if reversed then
- for k:=str_start[s]+b-1 downto str_start[s]+a do append_char(so(str_pool[k]))
-else for k:=str_start[s]+a to str_start[s]+b-1 do append_char(so(str_pool[k]));
-cur_exp:=make_string; delete_str_ref(s);
-end;
-
-@ @<Declare binary action...@>=
-procedure chop_path(@!p:pointer);
-var @!q:pointer; {a knot in the original path}
-@!pp,@!qq,@!rr,@!ss:pointer; {link variables for copies of path nodes}
-@!a,@!b,@!k,@!l:scaled; {indices for chopping}
-@!reversed:boolean; {was |a>b|?}
-begin l:=path_length; a:=value(x_part_loc(p)); b:=value(y_part_loc(p));
-if a<=b then reversed:=false
-else begin reversed:=true; k:=a; a:=b; b:=k;
- end;
-@<Dispense with the cases |a<0| and/or |b>l|@>;
-q:=cur_exp;
-while a>=unity do
- begin q:=link(q); a:=a-unity; b:=b-unity;
- end;
-if b=a then @<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):=endpoint; right_type(qq):=endpoint; link(qq):=pp;
-toss_knot_list(cur_exp);
-if reversed then
- begin cur_exp:=link(htap_ypoc(pp)); toss_knot_list(pp);
- end
-else cur_exp:=pp;
-end;
-
-@ @<Dispense with the cases |a<0| and/or |b>l|@>=
-if a<0 then
- if left_type(cur_exp)=endpoint then
- begin a:=0; if b<0 then b:=0;
- end
- else repeat a:=a+l; b:=b+l;
- until a>=0; {a cycle always has length |l>0|}
-if b>l then if left_type(cur_exp)=endpoint then
- begin b:=l; if a>l then a:=l;
- end
- else while a>=l do
- begin a:=a-l; b:=b-l;
- end
-
-@ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
-begin pp:=copy_knot(q); qq:=pp;
-repeat q:=link(q); rr:=qq; qq:=copy_knot(q); link(rr):=qq; b:=b-unity;
-until b<=0;
-if a>0 then
- begin ss:=pp; pp:=link(pp);
- split_cubic(ss,a*@'10000); pp:=link(ss);
- free_node(ss,knot_node_size);
- if rr=ss then
- begin b:=make_scaled(b,unity-a); rr:=pp;
- end;
- end;
-if b<0 then
- begin split_cubic(rr,(b+unity)*@'10000);
- free_node(qq,knot_node_size);
- qq:=link(rr);
- end;
-end
-
-@ @<Construct a path from |pp| to |qq| of length zero@>=
-begin if a>0 then
- begin split_cubic(q,a*@'10000); q:=link(q);
- end;
-pp:=copy_knot(q); qq:=pp;
-end
-
-@ @<Additional cases of binary operators@>=
-point_of,precontrol_of,postcontrol_of: begin if cur_type=pair_type then
- pair_to_path;
- if (cur_type=path_type)and(type(p)=known) then
- find_point(value(p),c)
- else bad_binary(p,c);
- end;
-pen_offset_of: if (cur_type=pen_type)and nice_pair(p,type(p)) then
- set_up_offset(value(p))
- else bad_binary(p,pen_offset_of);
-direction_time_of: begin if cur_type=pair_type then pair_to_path;
- if (cur_type=path_type)and nice_pair(p,type(p)) then
- set_up_direction_time(value(p))
- else bad_binary(p,direction_time_of);
- end;
-
-@ @<Declare binary action...@>=
-procedure set_up_offset(@!p:pointer);
-begin find_offset(value(x_part_loc(p)),value(y_part_loc(p)),cur_exp);
-pair_value(cur_x,cur_y);
-end;
-@#
-procedure set_up_direction_time(@!p:pointer);
-begin flush_cur_exp(find_direction_time(value(x_part_loc(p)),
- value(y_part_loc(p)),cur_exp));
-end;
-
-@ @<Declare binary action...@>=
-procedure find_point(@!v:scaled;@!c:quarterword);
-var @!p:pointer; {the path}
-@!n:scaled; {its length}
-begin p:=cur_exp;@/
-if left_type(p)=endpoint then n:=-unity@+else n:=0;
-repeat p:=link(p); n:=n+unity;
-until p=cur_exp;
-if n=0 then v:=0
-else if v<0 then
- if left_type(p)=endpoint then v:=0
- else v:=n-1-((-v-1) mod n)
-else if v>n then
- if left_type(p)=endpoint then v:=n
- else v:=v mod n;
-p:=cur_exp;
-while v>=unity do
- begin p:=link(p); v:=v-unity;
- end;
-if v<>0 then @<Insert a fractional node by splitting the cubic@>;
-@<Set the current expression to the desired path coordinates@>;
-end;
-
-@ @<Insert a fractional node...@>=
-begin split_cubic(p,v*@'10000); p:=link(p);
-end
-
-@ @<Set the current expression to the desired path coordinates...@>=
-case c of
-point_of: pair_value(x_coord(p),y_coord(p));
-precontrol_of: if left_type(p)=endpoint then pair_value(x_coord(p),y_coord(p))
- else pair_value(left_x(p),left_y(p));
-postcontrol_of: if right_type(p)=endpoint then pair_value(x_coord(p),y_coord(p))
- else pair_value(right_x(p),right_y(p));
-end {there are no other cases}
-
-@ @<Additional cases of binary operators@>=
-arc_time_of: begin if cur_type=pair_type then
- pair_to_path;
- if (cur_type=path_type)and(type(p)=known) then
- flush_cur_exp(get_arc_time(cur_exp,value(p)))
- else bad_binary(p,c);
- end;
-
-@ @<Additional cases of bin...@>=
-intersect: begin if type(p)=pair_type then
- begin q:=stash_cur_exp; unstash_cur_exp(p);
- pair_to_path; p:=stash_cur_exp; unstash_cur_exp(q);
- end;
- if cur_type=pair_type then pair_to_path;
- if (cur_type=path_type)and(type(p)=path_type) then
- begin path_intersection(value(p),cur_exp);
- pair_value(cur_t,cur_tt);
- end
- else bad_binary(p,intersect);
- end;
-
-@ @<Additional cases of bin...@>=
-in_font:if (cur_type<>string_type)or(type(p)<>string_type)
- then bad_binary(p,in_font)
- else begin do_infont(p); return;
- end;
-
-@ 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...@>=
-procedure do_infont(@!p:pointer);
-var @!q:pointer;
-begin q:=get_node(edge_header_size);
-init_edges(q);
-link(obj_tail(q)):=new_text_node(cur_exp,value(p));
-obj_tail(q):=link(obj_tail(q));
-free_node(p,value_node_size);@/
-flush_cur_exp(q);
-cur_type:=picture_type;
-end;
-
-@* \[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.
-
-@p @<Declare action procedures for use by |do_statement|@>@;
-procedure do_statement; {governs \MP's activities}
-begin cur_type:=vacuous; get_x_next;
-if cur_cmd>max_primary_command then @<Worry about bad statement@>
-else if cur_cmd>max_statement_command then
- @<Do an equation, assignment, title, or
- `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>
-else @<Do a statement that doesn't begin with an expression@>;
-if cur_cmd<semicolon then
- @<Flush unparsable junk that was found after the statement@>;
-error_count:=0;
-end;
-
-@ 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@>=
-begin if cur_cmd<semicolon then
- begin print_err("A statement can't begin with `");
-@.A statement can't begin with x@>
- print_cmd_mod(cur_cmd,cur_mod); print_char("'");
- 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@>
- back_error; get_x_next;
- end;
-end
-
-@ 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@>=
-begin 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@>
-back_error; scanner_status:=flushing;
-repeat get_t_next;
-@<Decrease the string reference count...@>;
-until end_of_statement; {|cur_cmd=semicolon|, |end_group|, or |stop|}
-scanner_status:=normal;
-end
-
-@ If |do_statement| ends with |cur_cmd=end_group|, we should have
-|cur_type=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...@>=
-begin if internal[tracing_commands]>0 then show_cur_cmd_mod;
-case cur_cmd of
-type_name:do_type_declaration;
-macro_def:if cur_mod>var_def then make_op_def
- else if cur_mod>end_def then scan_def;
-@t\4@>@<Cases of |do_statement| that invoke particular commands@>@;
-end; {there are no other cases}
-cur_type:=vacuous;
-end
-
-@ The most important statements begin with expressions.
-
-@<Do an equation, assignment, title, or...@>=
-begin var_flag:=assignment; scan_expression;
-if cur_cmd<end_group then
- begin if cur_cmd=equals then do_equation
- else if cur_cmd=assignment then do_assignment
- else if cur_type=string_type then @<Do a title@>
- else if cur_type<>vacuous then
- begin 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.");
- put_get_error;
- end;
- flush_cur_exp(0); cur_type:=vacuous;
- end;
-end
-
-@ @<Do a title@>=
-begin if internal[tracing_titles]>0 then
- begin print_nl(""); print(cur_exp); update_terminal;
- end;
-end
-
-@ 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|@>=
-@t\4@>@<Declare the procedure called |try_eq|@>@;
-@t\4@>@<Declare the procedure called |make_eq|@>@;
-procedure@?do_assignment; forward;@t\2@>@/
-procedure do_equation;
-var @!lhs:pointer; {capsule for the left-hand side}
-@!p:pointer; {temporary register}
-begin lhs:=stash_cur_exp; get_x_next; var_flag:=assignment; scan_expression;
-if cur_cmd=equals then do_equation
-else if cur_cmd=assignment then do_assignment;
-if internal[tracing_commands]>two then @<Trace the current equation@>;
-if cur_type=unknown_path then if type(lhs)=pair_type then
- begin p:=stash_cur_exp; unstash_cur_exp(lhs); lhs:=p;
- end; {in this case |make_eq| will change the pair to a path}
-make_eq(lhs); {equate |lhs| to |(cur_type,cur_exp)|}
-end;
-
-@ And |do_assignment| is similar to |do_equation|:
-
-@<Declare action procedures for use by |do_statement|@>=
-procedure do_assignment;
-var @!lhs:pointer; {token list for the left-hand side}
-@!p:pointer; {where the left-hand value is stored}
-@!q:pointer; {temporary capsule for the right-hand value}
-begin if cur_type<>token_list then
- begin 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.");@/
- error; do_equation;
- end
-else begin lhs:=cur_exp; cur_type:=vacuous;@/
- get_x_next; var_flag:=assignment; scan_expression;
- if cur_cmd=equals then do_equation
- else if cur_cmd=assignment then do_assignment;
- if internal[tracing_commands]>two then @<Trace the current assignment@>;
- if info(lhs)>hash_end then
- @<Assign the current expression to an internal variable@>
- else @<Assign the current expression to the variable |lhs|@>;
- flush_node_list(lhs);
- end;
-end;
-
-@ @<Trace the current equation@>=
-begin begin_diagnostic; print_nl("{("); print_exp(lhs,0);
-print(")=("); print_exp(null,0); print(")}"); end_diagnostic(false);
-end
-
-@ @<Trace the current assignment@>=
-begin begin_diagnostic; print_nl("{");
-if info(lhs)>hash_end then print(int_name[info(lhs)-(hash_end)])
-else show_token_list(lhs,null,1000,0);
-print(":="); print_exp(null,0); print_char("}"); end_diagnostic(false);
-end
-
-@ @<Assign the current expression to an internal variable@>=
-if cur_type=known then internal[info(lhs)-(hash_end)]:=cur_exp
-else begin exp_err("Internal quantity `");
-@.Internal quantity...@>
- print(int_name[info(lhs)-(hash_end)]);
- print("' 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.");
- put_get_error;
- end
-
-@ @<Assign the current expression to the variable |lhs|@>=
-begin p:=find_variable(lhs);
-if p<>null then
- begin q:=stash_cur_exp; cur_type:=und_type(p); recycle_value(p);
- type(p):=cur_type; value(p):=null; make_exp_copy(p);
- p:=stash_cur_exp; unstash_cur_exp(q); make_eq(p);
- end
-else begin obliterated(lhs); put_get_error;
- end;
-end
-
-
-@ 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|@>=
-procedure make_eq(@!lhs:pointer);
-label restart,done, not_found;
-var @!t:small_number; {type of the left-hand side}
-@!v:integer; {value of the left-hand side}
-@!p,@!q:pointer; {pointers inside of big nodes}
-begin restart: t:=type(lhs); v:=0;
-if t<=pair_type then v:=value(lhs);
-case t of
-@t\4@>@<For each type |t|, make an equation and |goto done| unless |cur_type|
- is incompatible with~|t|@>@;
-end; {all cases have been listed}
-@<Announce that the equation cannot be performed@>;
-done:check_arith; recycle_value(lhs); free_node(lhs,value_node_size);
-end;
-
-@ @<Announce that the equation cannot be performed@>=
-disp_err(lhs,""); exp_err("Equation cannot be performed (");
-@.Equation cannot be performed@>
-if type(lhs)<=pair_type then print_type(type(lhs))@+else print("numeric");
-print_char("=");
-if cur_type<=pair_type then print_type(cur_type)@+else print("numeric");
-print_char(")");@/
-help2("I'm sorry, but I don't know how to make such things equal.")@/
- ("(See the two expressions just above the error message.)");
-put_get_error
-
-@ @<For each type |t|, make an equation and |goto done| unless...@>=
-boolean_type,string_type,pen_type,path_type,picture_type:
- if cur_type=t+unknown_tag then
- begin nonlinear_eq(v,cur_exp,false); unstash_cur_exp(cur_exp); goto done;
- end
- else if cur_type=t then
- @<Report redundant or inconsistent equation and |goto done|@>;
-unknown_types:if cur_type=t-unknown_tag then
- begin nonlinear_eq(cur_exp,lhs,true); goto done;
- end
- else if cur_type=t then
- begin ring_merge(lhs,cur_exp); goto done;
- end
- else if cur_type=pair_type then if t=unknown_path then
- begin pair_to_path; goto restart;
- end;
-transform_type,color_type,cmykcolor_type,
-pair_type:if cur_type=t then
- @<Do multiple equations and |goto done|@>;
-known,dependent,proto_dependent,independent:if cur_type>=known then
- begin try_eq(lhs,null); goto done;
- end;
-vacuous:do_nothing;
-
-@ @<Report redundant or inconsistent equation and |goto done|@>=
-begin if cur_type<=string_type then
- begin if cur_type=string_type then
- begin if str_vs_str(v,cur_exp)<>0 then goto not_found;
- end
- else if v<>cur_exp then goto not_found;
- @<Exclaim about a redundant equation@>; goto done;
- end;
-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.");
-put_get_error; 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.");
-put_get_error; goto done;
-end
-
-@ @<Do multiple equations and |goto done|@>=
-begin p:=v+big_node_size[t]; q:=value(cur_exp)+big_node_size[t];
-repeat p:=p-2; q:=q-2; try_eq(p,q);
-until p=v;
-goto done;
-end
-
-@ 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|@>=
-procedure try_eq(@!l,@!r:pointer);
-label done,done1;
-var @!p:pointer; {dependency list for right operand minus left operand}
-@!t:known..independent; {the type of list |p|}
-@!q:pointer; {the constant term of |p| is here}
-@!pp:pointer; {dependency list for right operand}
-@!tt:dependent..independent; {the type of list |pp|}
-@!copied:boolean; {have we copied a list that ought to be recycled?}
-begin @<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 then @<Deal with redundant or inconsistent equation@>
-else begin linear_eq(p,t);
- if r=null then if cur_type<>known then if type(cur_exp)=known then
- begin pp:=cur_exp; cur_exp:=value(cur_exp); cur_type:=known;
- free_node(pp,value_node_size);
- end;
- end;
-end;
-
-@ @<Remove the left operand from its container, negate it, and...@>=
-t:=type(l);
-if t=known then
- begin t:=dependent; p:=const_dependency(-value(l)); q:=p;
- end
-else if t=independent then
- begin t:=dependent; p:=single_dependency(l); negate(value(p));
- q:=dep_final;
- end
-else begin p:=dep_list(l); q:=p;
- loop@+ begin negate(value(q));
- if info(q)=null then goto done;
- q:=link(q);
- end;
- done: link(prev_dep(l)):=link(q); prev_dep(link(q)):=prev_dep(l);
- type(l):=known;
- end
-
-@ @<Deal with redundant or inconsistent equation@>=
-begin if abs(value(p))>64 then {off by .001 or more}
- begin print_err("Inconsistent equation");@/
-@.Inconsistent equation@>
- print(" (off by "); print_scaled(value(p)); print_char(")");
- help2("The equation I just read contradicts what was said before.")@/
- ("But don't worry; continue and I'll just ignore it.");
- put_get_error;
- end
-else if r=null then @<Exclaim about a redundant equation@>;
-free_node(p,dep_node_size);
-end
-
-@ @<Add the right operand to list |p|@>=
-if r=null then
- if cur_type=known then
- begin value(q):=value(q)+cur_exp; goto done1;
- end
- else begin tt:=cur_type;
- if tt=independent then pp:=single_dependency(cur_exp)
- else pp:=dep_list(cur_exp);
- end
-else if type(r)=known then
- begin value(q):=value(q)+value(r); goto done1;
- end
- else begin tt:=type(r);
- if tt=independent then pp:=single_dependency(r)
- else pp:=dep_list(r);
- end;
-if tt<>independent then copied:=false
-else begin copied:=true; tt:=dependent;
- end;
-@<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
-if copied then flush_node_list(pp);
-done1:
-
-@ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
-watch_coefs:=false;
-if t=tt then p:=p_plus_q(p,pp,t)
-else if t=proto_dependent then
- p:=p_plus_fq(p,unity,pp,proto_dependent,dependent)
-else begin q:=p;
- while info(q)<>null do
- begin value(q):=round_fraction(value(q)); q:=link(q);
- end;
- t:=proto_dependent; p:=p_plus_q(p,pp,t);
- end;
-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|@>=
-function scan_declared_variable:pointer;
-label done;
-var @!x:pointer; {hash address of the variable's root}
-@!h,@!t:pointer; {head and tail of the token list to be returned}
-@!l:pointer; {hash address of left bracket}
-begin get_symbol; x:=cur_sym;
-if cur_cmd<>tag_token then clear_symbol(x,false);
-h:=get_avail; info(h):=x; t:=h;@/
-loop@+ begin get_x_next;
- if cur_sym=0 then goto done;
- if cur_cmd<>tag_token then if cur_cmd<>internal_quantity then
- if cur_cmd=left_bracket then @<Descend past a collective subscript@>
- else goto done;
- link(t):=get_avail; t:=link(t); info(t):=cur_sym;
- end;
-done: if eq_type(x) mod outer_tag<>tag_token then clear_symbol(x,false);
-if equiv(x)=null then new_root(x);
-scan_declared_variable:=h;
-end;
-
-@ If the subscript isn't collective, we don't accept it as part of the
-declared variable.
-
-@<Descend past a collective subscript@>=
-begin l:=cur_sym; get_x_next;
-if cur_cmd<>right_bracket then
- begin back_input; cur_sym:=l; cur_cmd:=left_bracket; goto done;
- end
-else cur_sym:=collective_subscript;
-end
-
-@ Type declarations are introduced by the following primitive operations.
-
-@<Put each...@>=
-primitive("numeric",type_name,numeric_type);@/
-@!@:numeric_}{\&{numeric} primitive@>
-primitive("string",type_name,string_type);@/
-@!@:string_}{\&{string} primitive@>
-primitive("boolean",type_name,boolean_type);@/
-@!@:boolean_}{\&{boolean} primitive@>
-primitive("path",type_name,path_type);@/
-@!@:path_}{\&{path} primitive@>
-primitive("pen",type_name,pen_type);@/
-@!@:pen_}{\&{pen} primitive@>
-primitive("picture",type_name,picture_type);@/
-@!@:picture_}{\&{picture} primitive@>
-primitive("transform",type_name,transform_type);@/
-@!@:transform_}{\&{transform} primitive@>
-primitive("color",type_name,color_type);@/
-@!@:color_}{\&{color} primitive@>
-primitive("rgbcolor",type_name,color_type);@/
-@!@:color_}{\&{rgbcolor} primitive@>
-primitive("cmykcolor",type_name,cmykcolor_type);@/
-@!@:color_}{\&{cmykcolor} primitive@>
-primitive("pair",type_name,pair_type);@/
-@!@:pair_}{\&{pair} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-type_name: print_type(m);
-
-@ 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|@>=
-procedure do_type_declaration;
-var @!t:small_number; {the type being declared}
-@!p:pointer; {token list for a declared variable}
-@!q:pointer; {value node for the variable}
-begin if cur_mod>=transform_type then t:=cur_mod@+else t:=cur_mod+unknown_tag;
-repeat p:=scan_declared_variable;
-flush_variable(equiv(info(p)),link(p),false);@/
-q:=find_variable(p);
-if q<>null then
- begin type(q):=t; value(q):=null;
- end
-else begin 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.");
- put_get_error;
- end;
-flush_list(p);
-if cur_cmd<comma then @<Flush spurious symbols after the declared variable@>;
-until end_of_statement;
-end;
-
-@ @<Flush spurious symbols after the declared variable@>=
-begin 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 cur_cmd=numeric_token then
- help_line[2]:="Explicit subscripts like `x15a' aren't permitted.";
-put_get_error; scanner_status:=flushing;
-repeat get_t_next;
-@<Decrease the string reference count...@>;
-until cur_cmd>=comma; {either |end_of_statement| or |cur_cmd=comma|}
-scanner_status:=normal;
-end
-
-@ \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|.
-
-@p procedure main_control;
-begin repeat do_statement;
-if cur_cmd=end_group then
- begin print_err("Extra `endgroup'");
-@.Extra `endgroup'@>
- help2("I'm not currently working on a `begingroup',")@/
- ("so I had better not try to end anything.");
- flush_error(0);
- end;
-until cur_cmd=stop;
-end;
-
-@ @<Put each...@>=
-primitive("end",stop,0);@/
-@!@:end_}{\&{end} primitive@>
-primitive("dump",stop,1);@/
-@!@:dump_}{\&{dump} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-stop:if m=0 then print("end")@+else print("dump");
-
-@* \[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|...@>=
-random_seed: do_random_seed;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_random_seed;
-begin get_x_next;
-if cur_cmd<>assignment then
- begin missing_err(":=");
-@.Missing `:='@>
- help1("Always say `randomseed:=<numeric expression>'.");
- back_error;
- end;
-get_x_next; scan_expression;
-if cur_type<>known then
- begin 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.");@/
- put_get_flush_error(0);
- end
-else @<Initialize the random seed to |cur_exp|@>;
-end;
-
-@ @<Initialize the random seed to |cur_exp|@>=
-begin init_randoms(cur_exp);
-if selector>=log_only then
- begin old_setting:=selector; selector:=log_only;
- print_nl("{randomseed:="); print_scaled(cur_exp); print_char("}");
- print_nl(""); selector:=old_setting;
- end;
-end
-
-@ And here's another simple one (somewhat different in flavor):
-
-@<Cases of |do_statement|...@>=
-mode_command: begin print_ln; interaction:=cur_mod;
- @<Initialize the print |selector| based on |interaction|@>;
- if log_opened then selector:=selector+2;
- get_x_next;
- end;
-
-@ @<Put each...@>=
-primitive("batchmode",mode_command,batch_mode);
-@!@:batch_mode_}{\&{batchmode} primitive@>
-primitive("nonstopmode",mode_command,nonstop_mode);
-@!@:nonstop_mode_}{\&{nonstopmode} primitive@>
-primitive("scrollmode",mode_command,scroll_mode);
-@!@:scroll_mode_}{\&{scrollmode} primitive@>
-primitive("errorstopmode",mode_command,error_stop_mode);
-@!@:error_stop_mode_}{\&{errorstopmode} primitive@>
-
-@ @<Cases of |print_cmd_mod|...@>=
-mode_command: case m of
- batch_mode: print("batchmode");
- nonstop_mode: print("nonstopmode");
- scroll_mode: print("scrollmode");
- othercases print("errorstopmode")
- endcases;
-
-@ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
-
-@<Cases of |do_statement|...@>=
-protection_command: do_protection;
-
-@ @<Put each...@>=
-primitive("inner",protection_command,0);@/
-@!@:inner_}{\&{inner} primitive@>
-primitive("outer",protection_command,1);@/
-@!@:outer_}{\&{outer} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-protection_command: if m=0 then print("inner")@+else print("outer");
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_protection;
-var @!m:0..1; {0 to unprotect, 1 to protect}
-@!t:halfword; {the |eq_type| before we change it}
-begin m:=cur_mod;
-repeat get_symbol; t:=eq_type(cur_sym);
- if m=0 then
- begin if t>=outer_tag then eq_type(cur_sym):=t-outer_tag;
- end
- else if t<outer_tag then eq_type(cur_sym):=t+outer_tag;
- get_x_next;
-until cur_cmd<>comma;
-end;
-
-@ \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|...@>=
-delimiters: def_delims;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure def_delims;
-var l_delim,r_delim:pointer; {the new delimiter pair}
-begin get_clear_symbol; l_delim:=cur_sym;@/
-get_clear_symbol; r_delim:=cur_sym;@/
-eq_type(l_delim):=left_delimiter; equiv(l_delim):=r_delim;@/
-eq_type(r_delim):=right_delimiter; equiv(r_delim):=l_delim;@/
-get_x_next;
-end;
-
-@ 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|@>=
-procedure check_delimiter(@!l_delim,@!r_delim:pointer);
-label exit;
-begin if cur_cmd=right_delimiter then if cur_mod=l_delim then return;
-if cur_sym<>r_delim then
- begin missing_err(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.");
- back_error;
- end
-else begin print_err("The token `"); print(text(r_delim));
-@.The token...delimiter@>
- print("' 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.");
- error;
- end;
-exit:end;
-
-@ The next four commands save or change the values associated with tokens.
-
-@<Cases of |do_statement|...@>=
-save_command: repeat get_symbol; save_variable(cur_sym); get_x_next;
- until cur_cmd<>comma;
-interim_command: do_interim;
-let_command: do_let;
-new_internal: do_new_internal;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure@?do_statement; forward;@t\2@>@/
-procedure do_interim;
-begin get_x_next;
-if cur_cmd<>internal_quantity then
- begin print_err("The token `");
-@.The token...quantity@>
- if cur_sym=0 then print("(%CAPSULE)")
- else print(text(cur_sym));
- print("' isn't an internal quantity");
- help1("Something like `tracingonline' should follow `interim'.");
- back_error;
- end
-else begin save_internal(cur_mod); back_input;
- end;
-do_statement;
-end;
-
-@ 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|@>=
-procedure do_let;
-var @!l:pointer; {hash location of the left-hand symbol}
-begin get_symbol; l:=cur_sym; get_x_next;
-if cur_cmd<>equals then if cur_cmd<>assignment then
- begin missing_err("=");
-@.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'.");
- back_error;
- end;
-get_symbol;
-case cur_cmd of
-defined_macro,secondary_primary_macro,tertiary_secondary_macro,
- expression_tertiary_macro: add_mac_ref(cur_mod);
-othercases do_nothing
-endcases;@/
-clear_symbol(l,false); eq_type(l):=cur_cmd;
-if cur_cmd=tag_token then equiv(l):=null
-else equiv(l):=cur_mod;
-get_x_next;
-end;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_new_internal;
-begin repeat if int_ptr=max_internal then
- overflow("number of internals",max_internal);
-@:MetaPost capacity exceeded number of int}{\quad number of internals@>
-get_clear_symbol; incr(int_ptr);
-eq_type(cur_sym):=internal_quantity; equiv(cur_sym):=int_ptr;
-int_name[int_ptr]:=text(cur_sym); internal[int_ptr]:=0;
-get_x_next;
-until cur_cmd<>comma;
-end;
-
-@ 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...@>=
-primitive("showtoken",show_command,show_token_code);@/
-@!@:show_token_}{\&{showtoken} primitive@>
-primitive("showstats",show_command,show_stats_code);@/
-@!@:show_stats_}{\&{showstats} primitive@>
-primitive("show",show_command,show_code);@/
-@!@:show_}{\&{show} primitive@>
-primitive("showvariable",show_command,show_var_code);@/
-@!@:show_var_}{\&{showvariable} primitive@>
-primitive("showdependencies",show_command,show_dependencies_code);@/
-@!@:show_dependencies_}{\&{showdependencies} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-show_command: case m of
- show_token_code:print("showtoken");
- show_stats_code:print("showstats");
- show_code:print("show");
- show_var_code:print("showvariable");
- othercases print("showdependencies")
- endcases;
-
-@ @<Cases of |do_statement|...@>=
-show_command:do_show_whatever;
-
-@ 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|@>=
-procedure do_show;
-begin repeat get_x_next; scan_expression;
-print_nl(">> ");
-@.>>@>
-print_exp(null,2); flush_cur_exp(0);
-until cur_cmd<>comma;
-end;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure disp_token;
-begin print_nl("> ");
-@.>\relax@>
-if cur_sym=0 then @<Show a numeric or string or capsule token@>
-else begin print(text(cur_sym)); print_char("=");
- if eq_type(cur_sym)>=outer_tag then print("(outer) ");
- print_cmd_mod(cur_cmd,cur_mod);
- if cur_cmd=defined_macro then
- begin print_ln; show_macro(cur_mod,null,100000);
- end; {this avoids recursion between |show_macro| and |print_cmd_mod|}
-@^recursion@>
- end;
-end;
-
-@ @<Show a numeric or string or capsule token@>=
-begin if cur_cmd=numeric_token then print_scaled(cur_mod)
-else if cur_cmd=capsule_token then
- begin g_pointer:=cur_mod; print_capsule;
- end
-else begin print_char(""""); print(cur_mod); print_char("""");
- delete_str_ref(cur_mod);
- end;
-end
-
-@ 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_...@>=
-left_delimiter,right_delimiter: begin if c=left_delimiter then print("lef")
- else print("righ");
- print("t delimiter that matches "); print(text(m));
- end;
-tag_token:if m=null then print("tag")@+else print("variable");
-defined_macro: print("macro:");
-secondary_primary_macro,tertiary_secondary_macro,expression_tertiary_macro:
- begin print_cmd_mod(macro_def,c); print("'d macro:");
- print_ln; show_token_list(link(link(m)),null,1000,0);
- end;
-repeat_loop:print("[repeat the loop]");
-internal_quantity:print(int_name[m]);
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_show_token;
-begin repeat get_t_next; disp_token;
-get_x_next;
-until cur_cmd<>comma;
-end;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_show_stats;
-begin print_nl("Memory usage ");
-@.Memory usage...@>
-@!stat print_int(var_used); print_char("&"); print_int(dyn_used);
-if false then@+tats@t@>@;@/
-print("unknown");
-print(" ("); print_int(hi_mem_min-lo_mem_max-1);
-print(" still untouched)"); print_ln;
-print_nl("String usage ");
-stat print_int(strs_in_use-init_str_use);
-print_char("&"); print_int(pool_in_use-init_pool_ptr);
-if false then@+tats@t@>@;@/
-print("unknown");
-print(" (");
-print_int(max_strings-1-strs_used_up); print_char("&");
-print_int(pool_size-pool_ptr); print(" now untouched)"); print_ln;
-get_x_next;
-end;
-
-@ 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|@>=
-procedure disp_var(@!p:pointer);
-var @!q:pointer; {traverses attributes and subscripts}
-@!n:0..max_print_line; {amount of macro text to show}
-begin if type(p)=structured then @<Descend the structure@>
-else if type(p)>=unsuffixed_macro then @<Display a variable macro@>
-else if type(p)<>undefined then
- begin print_nl(""); print_variable_name(p); print_char("=");
- print_exp(p,0);
- end;
-end;
-
-@ @<Descend the structure@>=
-begin q:=attr_head(p);
-repeat disp_var(q); q:=link(q);
-until q=end_attr;
-q:=subscr_head(p);
-while name_type(q)=subscr do
- begin disp_var(q); q:=link(q);
- end;
-end
-
-@ @<Display a variable macro@>=
-begin print_nl(""); print_variable_name(p);
-if type(p)>unsuffixed_macro then print("@@#"); {|suffixed_macro|}
-print("=macro:");
-if file_offset>=max_print_line-20 then n:=5
-else n:=max_print_line-file_offset-15;
-show_macro(value(p),null,n);
-end
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_show_var;
-label done;
-begin repeat get_t_next;
-if cur_sym>0 then if cur_sym<=hash_end then
- if cur_cmd=tag_token then if cur_mod<>null then
- begin disp_var(cur_mod); goto done;
- end;
-disp_token;
-done:get_x_next;
-until cur_cmd<>comma;
-end;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_show_dependencies;
-var @!p:pointer; {link that runs through all dependencies}
-begin p:=link(dep_head);
-while p<>dep_head do
- begin if interesting(p) then
- begin print_nl(""); print_variable_name(p);
- if type(p)=dependent then print_char("=")
- else print(" = "); {extra spaces imply proto-dependency}
- print_dependency(dep_list(p),type(p));
- end;
- p:=dep_list(p);
- while info(p)<>null do p:=link(p);
- p:=link(p);
- end;
-get_x_next;
-end;
-
-@ Finally we are ready for the procedure that governs all of the
-show commands.
-
-@<Declare action procedures for use by |do_statement|@>=
-procedure do_show_whatever;
-begin if interaction=error_stop_mode then wake_up_terminal;
-case cur_mod of
-show_token_code:do_show_token;
-show_stats_code:do_show_stats;
-show_code:do_show;
-show_var_code:do_show_var;
-show_dependencies_code:do_show_dependencies;
-end; {there are no other cases}
-if internal[showstopping]>0 then
- begin print_err("OK");
-@.OK@>
- if interaction<error_stop_mode then
- begin help0; decr(error_count);
- end
- else help1("This isn't an error message; I'm just showing something.");
- if cur_cmd=semicolon then error@+else put_get_error;
- end;
-end;
-
-@ 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...@>=
-primitive("doublepath",thing_to_add,double_path_code);@/
-@!@:double_path_}{\&{doublepath} primitive@>
-primitive("contour",thing_to_add,contour_code);@/
-@!@:contour_}{\&{contour} primitive@>
-primitive("also",thing_to_add,also_code);@/
-@!@:also_}{\&{also} primitive@>
-primitive("withpen",with_option,pen_type);@/
-@!@:with_pen_}{\&{withpen} primitive@>
-primitive("dashed",with_option,picture_type);@/
-@!@:dashed_}{\&{dashed} primitive@>
-primitive("withprescript",with_option,with_pre_script);@/
-@!@:with_pre_script_}{\&{withprescript} primitive@>
-primitive("withpostscript",with_option,with_post_script);@/
-@!@:with_post_script_}{\&{withpostscript} primitive@>
-primitive("withoutcolor",with_option,no_model);@/
-@!@:with_color_}{\&{withoutcolor} primitive@>
-primitive("withgreyscale",with_option,grey_model);@/
-@!@:with_color_}{\&{withgreyscale} primitive@>
-primitive("withcolor",with_option,uninitialized_model);@/
-@!@:with_color_}{\&{withcolor} primitive@>
-{ \&{withrgbcolor} is an alias for \&{withcolor}}
-primitive("withrgbcolor",with_option,rgb_model);@/
-@!@:with_color_}{\&{withrgbcolor} primitive@>
-primitive("withcmykcolor",with_option,cmyk_model);@/
-@!@:with_color_}{\&{withcmykcolor} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-thing_to_add:if m=contour_code then print("contour")
- else if m=double_path_code then print("doublepath")
- else print("also");
-with_option:if m=pen_type then print("withpen")
- else if m=with_pre_script then print("withprescript")
- else if m=with_post_script then print("withpostscript")
- else if m=no_model then print("withoutcolor")
- else if m=rgb_model then print("withrgbcolor")
- else if m=uninitialized_model then print("withcolor")
- else if m=cmyk_model then print("withcmykcolor")
- else if m=grey_model then print("withgreyscale")
- else print("dashed");
-
-@ 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|@>=
-procedure scan_with_list(@!p:pointer);
-label done, done1, done2;
-var @!t:small_number; {|cur_mod| of the |with_option| (should match |cur_type|)}
-@!q:pointer; {for list manipulation}
-@!old_setting:0..max_selector; {saved |selector| setting}
-@!k:pointer; {for finding the near-last item in a list }
-@!s:str_number; {for string cleanup after combining }
-@!cp,@!pp,@!dp,@!ap,@!bp:pointer;
- {objects being updated; |void| initially; |null| to suppress update}
-begin cp:=void; pp:=void; dp:=void; ap:=void; bp:=void; k:=null;
-while cur_cmd=with_option do
- begin t:=cur_mod;
- get_x_next;
- if t<>no_model then scan_expression;
- if ((t=with_pre_script)and(cur_type<>string_type))or
- ((t=with_post_script)and(cur_type<>string_type))or
- ((t=uninitialized_model)and
- ((cur_type<>cmykcolor_type)and(cur_type<>color_type)
- and(cur_type<>known)and(cur_type<>boolean_type)))or
- ((t=cmyk_model)and(cur_type<>cmykcolor_type))or
- ((t=rgb_model)and(cur_type<>color_type))or
- ((t=grey_model)and(cur_type<>known))or
- ((t=pen_type)and(cur_type<>t))or
- ((t=picture_type)and(cur_type<>t)) then @<Complain about improper type@>
- else if t=uninitialized_model then
- begin if cp=void then @<Make |cp| a colored object in object list~|p|@>;
- if cp<>null then
- @<Transfer a color from the current expression to object~|cp|@>;
- flush_cur_exp(0);
- end
- else if t=rgb_model then
- begin if cp=void then @<Make |cp| a rgb colored object in object list~|p|@>;
- if cp<>null then
- @<Transfer a rgbcolor from the current expression to object~|cp|@>;
- flush_cur_exp(0);
- end
- else if t=cmyk_model then
- begin if cp=void then @<Make |cp| a cmyk colored object in object list~|p|@>;
- if cp<>null then
- @<Transfer a cmykcolor from the current expression to object~|cp|@>;
- flush_cur_exp(0);
- end
- else if t=grey_model then
- begin if cp=void then @<Make |cp| a grey colored object in object list~|p|@>;
- if cp<>null then
- @<Transfer a greyscale from the current expression to object~|cp|@>;
- flush_cur_exp(0);
- end
- else if t=no_model then
- begin if cp=void then @<Make |cp| a no colored object in object list~|p|@>;
- if cp<>null then
- @<Transfer a noncolor from the current expression to object~|cp|@>;
- end
- else if t=pen_type then
- begin if pp=void then @<Make |pp| an object in list~|p| that needs
- a pen@>;
- if pp<>null then
- begin if pen_p(pp)<>null then toss_knot_list(pen_p(pp));
- pen_p(pp):=cur_exp; cur_type:=vacuous;
- end;
- end
- else if t=with_pre_script then
- begin if ap=void then
- ap:=p;
- while (ap<>null)and(not has_color(ap)) do
- ap:=link(ap);
- if ap<>null then
- begin if pre_script(ap)<>null then begin { build a new,combined string }
- s:=pre_script(ap);
- old_setting:=selector;
- selector:=new_string;
- str_room(length(pre_script(ap))+length(cur_exp)+2);
- print(cur_exp);
- append_char(13); {a forced \ps\ newline }
- print(pre_script(ap));
- pre_script(ap):=make_string;
- delete_str_ref(s);
- selector:=old_setting;
- end
- else
- pre_script(ap):=cur_exp;
- cur_type:=vacuous;
- end;
- end
- else if t=with_post_script then
- begin if bp=void then
- k:=p; bp:=k;
- while link(k)<>null do begin
- k:=link(k);
- if has_color(k) then bp:=k;
- end;
- if bp<>null then
- begin if post_script(bp)<>null then begin
- s:=post_script(bp);
- old_setting:=selector;
- selector:=new_string;
- str_room(length(post_script(bp))+length(cur_exp)+2);
- print(post_script(bp));
- append_char(13); {a forced \ps\ newline }
- print(cur_exp);
- post_script(bp):=make_string;
- delete_str_ref(s);
- selector:=old_setting;
- end
- else
- post_script(bp):=cur_exp;
- cur_type:=vacuous;
- end;
- end
- else begin if dp=void then @<Make |dp| a stroked node in list~|p|@>;
- if dp<>null then
- begin if dash_p(dp)<>null then delete_edge_ref(dash_p(dp));
- dash_p(dp):=make_dashes(cur_exp);
- dash_scale(dp):=unity;
- cur_type:=vacuous;
- end;
- end;
- end;
- @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
- of the list@>;
-end;
-
-@ @<Complain about improper type@>=
-begin 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 then
- help_line[1]:="Next time say `withprescript <known string expression>';"
-else if t=with_post_script then
- help_line[1]:="Next time say `withpostscript <known string expression>';"
-else if t=picture_type then
- help_line[1]:="Next time say `dashed <known picture expression>';"
-else if t=uninitialized_model then
- help_line[1]:="Next time say `withcolor <known color expression>';"
-else if t=rgb_model then
- help_line[1]:="Next time say `withrgbcolor <known color expression>';"
-else if t=cmyk_model then
- help_line[1]:="Next time say `withcmykcolor <known cmykcolor expression>';"
-else if t=grey_model then
- help_line[1]:="Next time say `withgreyscale <known numeric expression>';";
-put_get_flush_error(0);
-end
-
-@ 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|@>=
-begin if cur_type=color_type then
- @<Transfer a rgbcolor from the current expression to object~|cp|@>
-else if cur_type=cmykcolor_type then
- @<Transfer a cmykcolor from the current expression to object~|cp|@>
-else if cur_type=known then
- @<Transfer a greyscale from the current expression to object~|cp|@>
-else if cur_exp=false_code then
- @<Transfer a noncolor from the current expression to object~|cp|@>;
-end
-
-@ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
-begin q:=value(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):=rgb_model;
-if red_val(cp)<0 then red_val(cp):=0;
-if green_val(cp)<0 then green_val(cp):=0;
-if blue_val(cp)<0 then blue_val(cp):=0;
-if red_val(cp)>unity then red_val(cp):=unity;
-if green_val(cp)>unity then green_val(cp):=unity;
-if blue_val(cp)>unity then blue_val(cp):=unity;
-end
-
-@ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
-begin q:=value(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):=cmyk_model;
-if cyan_val(cp)<0 then cyan_val(cp):=0;
-if magenta_val(cp)<0 then magenta_val(cp):=0;
-if yellow_val(cp)<0 then yellow_val(cp):=0;
-if black_val(cp)<0 then black_val(cp):=0;
-if cyan_val(cp)>unity then cyan_val(cp):=unity;
-if magenta_val(cp)>unity then magenta_val(cp):=unity;
-if yellow_val(cp)>unity then yellow_val(cp):=unity;
-if black_val(cp)>unity then black_val(cp):=unity;
-end
-
-@ @<Transfer a greyscale from the current expression to object~|cp|@>=
-begin q:=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):=grey_model;
-if grey_val(cp)<0 then grey_val(cp):=0;
-if grey_val(cp)>unity then grey_val(cp):=unity;
-end
-
-@ @<Transfer a noncolor from the current expression to object~|cp|@>=
-begin
-cyan_val(cp):=0;
-magenta_val(cp):=0;
-yellow_val(cp):=0;
-black_val(cp):=0;
-grey_val(cp):=0;
-color_model(cp):=no_model;
-end
-
-@ It is a bit silly to repeat this action in five different
-forms with the only difference being the label. Ah well.
-
-@<Make |cp| a colored object in object list~|p|@>=
-begin cp:=p;
-while cp<>null do
- begin if has_color(cp) then goto done;
- cp:=link(cp);
- end;
-done:do_nothing;
-end
-
-@ @<Make |cp| a rgb colored object in object list~|p|@>=
-begin cp:=p;
-while cp<>null do
- begin if has_color(cp) then goto done6;
- cp:=link(cp);
- end;
-done6:do_nothing;
-end
-
-@ @<Make |cp| a cmyk colored object in object list~|p|@>=
-begin cp:=p;
-while cp<>null do
- begin if has_color(cp) then goto done5;
- cp:=link(cp);
- end;
-done5:do_nothing;
-end
-
-@ @<Make |cp| a grey colored object in object list~|p|@>=
-begin cp:=p;
-while cp<>null do
- begin if has_color(cp) then goto done4;
- cp:=link(cp);
- end;
-done4:do_nothing;
-end
-
-@ @<Make |cp| a no colored object in object list~|p|@>=
-begin cp:=p;
-while cp<>null do
- begin if has_color(cp) then goto done3;
- cp:=link(cp);
- end;
-done3:do_nothing;
-end
-
-@ @<Make |pp| an object in list~|p| that needs a pen@>=
-begin pp:=p;
-while pp<>null do
- begin if has_pen(pp) then goto done1;
- pp:=link(pp);
- end;
-done1:do_nothing;
-end
-
-@ @<Make |dp| a stroked node in list~|p|@>=
-begin dp:=p;
-while dp<>null do
- begin if type(dp)=stroked_code then goto done2;
- dp:=link(dp);
- end;
-done2:do_nothing;
-end
-
-@ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
-@<Copy |cp|'s color into the colored objects linked to~|cp|@>;
-if pp>void then
- @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
-if dp>void then @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>
-
-@ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
-begin q:=link(cp);
-while q<>null do
- begin if has_color(q) then
- begin 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);@/
- end;
- q:=link(q);
- end;
-end
-
-@ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
-begin q:=link(pp);
-while q<>null do
- begin if has_pen(q) then
- begin if pen_p(q)<>null then toss_knot_list(pen_p(q));
- pen_p(q):=copy_pen(pen_p(pp));
- end;
- q:=link(q);
- end;
-end
-
-@ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
-begin q:=link(dp);
-while q<>null do
- begin if type(q)=stroked_code then
- begin if dash_p(q)<>null then delete_edge_ref(dash_p(q));
- dash_p(q):=dash_p(dp);
- dash_scale(q):=unity;
- if dash_p(q)<>null then add_edge_ref(dash_p(q));
- end;
- q:=link(q);
- end;
-end
-
-@ 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|@>=
-function find_edges_var(@!t:pointer):pointer;
-var @!p:pointer;
-@!cur_edges:pointer; {the return value}
-begin p:=find_variable(t); cur_edges:=null;
-if p=null then
- begin obliterated(t); put_get_error;
- end
-else if type(p)<>picture_type then
- begin print_err("Variable "); show_token_list(t,null,1000,0);
-@.Variable x is the wrong type@>
- print(" is the wrong type ("); print_type(type(p)); print_char(")");
- help2("I was looking for a ""known"" picture variable.")@/
- ("So I'll not change anything just now."); put_get_error;
- end
-else begin value(p):=private_edges(value(p));
- cur_edges:=value(p);
- end;
-flush_node_list(t);
-find_edges_var:=cur_edges;
-end;
-
-@ @<Cases of |do_statement|...@>=
-add_to_command: do_add_to;
-bounds_command:do_bounds;
-
-@ @<Put each...@>=
-primitive("clip",bounds_command,start_clip_code);@/
-@!@:clip_}{\&{clip} primitive@>
-primitive("setbounds",bounds_command,start_bounds_code);@/
-@!@:set_bounds_}{\&{setbounds} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-bounds_command: if m=start_clip_code then print("clip")
- else print("setbounds");
-
-@ 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...@>=
-@!last_add_type:quarterword;
- {command modifier that identifies the last \&{addto} command}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-function start_draw_cmd(@!sep:quarterword):pointer;
-var @!lhv:pointer; {variable to add to left}
-@!add_type:quarterword; {value to be returned in |last_add_type|}
-begin lhv:=null; add_type:=0;
-get_x_next; var_flag:=sep; scan_primary;
-if cur_type<>token_list then
- @<Abandon edges command because there's no variable@>
-else begin lhv:=cur_exp; add_type:=cur_mod;@/
- cur_type:=vacuous; get_x_next; scan_expression;
- end;
-last_add_type:=add_type;
-start_draw_cmd:=lhv;
-end;
-
-@ @<Abandon edges command because there's no variable@>=
-begin 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.");
-put_get_flush_error(0);
-end
-
-@ Here is an example of how to use |start_draw_cmd|.
-
-@<Declare action procedures for use by |do_statement|@>=
-procedure do_bounds;
-var @!lhv,@!lhe:pointer; {variable on left, the corresponding edge structure}
-@!p:pointer; {for list manipulation}
-@!m:integer; {initial value of |cur_mod|}
-begin m:=cur_mod;
-lhv:=start_draw_cmd(to_token);@/
-if lhv<>null then
- begin lhe:=find_edges_var(lhv);
- if lhe=null then flush_cur_exp(0)
- else if cur_type<>path_type then
- begin exp_err("Improper `clip'");
-@.Improper `addto'@>
- help2("This expression should have specified a known path.")@/
- ("So I'll not change anything just now."); put_get_flush_error(0);
- end
- else if left_type(cur_exp)=endpoint then @<Complain about a non-cycle@>
- else @<Make |cur_exp| into a \&{setbounds} or clipping path and add
- it to |lhe|@>;
- end;
-end;
-
-@ @<Complain about a non-cycle@>=
-begin 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."); put_get_error;
-end
-
-@ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
-begin p:=new_bounds_node(cur_exp,m);
-link(p):=link(dummy_loc(lhe));
-link(dummy_loc(lhe)):=p;@/
-if obj_tail(lhe)=dummy_loc(lhe) then obj_tail(lhe):=p;
-p:=get_node(gr_object_size[stop_type(m)]);
-type(p):=stop_type(m);
-link(obj_tail(lhe)):=p;
-obj_tail(lhe):=p;@/
-init_bbox(lhe);
-end
-
-@ 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|@>=
-procedure do_add_to;
-var @!lhv,@!lhe:pointer; {variable on left, the corresponding edge structure}
-@!p:pointer; {the graphical object or list for |scan_with_list| to update}
-@!e:pointer; {an edge structure to be merged}
-@!add_type:quarterword; {|also_code|, |contour_code|, or |double_path_code|}
-begin lhv:=start_draw_cmd(thing_to_add); add_type:=last_add_type;@/
-if lhv<>null then
- begin if add_type=also_code then
- @<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@>;
- scan_with_list(p);
- @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
- end;
-end;
-
-@ 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|...@>=
-begin p:=null; e:=null;
-if cur_type<>picture_type then
- begin exp_err("Improper `addto'");
-@.Improper `addto'@>
- help2("This expression should have specified a known picture.")@/
- ("So I'll not change anything just now."); put_get_flush_error(0);
- end
-else begin e:=private_edges(cur_exp); cur_type:=vacuous;
- p:=link(dummy_loc(e));
- end;
-end
-
-@ 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...@>=
-begin e:=null; p:=null;
-if cur_type=pair_type then pair_to_path;
-if cur_type<>path_type then
- begin exp_err("Improper `addto'");
-@.Improper `addto'@>
- help2("This expression should have specified a known path.")@/
- ("So I'll not change anything just now."); put_get_flush_error(0);
- end
-else if add_type=contour_code then
- if left_type(cur_exp)=endpoint then
- @<Complain about a non-cycle@>
- else begin p:=new_fill_node(cur_exp);
- cur_type:=vacuous;
- end
- else begin p:=new_stroked_node(cur_exp);
- cur_type:=vacuous;
- end;
-end
-
-@ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
-lhe:=find_edges_var(lhv);
-if lhe=null then
- begin if (e=null)and(p<>null) then e:=toss_gr_object(p);
- if e<>null then delete_edge_ref(e);
- end
-else if add_type=also_code then
- if e<>null then @<Merge |e| into |lhe| and delete |e|@>
- else do_nothing
-else if p<>null then
- begin link(obj_tail(lhe)):=p;
- obj_tail(lhe):=p;
- if add_type=double_path_code then
- if pen_p(p)=null then pen_p(p):=get_pen_circle(0);
- end
-
-@ @<Merge |e| into |lhe| and delete |e|@>=
-begin if link(dummy_loc(e))<>null then
- begin 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;
- flush_dash_list(lhe);
- end;
-toss_edges(e);
-end
-
-@ @<Cases of |do_statement|...@>=
-ship_out_command: do_ship_out;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-@t\4@>@<Declare the function called |tfm_check|@>@;
-@t\4@>@<Declare the \ps\ output procedures@>@;
-procedure do_ship_out;
-var @!c:integer; {the character code}
-begin get_x_next; scan_expression;
-if cur_type<>picture_type then
- @<Complain that it's not a known picture@>
-else begin c:=round_unscaled(internal[char_code]) mod 256;
- if c<0 then c:=c+256;
- @<Store the width information for character code~|c|@>;@/
- ship_out(cur_exp);
- flush_cur_exp(0);
- end;
-end;
-
-@ @<Complain that it's not a known picture@>=
-begin exp_err("Not a known picture");
-help1("I can only output known pictures.");
-put_get_flush_error(0);
-end
-
-@ The \&{everyjob} command simply assigns a nonzero value to the global variable
-|start_sym|.
-
-@<Cases of |do_statement|...@>=
-every_job_command: begin get_symbol; start_sym:=cur_sym; get_x_next;
- end;
-
-@ @<Glob...@>=
-@!start_sym:halfword; {a symbolic token to insert at beginning of job}
-
-@ @<Set init...@>=
-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(#)== g := pool_ptr;
- print_int(#); g := pool_ptr-g;
- if f>g then begin
- pool_ptr := pool_ptr - g;
- while f>g do begin
- print_char("0");
- decr(f);
- end;
- print_int(#);
- end;
- f := 0
-
-@<Put each...@>=
-primitive("message",message_command,message_code);@/
-@!@:message_}{\&{message} primitive@>
-primitive("errmessage",message_command,err_message_code);@/
-@!@:err_message_}{\&{errmessage} primitive@>
-primitive("errhelp",message_command,err_help_code);@/
-@!@:err_help_}{\&{errhelp} primitive@>
-primitive("filenametemplate",message_command,filename_template_code);@/
-@!@:filename_template_}{\&{filenametemplate} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-message_command: if m<err_message_code then print("message")
- else if m=err_message_code then print("errmessage")
- else if m=filename_template_code then print("filenametemplate")
- else print("errhelp");
-
-@ @<Cases of |do_statement|...@>=
-message_command: do_message;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-@<Declare a procedure called |no_string_err|@>@;
-procedure do_message;
-var @!m:message_code..err_help_code; {the type of message}
-begin m:=cur_mod; get_x_next; scan_expression;
-if cur_type<>string_type then
- no_string_err("A message should be a known string expression.")
-else case m of
- message_code:begin print_nl(""); print(cur_exp);
- end;
- err_message_code:@<Print string |cur_exp| as an error message@>;
- err_help_code:@<Save string |cur_exp| as the |err_help|@>;
- filename_template_code:@<Save the filename template@>;
- end; {there are no other cases}
-flush_cur_exp(0);
-end;
-
-@ @<Declare a procedure called |no_string_err|@>=
-procedure no_string_err(s:str_number);
-begin exp_err("Not a string");
-@.Not a string@>
-help1(s);
-put_get_error;
-end;
-
-@ 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|@>=
-begin if err_help<>0 then delete_str_ref(err_help);
-if length(cur_exp)=0 then err_help:=0
-else begin err_help:=cur_exp; add_str_ref(err_help);
- end;
-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 |cur_exp| as an error message@>=
-begin print_err(""); print(cur_exp);
-if err_help<>0 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 Miss Marple: Examine all clues,")@/
-@^Marple, Jane@>
- ("and deduce the truth by inspired guesses.");
- end;
-put_get_error; use_err_help:=false;
-end
-
-@ @<Cases of |do_statement|...@>=
-write_command: do_write;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_write;
-label continue;
-var @!t:str_number; {the line of text to be written}
- @!n,@!n0:write_index; {for searching |wr_fname| and |wr_file| arrays}
- @!old_setting:0..max_selector; {for saving |selector| during output}
-begin get_x_next;
-scan_expression;
-if cur_type<>string_type then
- no_string_err("The text to be written should be a known string expression")
-else if cur_cmd<>to_token then
- begin print_err("Missing `to' clause");
- help1("A write command should end with `to <filename>'");
- put_get_error;
- end
-else begin t:=cur_exp; cur_type:=vacuous;
- get_x_next;
- scan_expression;
- if cur_type<>string_type then
- no_string_err("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);
- end;
-flush_cur_exp(0);
-end;
-
-@ @<Write |t| to the file named by |cur_exp|@>=
-begin @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
- |cur_exp| must be inserted@>;
-@<Make sure |eof_line| is initialized@>;
-if str_vs_str(t,eof_line)=0 then
- @<Record the end of file on |wr_file[n]|@>
-else begin old_setting:=selector;
- selector:=n;
- print(t); print_ln;
- selector := old_setting;
- end;
-end
-
-@ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
-n:=write_files;
-n0:=write_files;
-repeat
-continue:if n=0 then
- @<Insert |cur_exp| at index |n0| and call |open_write_file|@>
-else begin decr(n);
- if wr_fname[n]=0 then
- begin n0:=n; goto continue;
- end;
- end;
-until str_vs_str(cur_exp,wr_fname[n])=0
-
-@ @<Insert |cur_exp| at index |n0| and call |open_write_file|@>=
-begin if n0=write_files then
- if write_files<max_write_files then incr(write_files)
- else overflow("write files",max_write_files);
-n:=n0;
-open_write_file(cur_exp,n);
-end
-
-@ @<Record the end of file on |wr_file[n]|@>=
-begin a_close(wr_file[n]);
-delete_str_ref(wr_fname[n]);
-wr_fname[n]:=0;
-if n=write_files-1 then write_files:=n;
-end
-
-
-@* \[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...@>=
-@!tfm_file:byte_file; {the font metric output goes here}
-@!metric_file_name: str_number; {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 having the informal specification
-$$\def\arr$[#1]#2${\&{array} $[#1]$ \&{of} #2}
-\tabskip\centering
-\halign to\displaywidth{\hfil\\{#}\tabskip=0pt&$\,:\,$\arr#\hfil
- \tabskip\centering\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, 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+min_quarterword
- {value indicating `\.{STOP}' in a lig/kern program}
-@d kern_flag=128+min_quarterword {op code for a kern step}
-@d skip_byte(#)==lig_kern[#].b0
-@d next_char(#)==lig_kern[#].b1
-@d op_byte(#)==lig_kern[#].b2
-@d rem_byte(#)==lig_kern[#].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(#)==exten[#].b0 {|top| piece in a recipe}
-@d ext_mid(#)==exten[#].b1 {|mid| piece in a recipe}
-@d ext_bot(#)==exten[#].b2 {|bot| piece in a recipe}
-@d ext_rep(#)==exten[#].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 @'40 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 undefined_label==lig_table_size {an undefined local label}
-
-@<Glob...@>=
-@!bc,@!ec:eight_bits; {smallest and largest character codes shipped out}
-@!tfm_width:array[eight_bits] of scaled; {\&{charwd} values}
-@!tfm_height:array[eight_bits] of scaled; {\&{charht} values}
-@!tfm_depth:array[eight_bits] of scaled; {\&{chardp} values}
-@!tfm_ital_corr:array[eight_bits] of scaled; {\&{charic} values}
-@!char_exists:array[eight_bits] of boolean; {has this code been shipped out?}
-@!char_tag:array[eight_bits] of no_tag..ext_tag; {|remainder| category}
-@!char_remainder:array[eight_bits] of 0..lig_table_size; {the |remainder| byte}
-@!header_byte:array[1..header_size] of -1..255;
- {bytes of the \.{TFM} header, or $-1$ if unset}
-@!lig_kern:array[0..lig_table_size] of four_quarters; {the ligature/kern table}
-@!nl:0..32767-256; {the number of ligature/kern steps so far}
-@!kern:array[0..max_kerns] of scaled; {distinct kerning amounts}
-@!nk:0..max_kerns; {the number of distinct kerns so far}
-@!exten:array[eight_bits] of four_quarters; {extensible character recipes}
-@!ne:0..256; {the number of extensible characters so far}
-@!param:array[1..max_font_dimen] of scaled; {\&{fontinfo} parameters}
-@!np:0..max_font_dimen; {the largest \&{fontinfo} parameter specified so far}
-@!nw,@!nh,@!nd,@!ni:0..256; {sizes of \.{TFM} subtables}
-@!skip_table:array[eight_bits] of 0..lig_table_size; {local label status}
-@!lk_started:boolean; {has there been a lig/kern step in this command yet?}
-@!bchar:integer; {right boundary character}
-@!bch_label:0..lig_table_size; {left boundary starting location}
-@!ll,@!lll:0..lig_table_size; {registers used for lig/kern processing}
-@!label_loc:array[0..256] of -1..lig_table_size; {lig/kern starting addresses}
-@!label_char:array[1..256] of eight_bits; {characters for |label_loc|}
-@!label_ptr:0..256; {highest position occupied in |label_loc|}
-
-@ @<Set init...@>=
-for k:=0 to 255 do
- begin tfm_width[k]:=0; tfm_height[k]:=0; tfm_depth[k]:=0; tfm_ital_corr[k]:=0;
- char_exists[k]:=false; char_tag[k]:=no_tag; char_remainder[k]:=0;
- skip_table[k]:=undefined_label;
- end;
-for k:=1 to header_size do header_byte[k]:=-1;
-bc:=255; ec:=0; nl:=0; nk:=0; ne:=0; np:=0;@/
-internal[boundary_char]:=-unity;
-bch_label:=undefined_label;@/
-label_loc[0]:=-1; label_ptr:=0;
-
-@ @<Declare the function called |tfm_check|@>=
-function tfm_check(@!m:small_number):scaled;
-begin if abs(internal[m])>=fraction_half then
- begin print_err("Enormous "); print(int_name[m]);
-@.Enormous charwd...@>
-@.Enormous chardp...@>
-@.Enormous charht...@>
-@.Enormous charic...@>
-@.Enormous designsize...@>
- print(" has been reduced");
- help1("Font metric dimensions must be less than 2048pt.");
- put_get_error;
- if internal[m]>0 then tfm_check:=fraction_half-1
- else tfm_check:=1-fraction_half;
- end
-else tfm_check:=internal[m];
-end;
-
-@ @<Store the width information for character code~|c|@>=
-if c<bc then bc:=c;
-if c>ec then ec:=c;
-char_exists[c]:=true;
-tfm_width[c]:=tfm_check(char_wd);
-tfm_height[c]:=tfm_check(char_ht);
-tfm_depth[c]:=tfm_check(char_dp);
-tfm_ital_corr[c]:=tfm_check(char_ic)
-
-@ Now let's consider \MP's special \.{TFM}-oriented commands.
-
-@<Cases of |do_statement|...@>=
-tfm_command: do_tfm_command;
-
-@ @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...@>=
-primitive("charlist",tfm_command,char_list_code);@/
-@!@:char_list_}{\&{charlist} primitive@>
-primitive("ligtable",tfm_command,lig_table_code);@/
-@!@:lig_table_}{\&{ligtable} primitive@>
-primitive("extensible",tfm_command,extensible_code);@/
-@!@:extensible_}{\&{extensible} primitive@>
-primitive("headerbyte",tfm_command,header_byte_code);@/
-@!@:header_byte_}{\&{headerbyte} primitive@>
-primitive("fontdimen",tfm_command,font_dimen_code);@/
-@!@:font_dimen_}{\&{fontdimen} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-tfm_command: case m of
- char_list_code:print("charlist");
- lig_table_code:print("ligtable");
- extensible_code:print("extensible");
- header_byte_code:print("headerbyte");
- othercases print("fontdimen")
- endcases;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-function get_code:eight_bits; {scans a character code value}
-label found;
-var @!c:integer; {the code value found}
-begin get_x_next; scan_expression;
-if cur_type=known then
- begin c:=round_unscaled(cur_exp);
- if c>=0 then if c<256 then goto found;
- end
-else if cur_type=string_type then if length(cur_exp)=1 then
- begin c:=so(str_pool[str_start[cur_exp]]); goto found;
- end;
-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.");
-put_get_flush_error(0); c:=0;
-found: get_code:=c;
-end;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure set_tag(@!c:halfword;@!t:small_number;@!r:halfword);
-begin if char_tag[c]=no_tag then
- begin char_tag[c]:=t; char_remainder[c]:=r;
- if t=lig_tag then
- begin incr(label_ptr); label_loc[label_ptr]:=r; label_char[label_ptr]:=c;
- end;
- end
-else @<Complain about a character tag conflict@>;
-end;
-
-@ @<Complain about a character tag conflict@>=
-begin print_err("Character ");
-if (c>" ")and(c<127) then print(c)
-else if c=256 then print("||")
-else begin print("code "); print_int(c);
- end;
-print(" is already ");
-@.Character c is already...@>
-case char_tag[c] of
-lig_tag: print("in a ligtable");
-list_tag: print("in a charlist");
-ext_tag: print("extensible");
-end; {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.");
-put_get_error; end
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_tfm_command;
-label continue,done;
-var @!c,@!cc:0..256; {character codes}
-@!k:0..max_kerns; {index into the |kern| array}
-@!j:integer; {index into |header_byte| or |param|}
-begin case cur_mod of
-char_list_code: begin c:=get_code;
- {we will store a list of character successors}
- while cur_cmd=colon do
- begin cc:=get_code; set_tag(c,list_tag,cc); c:=cc;
- end;
- end;
-lig_table_code: @<Store a list of ligature/kern steps@>;
-extensible_code: @<Define an extensible recipe@>;
-header_byte_code, font_dimen_code: begin c:=cur_mod; get_x_next;
- scan_expression;
- if (cur_type<>known)or(cur_exp<half_unit) then
- begin 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.");
- put_get_error;
- end
- else begin j:=round_unscaled(cur_exp);
- if cur_cmd<>colon then
- begin missing_err(":");
-@.Missing `:'@>
- help1("A colon should follow a headerbyte or fontinfo location.");
- back_error;
- end;
- if c=header_byte_code then @<Store a list of header bytes@>
- else @<Store a list of font dimensions@>;
- end;
- end;
-end; {there are no other cases}
-end;
-
-@ @<Store a list of ligature/kern steps@>=
-begin lk_started:=false;
-continue: get_x_next;
-if(cur_cmd=skip_to)and lk_started then
- @<Process a |skip_to| command and |goto done|@>;
-if cur_cmd=bchar_label then
- begin c:=256; cur_cmd:=colon;@+end
-else begin back_input; c:=get_code;@+end;
-if(cur_cmd=colon)or(cur_cmd=double_colon)then
- @<Record a label in a lig/kern subprogram and |goto continue|@>;
-if cur_cmd=lig_kern_token then @<Compile a ligature/kern command@>
-else begin print_err("Illegal ligtable step");
-@.Illegal ligtable step@>
- help1("I was looking for `=:' or `kern' here.");
- back_error; next_char(nl):=qi(0); op_byte(nl):=qi(0); rem_byte(nl):=qi(0);@/
- skip_byte(nl):=stop_flag+1; {this specifies an unconditional stop}
- end;
-if nl=lig_table_size then overflow("ligtable size",lig_table_size);
-@:MetaPost capacity exceeded ligtable size}{\quad ligtable size@>
-incr(nl);
-if cur_cmd=comma then goto continue;
-if skip_byte(nl-1)<stop_flag then skip_byte(nl-1):=stop_flag;
-done:end
-
-@ @<Put each...@>=
-primitive("=:",lig_kern_token,0);
-@!@:=:_}{\.{=:} primitive@>
-primitive("=:|",lig_kern_token,1);
-@!@:=:/_}{\.{=:\char'174} primitive@>
-primitive("=:|>",lig_kern_token,5);
-@!@:=:/>_}{\.{=:\char'174>} primitive@>
-primitive("|=:",lig_kern_token,2);
-@!@:=:/_}{\.{\char'174=:} primitive@>
-primitive("|=:>",lig_kern_token,6);
-@!@:=:/>_}{\.{\char'174=:>} primitive@>
-primitive("|=:|",lig_kern_token,3);
-@!@:=:/_}{\.{\char'174=:\char'174} primitive@>
-primitive("|=:|>",lig_kern_token,7);
-@!@:=:/>_}{\.{\char'174=:\char'174>} primitive@>
-primitive("|=:|>>",lig_kern_token,11);
-@!@:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
-primitive("kern",lig_kern_token,128);
-@!@:kern_}{\&{kern} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-lig_kern_token: case m of
-0:print("=:");
-1:print("=:|");
-2:print("|=:");
-3:print("|=:|");
-5:print("=:|>");
-6:print("|=:>");
-7:print("|=:|>");
-11:print("|=:|>>");
-othercases print("kern")
-endcases;
-
-@ 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(#)==ll:=#;
- repeat lll:=qo(skip_byte(ll)); skip_byte(ll):=stop_flag; ll:=ll-lll;
- until lll=0
-@d skip_error(#)==begin print_err("Too far to skip");
-@.Too far to skip@>
- help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
- error; cancel_skips(#);
- end
-
-@<Process a |skip_to| command and |goto done|@>=
-begin c:=get_code;
-if nl-skip_table[c]>128 then
- begin skip_error(skip_table[c]); skip_table[c]:=undefined_label;
- end;
-if skip_table[c]=undefined_label then skip_byte(nl-1):=qi(0)
-else skip_byte(nl-1):=qi(nl-skip_table[c]-1);
-skip_table[c]:=nl-1; goto done;
-end
-
-@ @<Record a label in a lig/kern subprogram and |goto continue|@>=
-begin if cur_cmd=colon then
- if c=256 then bch_label:=nl
- else set_tag(c,lig_tag,nl)
-else if skip_table[c]<undefined_label then
- begin ll:=skip_table[c]; skip_table[c]:=undefined_label;
- repeat lll:=qo(skip_byte(ll));
- if nl-ll>128 then
- begin skip_error(ll); goto continue;
- end;
- skip_byte(ll):=qi(nl-ll-1); ll:=ll-lll;
- until lll=0;
- end;
-goto continue;
-end
-
-@ @<Compile a ligature/kern...@>=
-begin next_char(nl):=qi(c); skip_byte(nl):=qi(0);
-if cur_mod<128 then {ligature op}
- begin op_byte(nl):=qi(cur_mod); rem_byte(nl):=qi(get_code);
- end
-else begin get_x_next; scan_expression;
- if cur_type<>known then
- begin 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.");
- put_get_flush_error(0);
- end;
- kern[nk]:=cur_exp;
- k:=0;@+while kern[k]<>cur_exp do incr(k);
- if k=nk then
- begin if nk=max_kerns then overflow("kern",max_kerns);
-@:MetaPost capacity exceeded kern}{\quad kern@>
- incr(nk);
- end;
- op_byte(nl):=kern_flag+(k div 256);
- rem_byte(nl):=qi((k mod 256));
- end;
-lk_started:=true;
-end
-
-@ @d missing_extensible_punctuation(#)==
- begin missing_err(#);
-@.Missing `\char`\#'@>
- help1("I'm processing `extensible c: t,m,b,r'."); back_error;
- end
-
-@<Define an extensible recipe@>=
-begin if ne=256 then overflow("extensible",256);
-@:MetaPost capacity exceeded extensible}{\quad extensible@>
-c:=get_code; set_tag(c,ext_tag,ne);
-if cur_cmd<>colon then missing_extensible_punctuation(":");
-ext_top(ne):=qi(get_code);
-if cur_cmd<>comma then missing_extensible_punctuation(",");
-ext_mid(ne):=qi(get_code);
-if cur_cmd<>comma then missing_extensible_punctuation(",");
-ext_bot(ne):=qi(get_code);
-if cur_cmd<>comma then missing_extensible_punctuation(",");
-ext_rep(ne):=qi(get_code);
-incr(ne);
-end
-
-@ @<Store a list of header bytes@>=
-repeat if j>header_size then overflow("headerbyte",header_size);
-@:MetaPost capacity exceeded headerbyte}{\quad headerbyte@>
-header_byte[j]:=get_code; incr(j);
-until cur_cmd<>comma
-
-@ @<Store a list of font dimensions@>=
-repeat if j>max_font_dimen then overflow("fontdimen",max_font_dimen);
-@:MetaPost capacity exceeded fontdimen}{\quad fontdimen@>
-while j>np do
- begin incr(np); param[np]:=0;
- end;
-get_x_next; scan_expression;
-if cur_type<>known then
- begin exp_err("Improper font parameter");
-@.Improper font parameter@>
- help1("I'm zeroing this one. Proceed, with fingers crossed.");
- put_get_flush_error(0);
- end;
-param[j]:=cur_exp; incr(j);
-until 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
-
-@p function sort_in(@!v:scaled):pointer;
-label found;
-var @!p,@!q,@!r:pointer; {list manipulation registers}
-begin p:=temp_head;
-loop@+ begin q:=link(p);
- if v<=value(q) then goto found;
- p:=q;
- end;
-found: if v<value(q) then
- begin r:=get_node(value_node_size); value(r):=v; link(r):=q; link(p):=r;
- end;
-sort_in:=link(p);
-end;
-
-@ 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.
-
-@p function min_cover(@!d:scaled):integer;
-var @!p:pointer; {runs through the current list}
-@!l:scaled; {the least element covered by the current interval}
-@!m:integer; {lower bound on the size of the minimum cover}
-begin m:=0; p:=link(temp_head); perturbation:=el_gordo;
-while p<>inf_val do
- begin incr(m); l:=value(p);
- repeat p:=link(p);
- until value(p)>l+d;
- if value(p)-l<perturbation then perturbation:=value(p)-l;
- end;
-min_cover:=m;
-end;
-
-@ @<Glob...@>=
-@!perturbation:scaled; {quantity related to \.{TFM} rounding}
-@!excess:integer; {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.
-
-@p function threshold(@!m:integer):scaled;
-var @!d:scaled; {lower bound on the smallest interval size}
-begin excess:=min_cover(0)-m;
-if excess<=0 then threshold:=0
-else begin repeat d:=perturbation;
- until min_cover(d+d)<=m;
- while min_cover(d)>m do d:=perturbation;
- threshold:=d;
- end;
-end;
-
-@ 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|.
-
-@p function skimp(@!m:integer):integer;
-var @!d:scaled; {the size of intervals being coalesced}
-@!p,@!q,@!r:pointer; {list manipulation registers}
-@!l:scaled; {the least value in the current interval}
-@!v:scaled; {a compromise value}
-begin d:=threshold(m); perturbation:=0;
-q:=temp_head; m:=0; p:=link(temp_head);
-while p<>inf_val do
- begin incr(m); l:=value(p); info(p):=m;
- if value(link(p))<=l+d then
- @<Replace an interval of values by its midpoint@>;
- q:=p; p:=link(p);
- end;
-skimp:=m;
-end;
-
-@ @<Replace an interval...@>=
-begin repeat p:=link(p); info(p):=m;
-decr(excess);@+if excess=0 then d:=0;
-until value(link(p))>l+d;
-v:=l+halfp(value(p)-l);
-if value(p)-v>perturbation then perturbation:=value(p)-v;
-r:=q;
-repeat r:=link(r); value(r):=v;
-until r=p;
-link(q):=p; {remove duplicate values from the current list}
-end
-
-@ A warning message is issued whenever something is perturbed by
-more than 1/16\thinspace pt.
-
-@p procedure tfm_warning(@!m:small_number);
-begin print_nl("(some "); print(int_name[m]);
-@.some charwds...@>
-@.some chardps...@>
-@.some charhts...@>
-@.some charics...@>
-print(" values had to be adjusted by as much as ");
-print_scaled(perturbation); print("pt)");
-end;
-
-@ 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:=bc to ec do if char_exists[k] then
- tfm_width[k]:=sort_in(tfm_width[k]);
-nw:=skimp(255)+1; dimen_head[1]:=link(temp_head);
-if perturbation>=@'10000 then tfm_warning(char_wd)
-
-@ @<Glob...@>=
-@!dimen_head:array[1..4] of pointer; {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:=bc to ec do if char_exists[k] then
- if tfm_height[k]=0 then tfm_height[k]:=zero_val
- else tfm_height[k]:=sort_in(tfm_height[k]);
-nh:=skimp(15)+1; dimen_head[2]:=link(temp_head);
-if perturbation>=@'10000 then tfm_warning(char_ht);
-clear_the_list;
-for k:=bc to ec do if char_exists[k] then
- if tfm_depth[k]=0 then tfm_depth[k]:=zero_val
- else tfm_depth[k]:=sort_in(tfm_depth[k]);
-nd:=skimp(15)+1; dimen_head[3]:=link(temp_head);
-if perturbation>=@'10000 then tfm_warning(char_dp);
-clear_the_list;
-for k:=bc to ec do if char_exists[k] then
- if tfm_ital_corr[k]=0 then tfm_ital_corr[k]:=zero_val
- else tfm_ital_corr[k]:=sort_in(tfm_ital_corr[k]);
-ni:=skimp(63)+1; dimen_head[4]:=link(temp_head);
-if perturbation>=@'10000 then tfm_warning(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[design_size])|}
- < \\{three\_bytes}.$$
-
-@d three_bytes==@'100000000 {$2^{24}$}
-
-@p procedure fix_design_size;
-var @!d:scaled; {the design size}
-begin d:=internal[design_size];
-if (d<unity)or(d>=fraction_half) then
- begin if d<>0 then
- print_nl("(illegal design size has been changed to 128pt)");
-@.illegal design size...@>
- d:=@'40000000; internal[design_size]:=d;
- end;
-if header_byte[5]<0 then if header_byte[6]<0 then
- if header_byte[7]<0 then if header_byte[8]<0 then
- begin header_byte[5]:=d div @'4000000;
- header_byte[6]:=(d div 4096) mod 256;
- header_byte[7]:=(d div 16) mod 256;
- header_byte[8]:=(d mod 16)*16;
- end;
-max_tfm_dimen:=16*internal[design_size]-1-internal[design_size] div @'10000000;
-if max_tfm_dimen>=fraction_half then max_tfm_dimen:=fraction_half-1;
-end;
-
-@ 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.
-
-@p function dimen_out(@!x:scaled):integer;
-begin if abs(x)>max_tfm_dimen then
- begin incr(tfm_changed);
- if x>0 then x:=max_tfm_dimen@+else x:=-max_tfm_dimen;
- end;
-x:=make_scaled(x*16,internal[design_size]);
-dimen_out:=x;
-end;
-
-@ @<Glob...@>=
-@!max_tfm_dimen:scaled; {bound on widths, heights, kerns, etc.}
-@!tfm_changed:integer; {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@>
-
-@p procedure fix_check_sum;
-label exit;
-var @!k:eight_bits; {runs through character codes}
-@!b1,@!b2,@!b3,@!b4:eight_bits; {bytes of the check sum}
-@!x:integer; {hash value used in check sum computation}
-begin if header_byte[1]<0 then if header_byte[2]<0 then
- if header_byte[3]<0 then if header_byte[4]<0 then
- begin @<Compute a check sum in |(b1,b2,b3,b4)|@>;
- header_byte[1]:=b1; header_byte[2]:=b2;
- header_byte[3]:=b3; header_byte[4]:=b4; return;
- end;
-for k:=1 to 4 do if header_byte[k]<0 then header_byte[k]:=0;
-exit:end;
-
-@ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
-b1:=bc; b2:=ec; b3:=bc; b4:=ec; tfm_changed:=0;
-for k:=bc to ec do if char_exists[k] then
- begin x:=dimen_out(value(tfm_width[k]))+(k+4)*@'20000000; {this is positive}
- b1:=(b1+b1+x) mod 255;
- b2:=(b2+b2+x) mod 253;
- b3:=(b3+b3+x) mod 251;
- b4:=(b4+b4+x) mod 247;
- end
-
-@ Finally we're ready to actually write the \.{TFM} information.
-Here are some utility routines for this purpose.
-
-@d tfm_out(#)==write(tfm_file,#) {output one byte to |tfm_file|}
-
-@p procedure tfm_two(@!x:integer); {output two bytes to |tfm_file|}
-begin tfm_out(x div 256); tfm_out(x mod 256);
-end;
-@#
-procedure tfm_four(@!x:integer); {output four bytes to |tfm_file|}
-begin if x>=0 then tfm_out(x div three_bytes)
-else begin x:=x+@'10000000000; {use two's complement for negative values}
- x:=x+@'10000000000;
- tfm_out((x div three_bytes) + 128);
- end;
-x:=x mod three_bytes; tfm_out(x div unity);
-x:=x mod unity; tfm_out(x div @'400);
-tfm_out(x mod @'400);
-end;
-@#
-procedure tfm_qqqq(@!x:four_quarters); {output four quarterwords to |tfm_file|}
-begin tfm_out(qo(x.b0)); tfm_out(qo(x.b1)); tfm_out(qo(x.b2));
-tfm_out(qo(x.b3));
-end;
-
-@ @<Finish the \.{TFM} file@>=
-if job_name=0 then open_log_file;
-pack_job_name(".tfm");
-while not b_open_out(tfm_file) do
- prompt_file_name("file name for font metrics",".tfm");
-metric_file_name:=b_make_name_string(tfm_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@>;
-@!stat if internal[tracing_stats]>0 then
- @<Log the subfile sizes of the \.{TFM} file@>;@;@+tats@/
-print_nl("Font metrics written on "); print(metric_file_name); print_char(".");
-@.Font metrics written...@>
-b_close(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:=header_size;
-while header_byte[k]<0 do decr(k);
-lh:=(k+3) div 4; {this is the number of header words}
-if bc>ec then bc:=1; {if there are no characters, |ec=0| and |bc=1|}
-@<Compute the ligature/kern program offset and implant the
- left boundary label@>;
-tfm_two(6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+lk_offset+nk+ne+np);
- {this is the total number of file words that will be output}
-tfm_two(lh); tfm_two(bc); tfm_two(ec); tfm_two(nw); tfm_two(nh);
-tfm_two(nd); tfm_two(ni); tfm_two(nl+lk_offset); tfm_two(nk); tfm_two(ne);
-tfm_two(np);
-for k:=1 to 4*lh do
- begin if header_byte[k]<0 then header_byte[k]:=0;
- tfm_out(header_byte[k]);
- end
-
-@ @<Output the character information bytes...@>=
-for k:=bc to ec do
- if not char_exists[k] then tfm_four(0)
- else begin tfm_out(info(tfm_width[k])); {the width index}
- tfm_out((info(tfm_height[k]))*16+info(tfm_depth[k]));
- tfm_out((info(tfm_ital_corr[k]))*4+char_tag[k]);
- tfm_out(char_remainder[k]);
- end;
-tfm_changed:=0;
-for k:=1 to 4 do
- begin tfm_four(0); p:=dimen_head[k];
- while p<>inf_val do
- begin tfm_four(dimen_out(value(p))); p:=link(p);
- end;
- end
-
-@ 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...@>=
-bchar:=round_unscaled(internal[boundary_char]);
-if(bchar<0)or(bchar>255)then
- begin bchar:=-1; lk_started:=false; lk_offset:=0;@+end
-else begin lk_started:=true; lk_offset:=1;@+end;
-@<Find the minimum |lk_offset| and adjust all remainders@>;
-if bch_label<undefined_label then
- begin skip_byte(nl):=qi(255); next_char(nl):=qi(0);
- op_byte(nl):=qi(((bch_label+lk_offset)div 256));
- rem_byte(nl):=qi(((bch_label+lk_offset)mod 256));
- incr(nl); {possibly |nl=lig_table_size+1|}
- end
-
-@ @<Find the minimum |lk_offset|...@>=
-k:=label_ptr; {pointer to the largest unallocated label}
-if label_loc[k]+lk_offset>255 then
- begin lk_offset:=0; lk_started:=false; {location 0 can do double duty}
- repeat char_remainder[label_char[k]]:=lk_offset;
- while label_loc[k-1]=label_loc[k] do
- begin decr(k); char_remainder[label_char[k]]:=lk_offset;
- end;
- incr(lk_offset); decr(k);
- until lk_offset+label_loc[k]<256;
- {N.B.: |lk_offset=256| satisfies this when |k=0|}
- end;
-if lk_offset>0 then
- while k>0 do
- begin char_remainder[label_char[k]]
- :=char_remainder[label_char[k]]+lk_offset;
- decr(k);
- end
-
-@ @<Output the ligature/kern program@>=
-for k:=0 to 255 do if skip_table[k]<undefined_label then
- begin print_nl("(local label "); print_int(k); print(":: was missing)");
-@.local label l:: was missing@>
- cancel_skips(skip_table[k]);
- end;
-if lk_started then {|lk_offset=1| for the special |bchar|}
- begin tfm_out(255); tfm_out(bchar); tfm_two(0);
- end
-else for k:=1 to lk_offset do {output the redirection specs}
- begin ll:=label_loc[label_ptr];
- if bchar<0 then
- begin tfm_out(254); tfm_out(0);
- end
- else begin tfm_out(255); tfm_out(bchar);
- end;
- tfm_two(ll+lk_offset);
- repeat decr(label_ptr);
- until label_loc[label_ptr]<ll;
- end;
-for k:=0 to nl-1 do tfm_qqqq(lig_kern[k]);
-for k:=0 to nk-1 do tfm_four(dimen_out(kern[k]))
-
-@ @<Output the extensible character recipes...@>=
-for k:=0 to ne-1 do tfm_qqqq(exten[k]);
-for k:=1 to np do
- if k=1 then
- if abs(param[1])<fraction_half then tfm_four(param[1]*16)
- else begin incr(tfm_changed);
- if param[1]>0 then tfm_four(el_gordo)
- else tfm_four(-el_gordo);
- end
- else tfm_four(dimen_out(param[k]));
-if tfm_changed>0 then
- begin if tfm_changed=1 then print_nl("(a font metric dimension")
-@.a font metric dimension...@>
- else begin print_nl("("); print_int(tfm_changed);
-@.font metric dimensions...@>
- print(" font metric dimensions");
- end;
- print(" had to be decreased)");
- end
-
-@ @<Log the subfile sizes of the \.{TFM} file@>=
-begin wlog_ln(' ');
-if bch_label<undefined_label then decr(nl);
-wlog_ln('(You used ',nw:1,'w,',@| nh:1,'h,',@| nd:1,'d,',@| ni:1,'i,',@|
- nl:1,'l,',@| nk:1,'k,',@| ne:1,'e,',@|
- np:1,'p metric file positions');
-wlog_ln(' out of ',@| '256w,16h,16d,64i,',@|
- lig_table_size:1,'l,',max_kerns:1,'k,256e,',@|
- max_font_dimen:1,'p)');
-end
-
-@* \[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...@>=
-tfm_infile:byte_file;
-
-@ 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...@>=
-font_number=0..font_max;
-
-@ @<Glob...@>=
-font_info:array[0..font_mem_size] of memory_word;
- {height, width, and depth data}
-@!font_enc_name:array[font_number] of str_number;
- {encoding names, if any}
-@!font_ps_name_fixed:array[font_number] of boolean;
- {are the postscript names fixed already? }
-@!mp_font_map: ^fm_entry_ptr; {pointer into AVL tree of font mappings}
-next_fmem:0..font_mem_size; {next unused entry in |font_info|}
-last_fnum:font_number; {last font number used so far}
-font_dsize:array[font_number] of scaled;
- {16 times the ``design'' size in \ps\ points}
-font_name:array[font_number] of str_number;
- {name as specified in the \&{infont} command}
-font_ps_name:array[font_number] of str_number;
- {PostScript name for use when |internal[prologues]>0|}
-last_ps_fnum:font_number; {last valid |font_ps_name| index}
-font_bc,font_ec:array[font_number] of eight_bits;
- {first and last character code}
-
-@ 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...@>=
-char_base:array[font_number] of 0..font_mem_size;
- {base address for |char_info|}
-width_base:array[font_number] of 0..font_mem_size;
- {index for zeroth character width}
-height_base:array[font_number] of 0..font_mem_size;
- {index for zeroth character height}
-depth_base:array[font_number] of 0..font_mem_size;
- {index for zeroth character depth}
-
-@ 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}
-
-@<Initialize table...@>=
-font_dsize[null_font]:=0;
-font_name[null_font]:="";
-font_ps_name[null_font]:="";
-font_bc[null_font]:=1;
-font_ec[null_font]:=0;@/
-char_base[null_font]:=0;
-width_base[null_font]:=0;
-height_base[null_font]:=0;
-depth_base[null_font]:=0;@/
-next_fmem:=0;
-last_fnum:=null_font;
-last_ps_fnum:=null_font;
-
-@ Each |char_info| word is of type |four_quarters|. The |b0| field contains
-|min_quarter_word| plus 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(#)==#].qqqq
-@d char_info(#)==font_info[char_base[#]+char_info_end
-@d char_width_end(#)==#.b0].sc
-@d char_width(#)==font_info[width_base[#]+char_width_end
-@d char_height_end(#)==#.b1].sc
-@d char_height(#)==font_info[height_base[#]+char_height_end
-@d char_depth_end(#)==#.b2].sc
-@d char_depth(#)==font_info[depth_base[#]+char_depth_end
-@d ichar_exists(#)==(#.b0>min_quarterword)
-
-@ 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.
-
-@d bad_tfm=11 {go here if the \.{TFM} file is bad}
-
-@<Declare text measuring subroutines@>=
-@<Declare subroutines for parsing file names@>@;
-function read_font_info(fname:str_number):font_number;
-label bad_tfm,done;
-var @!file_opened:boolean; {has |tfm_infile| been opened?}
-@!n:font_number; {the number to return}
-@!lf,@!lh,@!bc,@!ec,@!nw,@!nh,@!nd:halfword; {subfile size parameters}
-@!whd_size:integer; {words needed for heights, widths, and depths}
-@!i,@!ii:0..font_mem_size; {|font_info| indices}
-@!jj:0..font_mem_size; {counts bytes to be ignored}
-@!z:scaled; {used to compute the design size}
-@!d:fraction;
- {height, width, or depth as a fraction of design size times $2^{-8}$}
-@!h_and_d:eight_bits; {height and depth indices being unpacked}
-begin 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 then b_close(tfm_infile);
-if n<>null_font then
- begin font_ps_name[n]:=fname;
- font_name[n]:=fname;
- str_ref[fname]:=max_str_ref;
- end;
-read_font_info:=n;
-end;
-
-@ \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 ");
-print(fname);
-if file_opened then print(" not usable: TFM file is bad")
-else print(" 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 then
- help_line[0]:="is right, try asking an expert to fix the TFM file";
-error
-
-@ @<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==get(tfm_infile)
-@d tfbyte==tfm_infile^
-@d read_two(#)==begin #:=tfbyte;
- if #>127 then goto bad_tfm;
- tfget; #:=#*@'400+tfbyte;
- end
-@d tf_ignore(#)==for jj:=# downto 1 do tfget
-
-@<Read the \.{TFM} size fields@>=
-read_two(lf);
-tfget; read_two(lh);
-tfget; read_two(bc);
-tfget; read_two(ec);
-if (bc>1+ec)or(ec>255) then 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<6+lh+whd_size then 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 next_fmem<bc+min_pool_ASCII then next_fmem:=bc+min_pool_ASCII;
- {ensure nonnegative |char_base|}
-if (last_fnum=font_max)or(next_fmem+whd_size>=font_mem_size) then
- @<Explain that there isn't enough space and |goto done|@>;
-incr(last_fnum);
-n:=last_fnum;
-font_bc[n]:=bc;
-font_ec[n]:=ec;
-char_base[n]:=next_fmem-bc-min_pool_ASCII;
-width_base[n]:=next_fmem+ec-bc+1-min_quarterword;
-height_base[n]:=width_base[n]+min_quarterword+nw;
-depth_base[n]:=height_base[n]+nh;
-next_fmem:=next_fmem+whd_size;
-
-@ @<Explain that there isn't enough space and |goto done|@>=
-begin print_err("Font ");
-print(fname);
-print(" not usable: Not enough space");
-help3("This `infont' operation won't produce anything because I")@/
- ("don't have enough room to store the character-size data for")@/
- ("the font. You may have to ask a wizard to enlarge me.");
-error;
-goto done;
-end
-
-@ @<Read the \.{TFM} header@>=
-if lh<2 then goto bad_tfm;
-tf_ignore(4);
-tfget; read_two(z);
-tfget; z:=z*@'400+tfbyte;
-tfget; z:=z*@'400+tfbyte; {now |z| is 16 times the design size}
-font_dsize[n]:=take_fraction(z,267432584);
- {times ${72\over72.27}2^{28}$ to convert from \TeX\ points}
-tf_ignore(4*(lh-2))
-
-@ @<Read the character data and the width, height, and depth tables...@>=
-ii:=width_base[n]+min_quarterword;
-i:=char_base[n]+min_pool_ASCII+bc;
-while i<ii do
- begin tfget; font_info[i].qqqq.b0:=qi(tfbyte);@/
- tfget; h_and_d:=tfbyte;
- font_info[i].qqqq.b1:=h_and_d div 16;
- font_info[i].qqqq.b2:=h_and_d mod 16;@/
- tfget; tfget;
- incr(i);
- end;
-while i<next_fmem do
- @<Read a four byte dimension, scale it by the design size, store it in
- |font_info[i]|, and increment |i|@>;
-if eof(tfm_infile) then goto bad_tfm;
-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...@>=
-begin tfget; d:=tfbyte;
-if d>=@'200 then d:=d-@'400;
-tfget; d:=d*@'400+tfbyte;@/
-tfget; d:=d*@'400+tfbyte;@/
-tfget; d:=d*@'400+tfbyte;@/
-font_info[i].sc:=take_fraction(d*16,font_dsize[n]);
-incr(i);
-end
-
-@ @<Open |tfm_infile| for input@>=
-file_opened:=false;
-str_scan_file(fname);
-if cur_area="" then cur_area:=MP_font_area;
-if cur_ext="" then cur_ext:=".tfm";
-pack_cur_name;
-if not b_open_in(tfm_infile) then 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@>=
-function find_font(@!f:str_number):font_number;
-label exit,found;
-var @!n:font_number;
-begin for n:=0 to last_fnum do
- if str_vs_str(f,font_name[n])=0 then goto found;
-find_font:=read_font_info(f);
-return;
-found:find_font:=n;
-exit:end;
-
-@ 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|@>=
-flush_cur_exp((font_dsize[find_font(cur_exp)]+8) div 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@>=
-procedure lost_warning(@!f:font_number;@!k:pool_pointer);
-begin if internal[tracing_lost_chars]>0 then
- begin begin_diagnostic;
- if selector=log_only then incr(selector);
- print_nl("Missing character: There is no ");
-@.Missing character@>
- print(so(str_pool[k])); print(" in font ");
- print(font_name[f]); print_char("!"); end_diagnostic(false);
- end;
-end;
-
-@ 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@>=
-procedure set_text_box(@!p:pointer);
-var @!f:font_number; {|font_n(p)|}
-@!bc,@!ec:pool_ASCII_code; {range of valid characters for font |f|}
-@!k,kk:pool_pointer; {current character and character to stop at}
-@!cc:four_quarters; {the |char_info| for the current character}
-@!h,@!d:scaled; {dimensions of the current character}
-begin width_val(p):=0;
-height_val(p):=-el_gordo;
-depth_val(p):=-el_gordo;@/
-f:=font_n(p);
-bc:=si(font_bc[f]);
-ec:=si(font_ec[f]);@/
-kk:=str_stop(text_p(p));
-k:=str_start[text_p(p)];
-while k<kk do
- @<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@>;
-end;
-
-@ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
-begin if (str_pool[k]<bc)or(str_pool[k]>ec) then lost_warning(f,k)
-else begin cc:=char_info(f)(str_pool[k]);
- if not ichar_exists(cc) then lost_warning(f,k)
- else begin 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) then height_val(p):=h;
- if d>depth_val(p) then depth_val(p):=d;
- end;
- end;
-incr(k);
-end
-
-@ 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) then
- begin height_val(p):=0;
- depth_val(p):=0;
- end
-
-@ The new primitives fontmapfile and fontmapline.
-
-@<Declare action procedures for use by |do_statement|@>=
-procedure do_mapfile;
-begin get_x_next; scan_expression;
-if cur_type<>string_type then @<Complain about improper map operation@>
-else mpmapfile(cur_exp);
-end;
-procedure do_mapline;
-begin get_x_next; scan_expression;
-if cur_type<>string_type then @<Complain about improper map operation@>
-else begin mpmapline(cur_exp);
- end;
-end;
-
-@ @<Complain about improper map operation@>=
-begin exp_err("Unsuitable expression");
-help1("Only known strings can be map files or map lines.");
-put_get_error;
-end
-
-@ the C code needs to know how to get at the null font, how remove
-a string from memory, etc.
-
-@d is_valid_char(#)==((font_bc[f] <= #) and (# <= font_ec[f]) and
- ichar_exists(char_info(f)(#)))
-
-@p function get_nullfont: font_number;
-begin
- get_nullfont := null_font;
-end;
-@#
-procedure flush_str(s: str_number); {flush a string if possible}
-begin
- flush_string(s);
-end;
-@#
-function get_nullstr: str_number;
-begin
- get_nullstr := "";
-end;
-@#
-function get_termandlogid: integer;
-begin
- get_termandlogid:=term_and_log;
-end;
-@#
-function get_charwidth(f: font_number; c: eight_bits): scaled;
-begin
- if is_valid_char(c) then
- get_charwidth := char_width(f)(char_info(f)(c))
- else
- get_charwidth := 0;
-end;
-@#
-function tfm_lookup(s: str_number; fs: scaled): font_number;
-{looks up for a TFM with name |s| loaded at |fs| size; if found then flushes |s|}
-var k: font_number;
-begin
- if fs <> 0 then begin { should not be used! }
- for k := null_font + 1 to last_fnum do
- if str_vs_str(font_name[k], s) and (font_sizes[k] = fs) then begin
- flush_str(s);
- tfm_lookup := k;
- return;
- end;
- end
- else begin
- for k := null_font + 1 to last_fnum do
- if str_vs_str(font_name[k], s) then begin
- flush_str(s);
- tfm_lookup := k;
- return;
- end;
- end;
- tfm_lookup := null_font;
- exit:
-end;
-@#
-function new_dummy_font: font_number;
-begin
- new_dummy_font := read_font_info("dummy");
-end;
-@#
-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;
-
-
-@
-@<Declare the \ps\ output procedures@>=
-procedure ps_print_cmd(@!l:str_number;@!s:str_number);
-begin
-if internal[mpprocset]>0 then begin ps_room(length(s)); print(s); end
-else begin ps_room(length(l)); print(l); end;
-end;
-@#
-procedure print_cmd(@!l:str_number;@!s:str_number);
-begin
-if internal[mpprocset]>0 then print(s) else print(l);
-end;
-@#
-function mp_char_marked(@!f:font_number;@!c: eight_bits): boolean;
-var @!b:integer; {|char_base[f]|}
-begin b:=char_base[f];
- if (c>=font_bc[f])and(c<=font_ec[f])and(font_info[b+c].qqqq.b3<>0) then
- mp_char_marked:=true
- else
- mp_char_marked:=false;
-end;
-
-@ The fontmap entries need a typedef
-
-@<Types...@>=
-fm_entry_ptr = ^integer;
-@!nonnegative_integer=0..@'17777777777; {$0\L x<2^{31}$}
-
-@ 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_bp: scaled; {scaled value corresponds to 1bp}
-@!one_hundred_bp: scaled; {scaled value corresponds to 100bp}
-@!one_hundred_inch: scaled; {scaled value corresponds to 100in}
-@!ten_pow: array[0..9] of integer; {$10^0..10^9$}
-@!scaled_out: integer; {amount of |scaled| that was taken out in
-|divide_scaled|}
-
-@ @<Set init...@>=
-one_bp := 65782; {65781.76}
-one_hundred_bp := 6578176;
-one_hundred_inch := 473628672;
-ten_pow[0] := 1;
-for i := 1 to 9 do
- ten_pow[i] := 10*ten_pow[i - 1];
-mp_font_map:=xmalloc_array(fm_entry_ptr,font_max);
-for i := null_font to font_max do begin
- font_enc_name[i] := 0;
- font_ps_name_fixed[i] := false;
- mp_font_map[i] := 0;
- end;
-
-
-
-@ The following function divides |s| by |m|. |dd| is number of decimal digits.
-
-@p function divide_scaled(s, m: scaled; dd: integer): scaled;
-var q, r: scaled;
- sign, i: integer;
-begin
- sign := 1;
- if s < 0 then begin
- sign := -sign;
- s := -s;
- end;
- if m < 0 then begin
- sign := -sign;
- m := -m;
- end;
- if m = 0 then
- confusion("arithmetic: divided by zero")
- else if m >= (max_integer div 10) then
- confusion("arithmetic: number too big");
- q := s div m;
- r := s mod m;
- for i := 1 to dd do begin
- q := 10*q + (10*r) div m;
- r := (10*r) mod m;
- end;
- if 2*r >= m then begin
- incr(q);
- r := r - m;
- end;
- scaled_out := sign*(s - (r div ten_pow[dd]));
- divide_scaled := sign*q;
-end;
-
-@ 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|. If the file |ps_tab_file|
-is missing, we assume that the existing font names are OK and nothing needs to
-be done.
-
-@<Declare the \ps\ output procedures@>=
-procedure read_psname_table;
-label common_ending, done;
-var @!k:font_number; {font for possible name match}
-@!lmax:integer; {upper limit on length of name to match}
-@!j:integer; {characters left to read before string gets too long}
-@!c:text_char; {character being read from |ps_tab_file|}
-@!s:str_number; {possible font name to match}
-begin name_of_file:=ps_tab_name;
-if a_open_in(ps_tab_file) then
- begin @<Set |lmax| to the maximum |font_name| length for fonts
- |last_ps_fnum+1| through |last_fnum|@>;
- while not eof(ps_tab_file) do
- begin @<Read at most |lmax| characters from |ps_tab_file| into string |s|
- but |goto common_ending| if there is trouble@>;
- for k:=last_ps_fnum+1 to last_fnum do
- if str_vs_str(s,font_name[k])=0 then
- @<|flush_string(s)|, read in |font_ps_name[k]|, and
- |goto common_ending|@>;
- flush_string(s);
-common_ending:read_ln(ps_tab_file);
- end;
- last_ps_fnum:=last_fnum;
- a_close(ps_tab_file);
- end;
-end;
-
-@ @<Glob...@>=
-@!ps_tab_file:alpha_file; {file for font name translation table}
-
-@ @<Set |lmax| to the maximum |font_name| length for fonts...@>=
-lmax:=0;
-for k:=last_ps_fnum+1 to last_fnum do
- if length(font_name[k])>lmax then lmax:=length(font_name[k])
-
-@ @<Read at most |lmax| characters from |ps_tab_file| into string |s|...@>=
-str_room(lmax);
-j:=lmax;
-loop @+begin if eoln(ps_tab_file) then
- fatal_error("The psfont map file is bad!");
- read(ps_tab_file,c);
- if c=' ' then goto done;
- decr(j);
- if j>=0 then append_char(xord[c])
- else begin flush_cur_string;
- goto common_ending;
- end;
- end;
-done:s:=make_string
-
-@ PostScript font names should be at most 28 characters long but we allow 32
-just to be safe.
-
-@<|flush_string(s)|, read in |font_ps_name[k]|, and...@>=
-begin flush_string(s);
-j:=32;
-str_room(j);
-repeat if eoln(ps_tab_file) then fatal_error("The psfont map file is bad!");
- read(ps_tab_file,c);
-until c<>' ';
-repeat decr(j);
- if j<0 then fatal_error("The psfont map file is bad!");
- append_char(xord[c]);
- if eoln(ps_tab_file) then c:=' ' @+else read(ps_tab_file,c);
-until c=' ';
-delete_str_ref(font_ps_name[k]);
-font_ps_name[k]:=make_string;
-goto common_ending;
-end
-
-@* \[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@>
-
-@<Declare the \ps\ output procedures@>=
-procedure open_output_file;
-label @!continue; { after a digit is seen}
-var @!c:integer; {\&{charcode} rounded to the nearest integer}
-@!old_setting:0..max_selector; {previous |selector| setting}
-@!s,n:str_number; {a file extension derived from |c|}
-@!i:pool_pointer; { indexes into |filename_template| }
-@!cc:integer; {a temporary integer for template building }
-@!f,g:integer; {field widths}
-begin if job_name=0 then open_log_file;
-c:=round_unscaled(internal[char_code]);
-if filename_template=0 then begin
- if c<0 then s:=".ps"
- else @<Use |c| to compute the file extension |s|@>;
- pack_job_name(s);
- while not a_open_out(ps_file) do
- prompt_file_name("file name for output",s);
- end
-else begin
- {initializations}
- s := "";
- n := "";
- old_setting:=selector; selector:=new_string;
- f := 0;
- i := str_start[filename_template];
- while i<str_stop(filename_template) do begin
- if so(str_pool[i])="%" then begin
- continue:
- incr(i);
- if i<str_stop(filename_template) then
- begin
- if so(str_pool[i])="j" then
- print(job_name)
- else if so(str_pool[i])="d" then begin
- cc:= round_unscaled(internal[day]);
- print_with_leading_zeroes(cc);
- end
- else if so(str_pool[i])="m" then begin
- cc:= round_unscaled(internal[month]);
- print_with_leading_zeroes(cc);
- end
- else if so(str_pool[i])="y" then begin
- cc:= round_unscaled(internal[year]);
- print_with_leading_zeroes(cc);
- end
- else if so(str_pool[i])="H" then begin
- cc:= round_unscaled(internal[time]) div 60;
- print_with_leading_zeroes(cc);
- end
- else if so(str_pool[i])="M" then begin
- cc:= round_unscaled(internal[time]) mod 60;
- print_with_leading_zeroes(cc);
- end
- else if so(str_pool[i])="c" then begin
- if c<0 then print("ps")
- else begin
- print_with_leading_zeroes(c);
- end;
- end
- else if (so(str_pool[i])>="0") and (so(str_pool[i])<="9") then begin
- if (f<10) then
- f := (f*10) + so(str_pool[i])-"0";
- goto continue;
- end
- else
- print(str_pool[i])
- end
- end
- else begin
- if so(str_pool[i])="." then
- if n="" then
- n := make_string;
- print(str_pool[i]);
- end;
- incr(i);
- end;
- s := make_string;
- selector:= old_setting;
- if n="" then begin
- n:=s;
- s:="";
- end;
- pack_file_name(n,"",s);
- while not a_open_out(ps_file) do
- prompt_file_name("file name for output",s);
- delete_str_ref(n);
- end;
-delete_str_ref(s);
-@<Store the true output file name if appropriate@>;
-@<Begin the progress report for the ouput of picture~|c|@>;
-end;
-
-@ 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|@>=
-begin old_setting:=selector; selector:=new_string;
-print_char("."); print_int(c);
-s:=make_string;
-selector:=old_setting;
-end
-
-@ 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<first_output_code)and(first_output_code>=0) then
- begin first_output_code:=c;
- delete_str_ref(first_file_name);
- first_file_name:=a_make_name_string(ps_file);
- end;
-if c>=last_output_code then
- begin last_output_code:=c;
- delete_str_ref(last_file_name);
- last_file_name:=a_make_name_string(ps_file);
- end
-
-@ @<Glob...@>=
-@!first_file_name,@!last_file_name:str_number; {full file names}
-@!first_output_code,@!last_output_code:integer; {rounded \&{charcode} values}
-@:char_code_}{\&{charcode} primitive@>
-@!total_shipped:integer; {total number of |ship_out| operations completed}
-
-@ @<Set init...@>=
-first_file_name:="";
-last_file_name:="";@/
-first_output_code:=32768;
-last_output_code:=-32768;@/
-total_shipped:=0;
-
-@ @<Begin the progress report for the ouput of picture~|c|@>=
-if term_offset>max_print_line-6 then print_ln
-else if (term_offset>0)or(file_offset>0) then print_char(" ");
-print_char("[");
-if c>=0 then print_int(c)
-
-@ @<End progress report@>=
-print_char("]");
-update_terminal;
-incr(total_shipped)
-
-@ @<Explain what output files were written@>=
-if total_shipped>0 then
- begin print_nl("");
- print_int(total_shipped);
- print(" output file");
- if total_shipped>1 then print_char("s");
- print(" written: ");
- print(first_file_name);
- if total_shipped>1 then
- begin if 31+length(first_file_name)+length(last_file_name)>@|
- max_print_line
- then print_ln;
- print(" .. ");
- print(last_file_name);
- end;
- end
-
-@ We often need to print a pair of coordinates.
-
-@d ps_room(#)==if ps_offset+#>max_print_line then print_ln {optional line break}
-
-@<Declare the \ps\ output procedures@>=
-procedure ps_pair_out(@!x,@!y:scaled);
-begin ps_room(26);
-print_scaled(x); print_char(" ");
-print_scaled(y); print_char(" ")
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-procedure ps_print(@!s:str_number);
-begin ps_room(length(s));
-print(s);
-end;
-
-@ The most important output procedure is the one that gives the \ps\ version of
-a \MP\ path.
-
-@<Declare the \ps\ output procedures@>=
-procedure ps_path_out(@!h:pointer);
-label exit;
-var @!p,@!q:pointer; {for scanning the path}
-@!d:scaled; {a temporary value}
-@!curved:boolean; {|true| unless the cubic is almost straight}
-begin ps_room(40);
-if need_newpath then print_cmd("newpath ","n ");
-need_newpath:=true;
-ps_pair_out(x_coord(h),y_coord(h));
-print_cmd("moveto","m");@/
-p:=h;
-repeat if right_type(p)=endpoint then
- begin if p=h then ps_print_cmd(" 0 0 rlineto"," 0 0 r");
- return;
- end;
-q:=link(p);
-@<Start a new line and print the \ps\ commands for the curve from
- |p| to~|q|@>;
-p:=q;
-until p=h;
-ps_print_cmd(" closepath"," p");
-exit:end;
-
-@ @<Glob...@>=
-need_newpath:boolean;
- {will |ps_path_out| need to issue a \&{newpath} command next time}
-@:newpath_}{\&{newpath} command@>
-
-@ @<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@>;
-print_ln;
-if curved then
- begin ps_pair_out(right_x(p),right_y(p));
- ps_pair_out(left_x(q),left_y(q));
- ps_pair_out(x_coord(q),y_coord(q));
- ps_print_cmd("curveto","c");
- end
-else if q<>h then
- begin ps_pair_out(x_coord(q),y_coord(q));
- ps_print_cmd("lineto","l");
- end
-
-@ 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 right_x(p)=x_coord(p) then
- if right_y(p)=y_coord(p) then
- if left_x(q)=x_coord(q) then
- if left_y(q)=y_coord(q) then curved:=false;
-d:=left_x(q)-right_x(p);
-if abs(right_x(p)-x_coord(p)-d)<=bend_tolerance then
- if abs(x_coord(q)-left_x(q)-d)<=bend_tolerance then
- begin d:=left_y(q)-right_y(p);
- if abs(right_y(p)-y_coord(p)-d)<=bend_tolerance then
- if abs(y_coord(q)-left_y(q)-d)<=bend_tolerance then curved:=false;
- end
-
-@ 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_node_size=10
-@d gs_red ==mem[gs_state+1].sc
-@d gs_green ==mem[gs_state+2].sc
-@d gs_blue ==mem[gs_state+3].sc
-@d gs_black ==mem[gs_state+4].sc
- {color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command}
-@d gs_colormodel==mem[gs_state+5].qqqq.b0
- {the current colormodel}
-@d gs_ljoin ==mem[gs_state+5].qqqq.b1
-@d gs_lcap ==mem[gs_state+5].qqqq.b2
- {values from the last \&{setlinejoin} and \&{setlinecap} commands}
-@d gs_adj_wx ==mem[gs_state+5].qqqq.b3
- {what resolution-dependent adjustment applies to the width}
-@d gs_miterlim ==mem[gs_state+6].sc
- {the value from the last \&{setmiterlimit} command}
-@d gs_dash_p ==mem[gs_state+7].hh.lh
- {edge structure for last \&{setdash} command}
-@d gs_previous ==mem[gs_state+7].hh.rh
- {backlink to the previous |gs_state| structure}
-@d gs_dash_sc ==mem[gs_state+8].sc
- {scale factor used with |gs_dash_p|}
-@d gs_width ==mem[gs_state+9].sc
- {width setting or $-1$ if no \&{setlinewidth} command so far}
-
-@<Glob...@>=
-gs_state:pointer;
-
-@ @<Set init...@>=
-gs_state:=null;
-
-@ 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.
-
-@<Declare the \ps\ output procedures@>=
-procedure unknown_graphics_state(c:scaled);
-var @!p:pointer; {to shift graphic states around}
- @!k:quarterword; {a loop index for copying the |gs_state|}
-begin if (c=0)or(c=-1) then begin
- if gs_state=null then begin
- gs_state := get_node(gs_node_size);
- gs_previous:=null;
- end
- else begin
- while gs_previous<>null do begin
- p := gs_previous;
- free_node(gs_state,gs_node_size);
- gs_state:=p;
- end;
- end;
- gs_red:=c; gs_green:=c; gs_blue:=c; gs_black:=c;@/
- gs_colormodel:=uninitialized_model;
- gs_ljoin:=3;
- gs_lcap:=3;
- gs_miterlim:=0;@/
- gs_dash_p:=void;
- gs_dash_sc:=0;
- gs_width:=-1;
- end
-else if c=1 then begin
- p:= gs_state;
- gs_state := get_node(gs_node_size);
- for k:=1 to gs_node_size-1 do
- mem[gs_state+k]:=mem[p+k];
- gs_previous := p;
- end
-else if c=2 then begin
- p := gs_previous;
- free_node(gs_state,gs_node_size);
- gs_state:=p;
- end;
-end;
-
-@ 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.
-
-@<Declare the \ps\ output procedures@>=
-@<Declare subroutines needed by |fix_graphics_state|@>@;
-procedure fix_graphics_state(p:pointer);
- {get ready to output graphical object |p|}
-var @!hh,@!pp:pointer; {for list manipulation}
-@!wx,@!wy,@!ww:scaled; {dimensions of pen bounding box}
-@!adj_wx:boolean; {whether pixel rounding should be based on |wx| or |wy|}
-@!tx,@!ty:integer; {temporaries for computing |adj_wx|}
-@!scf:scaled; {a scale factor for the dash pattern}
-begin if has_color(p) then
- @<Make sure \ps\ will use the right color for object~|p|@>;
-if (type(p)=fill_code)or(type(p)=stroked_code) then
- if pen_p(p)<>null then
- if pen_is_elliptical(pen_p(p)) then
- begin @<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|@>;
- end;
-if ps_offset>0 then print_ln;
-end;
-
-@ @<Decide whether the line cap parameter matters and set it if necessary@>=
-if type(p)=stroked_code then
- if (left_type(path_p(p))=endpoint)or(dash_p(p)<>null) then
- if gs_lcap<>lcap_val(p) then
- begin ps_room(13);
- print_char(" ");
- print_char("0"+lcap_val(p)); print_cmd(" setlinecap"," lc");
- gs_lcap:=lcap_val(p);
- end
-
-@ @<Set the other numeric parameters as needed for object~|p|@>=
-if gs_ljoin<>ljoin_val(p) then
- begin ps_room(14);
- print_char(" ");
- print_char("0"+ljoin_val(p)); print_cmd(" setlinejoin"," lj");
- gs_ljoin:=ljoin_val(p);
- end;
-if gs_miterlim<>miterlim_val(p) then
- begin ps_room(27);
- print_char(" ");
- print_scaled(miterlim_val(p)); print_cmd(" setmiterlimit"," ml");
- gs_miterlim:=miterlim_val(p);
- end
-
-@ @<Make sure \ps\ will use the right color for object~|p|@>=
-begin
- if (color_model(p)=rgb_model)or@|
- ((color_model(p)=uninitialized_model)and
- ((internal[default_color_model] div unity)=rgb_model)) then
- begin if (gs_colormodel<>rgb_model)or(gs_red<>red_val(p))or@|
- (gs_green<>green_val(p))or(gs_blue<>blue_val(p)) then
- begin gs_red:=red_val(p);
- gs_green:=green_val(p);
- gs_blue:=blue_val(p);
- gs_black:= -1;@/
- gs_colormodel:=rgb_model;
- begin ps_room(36);
- print_char(" ");
- print_scaled(gs_red); print_char(" ");
- print_scaled(gs_green); print_char(" ");
- print_scaled(gs_blue);
- print_cmd(" setrgbcolor", " R");
- end;
- end;
- end
- else if (color_model(p)=cmyk_model)or@|
- ((color_model(p)=uninitialized_model)and
- ((internal[default_color_model] div unity)=cmyk_model)) then
- begin if (gs_red<>cyan_val(p))or(gs_green<>magenta_val(p))or@|
- (gs_blue<>yellow_val(p))or(gs_black<>black_val(p))or@|
- (gs_colormodel<>cmyk_model) then
- begin
- if color_model(p)=uninitialized_model then begin
- gs_red:=0;
- gs_green:=0;
- gs_blue:=0;
- gs_black:=unity;@/
- end
- else begin
- gs_red:=cyan_val(p);
- gs_green:=magenta_val(p);
- gs_blue:=yellow_val(p);
- gs_black:=black_val(p);@/
- end;
- gs_colormodel:=cmyk_model;
- begin ps_room(45);
- print_char(" ");
- print_scaled(gs_red); print_char(" ");
- print_scaled(gs_green); print_char(" ");
- print_scaled(gs_blue); print_char(" ");
- print_scaled(gs_black);
- print_cmd(" setcmykcolor"," C");
- end;
- end;
- end
- else if (color_model(p)=grey_model)or@|
- ((color_model(p)=uninitialized_model)and
- ((internal[default_color_model] div unity)=grey_model)) then
- begin if (gs_red<>grey_val(p))or(gs_colormodel<>grey_model) then
- begin gs_red := grey_val(p);
- gs_green:= -1;
- gs_blue:= -1;
- gs_black:= -1;@/
- gs_colormodel:=grey_model;
- begin ps_room(16);
- print_char(" ");
- print_scaled(gs_red);
- print_cmd(" setgray"," G");
- end;
- end;
- end;
- if color_model(p)=no_model then
- gs_colormodel:=no_model;
-end
-
-@ 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) or (adj_wx<>gs_adj_wx) then
- begin if adj_wx then
- begin ps_room(13);
- print_char(" "); print_scaled(ww);
- ps_print_cmd(" 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw");
- end
- else begin
- if internal[mpprocset]>0 then begin
- ps_room(13);
- print_char(" ");
- print_scaled(ww);
- ps_print(" vlw");
- end
- else begin ps_room(15);
- print(" 0 "); print_scaled(ww);
- ps_print(" dtransform truncate idtransform setlinewidth pop");
- end;
- end;
- gs_width := ww;
- gs_adj_wx := adj_wx;
- end
-
-@ @<Set |wx| and |wy| to the width and height of the bounding box for...@>=
-pp:=pen_p(p);
-if (right_x(pp)=x_coord(pp)) and (left_y(pp)=y_coord(pp)) then
- begin wx := abs(left_x(pp) - x_coord(pp));
- wy := abs(right_y(pp) - y_coord(pp));
- end
-else begin
- wx := pyth_add(left_x(pp)-x_coord(pp), right_x(pp)-x_coord(pp));
- wy := pyth_add(left_y(pp)-y_coord(pp), right_y(pp)-y_coord(pp));
- end
-
-@ 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}
-
-@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more...@>=
-tx:=1; ty:=1;
-if coord_rangeOK(path_p(p), y_loc(0), wy) then tx:=aspect_bound
-else if coord_rangeOK(path_p(p), x_loc(0), wx) then ty:=aspect_bound;
-if wy div ty>=wx div tx then
- begin ww:=wy; adj_wx:=false;
- end
-else begin ww:=wx; adj_wx:=true;
- end
-
-@ 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.
-
-@<Declare subroutines needed by |fix_graphics_state|@>=
-function coord_rangeOK(@!h:pointer; @!zoff:small_number; dz:scaled):boolean;
-label found, not_found, exit;
-var @!p:pointer; {for scanning the path form |h|}
- @!zlo,@!zhi:scaled; {coordinate range so far}
- @!z:scaled; {coordinate currently being tested}
-begin zlo:=knot_coord(h+zoff);
-zhi:=zlo;
-p:=h;
-while right_type(p)<>endpoint do
- begin z:=right_coord(p+zoff);@/
- @<Make |zlo..zhi| include |z| and |goto found| if |zhi-zlo>dz|@>;
- p:=link(p);
- z:=left_coord(p+zoff);@/
- @<Make |zlo..zhi| include |z| and |goto found| if |zhi-zlo>dz|@>;
- z:=knot_coord(p+zoff);@/
- @<Make |zlo..zhi| include |z| and |goto found| if |zhi-zlo>dz|@>;
- if p=h then goto not_found;
- end;
-not_found:coord_rangeOK:=true;
-return;
-found:coord_rangeOK:=false;
-exit:end;
-
-@ @<Make |zlo..zhi| include |z| and |goto found| if |zhi-zlo>dz|@>=
-if z<zlo then zlo:=z
-else if z>zhi then zhi:=z;
-if zhi-zlo>dz then goto found
-
-@ 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 type(p)=fill_code then hh:=null
-else begin hh:=dash_p(p);
- scf:=get_pen_scale(pen_p(p));
- if scf=0 then
- if gs_width=0 then scf:=dash_scale(p) @+else hh:=null
- else begin scf:=make_scaled(gs_width,scf);
- scf:=take_scaled(scf,dash_scale(p));
- end;
- end;
-if hh=null then
- begin if gs_dash_p<>null then
- begin ps_print_cmd(" [] 0 setdash"," rd");
- gs_dash_p:=null;
- end;
- end
-else if (gs_dash_sc<>scf) or not same_dashes(gs_dash_p,hh) then
- @<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>
-
-@ Translating a dash list into \ps\ is very similar to printing it symbolically
-in |print_edges|. A dash pattern with |dash_y(hh)=0| has length zero and is
-ignored. The same fate applies in the bizarre case of a dash pattern that
-cannot be printed without overflow.
-
-@<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>=
-begin gs_dash_p:=hh;
-gs_dash_sc:=scf;
-if (dash_y(hh)=0) or (abs(dash_y(hh)) div unity >= el_gordo div scf) then
- ps_print_cmd(" [] 0 setdash"," rd")
-else begin pp:=dash_list(hh);
- start_x(null_dash):=start_x(pp)+dash_y(hh);@/
- ps_room(28);
- print(" [");
- while pp<>null_dash do
- begin ps_pair_out(take_scaled(stop_x(pp)-start_x(pp),scf),@|
- take_scaled(start_x(link(pp))-stop_x(pp),scf));
- pp:=link(pp);
- end;
- ps_room(22);
- print("] ");
- print_scaled(take_scaled(dash_offset(hh),scf));
- print_cmd(" setdash"," sd");
- end;
-end
-
-@ @<Declare subroutines needed by |fix_graphics_state|@>=
-function same_dashes(@!h,@!hh:pointer):boolean;
- {do |h| and |hh| represent the same dash pattern?}
-label done;
-var @!p,@!pp:pointer; {dash nodes being compared}
-begin if h=hh then same_dashes:=true
-else if (h<=void)or(hh<=void) then same_dashes:=false
-else if dash_y(h)<>dash_y(hh) then same_dashes:=false
-else @<Compare |dash_list(h)| and |dash_list(hh)|@>;
-end;
-
-@ @<Compare |dash_list(h)| and |dash_list(hh)|@>=
-begin p:=dash_list(h);
-pp:=dash_list(hh);
-while (p<>null_dash)and(pp<>null_dash) do
- if (start_x(p)<>start_x(pp))or(stop_x(p)<>stop_x(pp)) then goto done
- else begin p:=link(p);
- pp:=link(pp);
- end;
-done:same_dashes:=p=pp;
-end
-
-@ 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.
-
-@<Declare the \ps\ output procedures@>=
-procedure stroke_ellipse(@!h:pointer;@!fill_also:boolean);
- {generate an elliptical pen stroke from object |h|}
-var @!txx,@!txy,@!tyx,@!tyy:scaled; {transformation parameters}
-@!p:pointer; {the pen to stroke with}
-@!d1,@!det:scaled; {for tweaking transformation parameters}
-@!s:integer; {also for tweaking transformation paramters}
-@!transformed:boolean; {keeps track of whether gsave/grestore are needed}
-begin 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@>;
-ps_path_out(path_p(h));@/
-if internal[mpprocset]=0 then begin
- if fill_also then print_nl("gsave fill grestore");
- @<Issue \ps\ commands to transform the coordinate system@>;
- ps_print(" stroke");
- if transformed then ps_print(" grestore");
- end
-else begin
- if fill_also then print_nl("B") else print_ln;
- if (txy<>0)or(tyx<>0) then
- begin
- print(" [");
- ps_pair_out(txx,tyx);
- ps_pair_out(txy,tyy);@/
- ps_print("0 0] t");
- end
- else if (txx<>unity)or(tyy<>unity) then
- begin
- ps_pair_out(txx,tyy);
- print(" s");
- end;
- ps_print(" S");
- if transformed then ps_print(" Q");
-end;
-print_ln;
-end;
-
-@ @<Use |pen_p(h)| to set the transformation parameters and give the...@>=
-p:=pen_p(h);
-txx:=left_x(p);
-tyx:=left_y(p);@/
-txy:=right_x(p);
-tyy:=right_y(p);
-if (x_coord(p)<>0)or(y_coord(p)<>0) then
- begin print_nl(""); print_cmd("gsave ","q ");
- ps_pair_out(x_coord(p),y_coord(p));
- ps_print("translate ");@/
- txx:=txx-x_coord(p);
- tyx:=tyx-y_coord(p);@/
- txy:=txy-x_coord(p);
- tyy:=tyy-y_coord(p);
- transformed:=true;
- end
-else print_nl("");
-@<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 then
- if gs_width=0 then
- begin txx:=unity; tyy:=unity;
- end
- else begin txx:=make_scaled(txx,gs_width);
- txy:=make_scaled(txy,gs_width);
- tyx:=make_scaled(tyx,gs_width);
- tyy:=make_scaled(tyy,gs_width);
- end;
-if (txy<>0)or(tyx<>0)or(txx<>unity)or(tyy<>unity) then
- if (not transformed) then
- begin ps_print_cmd("gsave ","q ");
- transformed:=true;
- end
-
-@ @<Issue \ps\ commands to transform the coordinate system@>=
-if (txy<>0)or(tyx<>0) then
- begin print_ln;
- print_char("[");
- ps_pair_out(txx,tyx);
- ps_pair_out(txy,tyy);@/
- ps_print("0 0] concat");
- end
-else if (txx<>unity)or(tyy<>unity) then
- begin print_ln;
- ps_pair_out(txx,tyy);
- print("scale");
- end
-
-@ 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:=take_scaled(txx,tyy) - take_scaled(txy,tyx);
-d1:=4*aspect_bound+1;
-if abs(det)<d1 then
- begin if det>=0 then
- begin d1:=d1-det; s:=1; @+end
- else begin d1:=-d1-det; s:=-1; @+end;
- d1:=d1*unity;
- if abs(txx)+abs(tyy)>=abs(txy)+abs(tyy) then
- if abs(txx)>abs(tyy) then tyy:=tyy+(d1+s*abs(txx)) div txx
- else txx:=txx+(d1+s*abs(tyy)) div tyy
- else if abs(txy)>abs(tyx) then tyx:=tyx+(d1+s*abs(txy)) div txy
- else txy:=txy+(d1+s*abs(tyx)) div tyx;
- end
-
-@ Here is a simple routine that just fills a cycle.
-
-@<Declare the \ps\ output procedures@>=
-procedure ps_fill_out(@!p:pointer); {fill cyclic path~|p|}
-begin ps_path_out(p);
-ps_print_cmd(" fill"," F");
-print_ln;
-end;
-
-@ Given a cyclic path~|p| and a graphical object~|h|, the |do_outer_envelope|
-procedure fills the cycle generated by |make_envelope|. It need not do
-anything unless some region has positive winding number with respect to~|p|,
-but it does not seem worthwhile to for test this.
-
-@<Declare the \ps\ output procedures@>=
-procedure do_outer_envelope(@!p,@!h:pointer);
-begin p:=make_envelope(p, pen_p(h), ljoin_val(h), 0, miterlim_val(h));
-ps_fill_out(p);
-toss_knot_list(p);
-end;
-
-@ 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@>=
-function choose_scale(@!p:pointer):scaled; {|p| should point to a text node}
-var @!a,@!b,@!c,@!d,@!ad,@!bc:scaled; {temporary values}
-begin a:=txx_val(p);
-b:=txy_val(p);
-c:=tyx_val(p);
-d:=tyy_val(p);@/
-if (a<0) then negate(a);
-if (b<0) then negate(b);
-if (c<0) then negate(c);
-if (d<0) then negate(d);
-ad:=half(a-d);
-bc:=half(b-c);@/
-choose_scale:=pyth_add(pyth_add(d+ad,ad), pyth_add(c+bc,bc));
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-procedure ps_string_out(s:str_number);
-var @!i:pool_pointer; {current character code position}
-@!k:ASCII_code; {bits to be converted to octal}
-begin print("(");
-i:=str_start[s];
-while i<str_stop(s) do
- begin if ps_offset+5>max_print_line then
- begin print_char("\");
- print_ln;
- end;
- k:=so(str_pool[i]);
- if (@<Character |k| is not allowed in PostScript output@>) then
- begin print_char("\");
- print_char("0"+(k div 64));
- print_char("0"+((k div 8) mod 8));
- print_char("0"+(k mod 8));
- end
- else begin if (k="(")or(k=")")or(k="\") then print_char("\");
- print_char(k);
- end;
- incr(i);
- end;
-print(")");
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-function is_ps_name(@!s:str_number):boolean;
-label not_found,exit;
-var @!i:pool_pointer; {current character code position}
-@!k:ASCII_code; {the character being checked}
-begin i:=str_start[s];
-while i<str_stop(s) do
- begin k:=so(str_pool[i]);
- if (k<=" ")or(k>"~") then goto not_found;
- if (k="(")or(k=")")or(k="<")or(k=">")or@|
- (k="{")or(k="}")or(k="/")or(k="%") then goto not_found;
- incr(i);
- end;
-is_ps_name:=true;
-return;
-not_found:is_ps_name:=false;
-exit:end;
-
-@ @<Declare the \ps\ output procedures@>=
-procedure ps_name_out(@!s:str_number;@!lit:boolean);
-begin ps_room(length(s)+2);
-print_char(" ");
-if is_ps_name(s) then
- begin if lit then print_char("/");
- print(s);
- end
- else begin ps_string_out(s);
- if not lit then ps_print("cvx ");
- ps_print("cvn");
- end;
-end;
-
-@ 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|.
-
-@d unused=0
-@d used=1
-
-@ @<Declare the \ps\ output procedures@>=
-procedure unmark_font(@!f:font_number);
-var @!k:0..font_mem_size; {an index into |font_info|}
-begin for k:= char_base[f]+si(font_bc[f]) to char_base[f]+si(font_ec[f]) do
- font_info[k].qqqq.b3:=unused;
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-procedure mark_string_chars(@!f:font_number;@!s:str_number);
-var @!b:integer; {|char_base[f]|}
-@!bc,@!ec:pool_ASCII_code; {only characters between these bounds are marked}
-@!k:pool_pointer; {an index into string |s|}
-begin b:=char_base[f];
-bc:=si(font_bc[f]);
-ec:=si(font_ec[f]);@/
-k:=str_stop(s);
-while k>str_start[s] do
- begin decr(k);
- if (str_pool[k]>=bc)and(str_pool[k]<=ec) then
- font_info[b+str_pool[k]].qqqq.b3:=used;
- end
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-procedure hex_digit_out(@!d:small_number);
-begin if d<10 then print_char(d+"0")
-else print_char(d+"a"-10);
-end;
-
-@ 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.
-
-@<Declare the \ps\ output procedures@>=
-function ps_marks_out(@!f:font_number;@!c:eight_bits):halfword;
-var @!bc,@!ec:eight_bits; {only encode characters between these bounds}
-@!lim:integer; {the maximum number of marks to encode before truncating}
-@!p:0..font_mem_size; {|font_info| index for the current character}
-@!d,@!b:0..15; {used to construct a hexadecimal digit}
-begin lim:=4*(emergency_line_length-ps_offset-4);
-bc:=font_bc[f];
-ec:=font_ec[f];
-if c>bc then 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<font_ec[f])and(font_info[p].qqqq.b3=unused) do
- begin incr(p); incr(ec);
- end;
-ps_marks_out:=ec+1;
-end;
-
-@ 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:=char_base[f]+si(bc);
-while (font_info[p].qqqq.b3=unused)and(bc<ec) do
- begin incr(p); incr(bc);
- end;
-if ec>=bc+lim then ec:=bc+lim-1;
-p:=char_base[f]+si(ec);
-while (font_info[p].qqqq.b3=unused)and(bc<ec) do
- begin decr(p); decr(ec);
- end;
-
-@ @<Print the initial label indicating that the bitmap starts at |bc|@>=
-print_char(" ");
-hex_digit_out(bc div 16);
-hex_digit_out(bc mod 16);
-print_char(":")
-
-@ @<Print a hexadecimal encoding of the marks for characters |bc..ec|@>=
-b:=8; d:=0;
-for p:=char_base[f]+si(bc) to char_base[f]+si(ec) do
- begin if b=0 then
- begin hex_digit_out(d);
- d:=0; b:=8;
- end;
- if font_info[p].qqqq.b3<>unused then d:=d+b;
- b:=halfp(b);
- end;
-hex_digit_out(d)
-
-@ Here is a simple function that determines whether there are any marked
-characters in font~|f| with character code at least~|c|.
-
-@<Declare the \ps\ output procedures@>=
-function check_ps_marks(@!f:font_number; @!c:integer):boolean;
-label exit;
-var @!p:0..font_mem_size; {|font_info| index for the current character}
-begin for p:=char_base[f]+si(c) to char_base[f]+si(font_ec[f]) do
- if font_info[p].qqqq.b3=used then
- begin check_ps_marks:=true; return;
- end;
-check_ps_marks:=false;
-exit: end;
-
-@ 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 sc_factor(#)==mem[#+1].sc {the scale factor stored in a font size node}
-@d font_size_size=2 {size of a font size node}
-
-@<Glob...@>=
-font_sizes:array[font_number] of pointer;
-
-@ @d fscale_tolerance==65 {that's $.001\times2^{16}$}
-
-@<Declare the \ps\ output procedures@>=
-function size_index(@!f:font_number;@!s:scaled):quarterword;
-label found;
-var @!p,@!q:pointer; {the previous and current font size nodes}
-@!i:quarterword; {the size index for |q|}
-begin q:=font_sizes[f];
-i:=0;
-while q<>null do
- begin if abs(s-sc_factor(q))<=fscale_tolerance then goto found
- else begin p:=q; q:=link(q);
- incr(i);
- end;
- if i=max_quarterword then
- overflow("sizes per font",max_quarterword);
-@:MetaPost capacity exceeded sizes per font}{\quad sizes per font@>
- end;
-q:=get_node(font_size_size);
-sc_factor(q):=s;
-if i=0 then font_sizes[f]:=q @+else link(p):=q;
-found:size_index:=i;
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-function indexed_size(@!f:font_number;@!j:quarterword):scaled;
-var @!p:pointer; {a font size node}
-@!i:quarterword; {the size index for |p|}
-begin p:=font_sizes[f];
-i:=0;
-if p=null then confusion("size");
-while (i<>j) do
- begin incr(i); p:=link(p);
- if p=null then confusion("size");
- end;
-indexed_size:=sc_factor(p);
-end;
-
-@ @<Declare the \ps\ output procedures@>=
-procedure clear_sizes;
-var @!f:font_number; {the font whose size list is being cleared}
-@!p:pointer; {current font size nodes}
-begin for f:=null_font+1 to last_fnum do
- while font_sizes[f]<>null do
- begin p:=font_sizes[f];
- font_sizes[f]:=link(p);
- free_node(p,font_size_size);
- end;
-end;
-
-@ 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...@>=
-@!last_pending:pointer; {the last token in a list of pending specials}
-
-@ @<Set init...@>=
-last_pending:=spec_head;
-
-@ @<Cases of |do_statement|...@>=
-special_command: if cur_mod=0 then do_special else if cur_mod=1 then do_mapfile else do_mapline;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-procedure do_special;
-begin get_x_next; scan_expression;
-if cur_type<>string_type then @<Complain about improper special operation@>
-else begin link(last_pending):=stash_cur_exp;
- last_pending:=link(last_pending);
- link(last_pending):=null;
- end;
-end;
-
-@ @<Complain about improper special operation@>=
-begin exp_err("Unsuitable expression");
-help1("Only known strings are allowed for output as specials.");
-put_get_error;
-end
-
-@ @<Print any pending specials@>=
-t:=link(spec_head);
-while t<>null do
- begin print(value(t));
- print_ln;
- t:=link(t);
- end;
-flush_token_list(link(spec_head));
-link(spec_head):=null;
-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@>=
-procedure ship_out(@!h:pointer); {output edge structure |h|}
-label done,done2,found,found2,found3;
-var @!p:pointer; {the current graphical object}
-@!q:pointer; {something that |p| points to}
-@!t:integer; {a temporary value}
-@!f,ff:font_number; {fonts used in a text node or as loop counters}
-@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)}
-@!done_fonts:boolean; {have we finished listing the fonts in the header?}
-@!next_size:quarterword; {the size index for fonts being listed}
-@!cur_fsize:array[font_number] of pointer; {current positions in |font_sizes|}
-@!ds,@!scf:scaled; {design size and scale factor for a text node}
-@!transformed:boolean; {is the coordinate system being transformed?}
-begin ldf:=null_font; open_output_file;
-non_ps_setting:=selector; selector:=ps_file_only;@/
-if (internal[prologues]=two)or(internal[prologues]=three) then begin
- @<Print improved initial comment and bounding box for edge structure~|h|@>;
- @<Scan all the text nodes and mark the used characters@>;
- mploadencodings(last_fnum);
- @<Update encoding names@>;
- @<Print the improved prologue and setup@>;
- @<Print any pending specials@>;
- unknown_graphics_state(0);
- need_newpath:=true;
- p:=link(dummy_loc(h));
- while p<>null do
- begin if has_color(p) then
- if (pre_script(p))<>null then begin
- print_nl (pre_script(p)); print_ln;
- end;
- fix_graphics_state(p);
- case type(p) of
- @<Cases for translating graphical object~|p| into \ps@>@;
- start_bounds_code,stop_bounds_code: do_nothing;
- end; {all cases are enumerated}
- p:=link(p);
- end;
- print_cmd("showpage","P"); print_ln;
- print("%%EOF"); print_ln;
- a_close(ps_file);
- selector:=non_ps_setting;
- if internal[prologues]<=0 then clear_sizes;
- @<End progress report@>;
- end
-else begin
-@<Print the initial comment and give the bounding box for edge structure~|h|@>;
-if (internal[prologues]>0) and (last_ps_fnum<last_fnum) then
- read_psname_table;
-print("%%BeginProlog"); print_ln;
-if (internal[prologues]>0)or(internal[mpprocset]>0) then @<Print the prologue@>;
-print("%%EndProlog");
-print_nl("%%Page: 1 1"); print_ln;
-@<Print any pending specials@>;
-unknown_graphics_state(0);
-need_newpath:=true;
-p:=link(dummy_loc(h));
-while p<>null do
- begin if has_color(p) then
- if (pre_script(p))<>null then begin
- print_nl (pre_script(p)); print_ln;
- end;
- fix_graphics_state(p);
- case type(p) of
- @<Cases for translating graphical object~|p| into \ps@>@;
- start_bounds_code,stop_bounds_code: do_nothing;
- end; {all cases are enumerated}
- p:=link(p);
- end;
-print_cmd("showpage","P"); print_ln;
-print("%%EOF"); print_ln;
-a_close(ps_file);
-selector:=non_ps_setting;
-if internal[prologues]<=0 then clear_sizes;
-@<End progress report@>;
-end;
-if internal[tracing_output]>0 then print_edges(h," (just shipped out)",true);
-end;
-
-@ @<Print the procset@>=
- begin
- print_nl("/hlw{0 dtransform exch truncate exch idtransform pop setlinewidth}bd");
- print_nl("/vlw{0 exch dtransform truncate idtransform setlinewidth pop}bd");
- print_nl("/l{lineto}bd/r{rlineto}bd/c{curveto}bd/m{moveto}bd/p{closepath}bd/n{newpath}bd");
- print_nl("/C{setcmykcolor}bd/G{setgray}bd/R{setrgbcolor}bd/lj{setlinejoin}bd/ml{setmiterlimit}bd");
- print_nl("/lc{setlinecap}bd/S{stroke}bd/F{fill}bd/q{gsave}bd/Q{grestore}bd/s{scale}bd/t{concat}bd");
- print_nl("/sd{setdash}bd/rd{[] 0 setdash}bd/P{showpage}bd/B{q F Q}bd/W{clip}bd");
- end
-
-
-@
-@d applied_reencoding(#)==((font_is_reencoded(#))and
- ((not font_is_subsetted(#))or(internal[prologues]=two)))
-
-@d ps_print_defined_name(#)==ps_print(" /");
- if (font_is_subsetted(#))and(font_is_included(#))and(internal[prologues]=three)
- then print(fm_font_subset_name(#))
- else print(font_ps_name[#]);
- if str_vs_str(font_name[#],"psyrgo")=0 then begin
- ps_print("-Slanted"); end;
- if str_vs_str(font_name[#],"zpzdr-reversed")=0 then begin
- ps_print("-Reverse"); end;
- if applied_reencoding(#) then begin ps_print("-");
- ps_print(font_enc_name[#]); end;
- if fm_font_slant(#)<>0 then begin
- ps_print("-Slant_"); print_int(fm_font_slant(#)) end;
- if fm_font_extend(#)<>0 then begin
- ps_print("-Extend_"); print_int(fm_font_extend(#)) end
-
-@<Print the improved prologue and setup@>=
-begin
- list_used_resources;
- list_supplied_resources;
- list_needed_resources;
- print_nl("%%EndComments");
- print_nl("%%BeginProlog");
- if internal[mpprocset]>0 then
- print_nl("%%BeginResource: procset mpost")
- else
- print_nl("%%BeginResource: procset mpost-minimal");
- print_nl("/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd");
- if internal[mpprocset]>0 then @<Print the procset@>;
- print_nl("/fcp{findfont dup length dict begin{1 index/FID ne{def}{pop pop}ifelse}forall}bd");
- print_nl("/fmc{FontMatrix dup length array copy dup dup}bd/fmd{/FontMatrix exch def}bd");
- print_nl("/Amul{4 -1 roll exch mul 1000 div}bd/ExtendFont{fmc 0 get Amul 0 exch put fmd}bd");
- if internal[gtroffmode]>0 then begin
- print_nl("/ScaleFont{dup fmc 0 get Amul 0 exch put dup dup 3 get Amul 3 exch put fmd}bd");
- end;
- print_nl("/SlantFont{fmc 2 get dup 0 eq{pop 1}if Amul FontMatrix 0 get mul 2 exch put fmd}bd");
- print_nl("%%EndResource");
- @<Include encodings and fonts for edge structure~|h|@>;
- print_nl("%%EndProlog");
- print_nl("%%BeginSetup");
- print_ln;
- for f:=null_font+1 to last_fnum do begin
- if font_sizes[f]<>null then begin
- if hasfmentry(f) then begin
- @<Write font definition@>;
- ps_name_out(font_name[f],true);
- ps_print_defined_name(f);
- ps_print(" def");
- end
- else begin
- begin_diagnostic;
- if selector=log_only then incr(selector);
- print_err("Warning: font ");
- print(font_name[f]);
- print(" cannot be found in any fontmapfile!");
- end_diagnostic(true);
- ps_name_out(font_name[f],true);
- ps_name_out(font_name[f],true);
- ps_print(" def");
- end;
- print_ln;
- end;
- end;
- print_nl("%%EndSetup");
- print_nl("%%Page: 1 1");
- print_ln;
-end
-
-@ @<Write font definition@>=
-if (applied_reencoding(f))or(fm_font_slant(f)<>0)or(fm_font_extend(f)<>0)or@|
- (str_vs_str(font_name[f],"psyrgo")=0)or(str_vs_str(font_name[f],"zpzdr-reversed")=0) then begin
- if (font_is_subsetted(f))and(font_is_included(f))and(internal[prologues]=three)
- then ps_name_out(fm_font_subset_name(f),true)
- else ps_name_out(font_ps_name[f],true);
- ps_print(" fcp");
- print_ln;
- if applied_reencoding(f) then begin
- ps_print("/Encoding ");
- ps_print(font_enc_name[f]);
- ps_print(" def ");
- end;
- if fm_font_slant(f)<>0 then begin
- print_int(fm_font_slant(f));
- ps_print(" SlantFont ");
- end;
- if fm_font_extend(f)<>0 then begin
- print_int(fm_font_extend(f));
- ps_print(" ExtendFont ");
- end;
- if str_vs_str(font_name[f],"psyrgo")=0 then begin
- ps_print(" 890 ScaleFont ");
- ps_print(" 277 SlantFont ");
- end;
- if str_vs_str(font_name[f],"zpzdr-reversed")=0 then begin
- ps_print(" FontMatrix [-1 0 0 1 0 0] matrix concatmatrix /FontMatrix exch def ");
- ps_print("/Metrics 2 dict dup begin ");
- ps_print("/space[0 -278]def ");
- ps_print("/a12[-904 -939]def ");
- ps_print("end def ");
- end; ps_print("currentdict end");
- print_ln;
- ps_print_defined_name(f);
- ps_print(" exch definefont pop");
- print_ln;
-end
-
-@ Included subset fonts do not need and encoding vector, make
-sure we skip that case.
-
-@p procedure list_used_resources;
-label found,found2;
-var @!f,ff:font_number; {fonts used in a text node or as loop counters}
-@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)}
-firstitem:boolean;
-begin
-if internal[mpprocset]>0 then
- print_nl("%%DocumentResources: procset mpost")
-else
- print_nl("%%DocumentResources: procset mpost-minimal");
-ldf:=null_font;
-firstitem:=true;
-for f:=null_font+1 to last_fnum do
- if (font_sizes[f]<>null)and(font_is_reencoded(f)) then
- begin
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_enc_name[f],font_enc_name[ff])=0 then
- goto found;
- if font_is_subsetted(f) then
- goto found;
- if ps_offset+1+length(font_enc_name[f])>max_print_line then
- print_nl("%%+ encoding");
- if firstitem then begin
- firstitem:=false;
- print_nl("%%+ encoding");
- end;
- print_char(" ");
- print(font_enc_name[f]);
- ldf:=f;
- found:
- end;
-ldf:=null_font;
-firstitem:=true;
-for f:=null_font+1 to last_fnum do
- if font_sizes[f]<>null then
- begin
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_name[f],font_name[ff])=0 then
- goto found2;
- if ps_offset+1+length(font_ps_name[f])>max_print_line then
- print_nl("%%+ font");
- if firstitem then begin
- firstitem:=false;
- print_nl("%%+ font");
- end;
- print_char(" ");
- if (internal[prologues]=three)and(font_is_subsetted(f)) then
- print(fm_font_subset_name(f))
- else
- print(font_ps_name[f]);
- ldf:=f;
- found2:
- end;
-print_ln;
-end;
-
-@
-@p procedure list_supplied_resources;
-label found,found2;
-var @!f,ff:font_number; {fonts used in a text node or as loop counters}
-@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)}
-firstitem:boolean;
-begin
-if internal[mpprocset]>0 then
- print_nl("%%DocumentSuppliedResources: procset mpost")
-else
- print_nl("%%DocumentSuppliedResources: procset mpost-minimal");
-ldf:=null_font;
-firstitem:=true;
-for f:=null_font+1 to last_fnum do
- if (font_sizes[f]<>null)and(font_is_reencoded(f)) then
- begin
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_enc_name[f],font_enc_name[ff])=0 then
- goto found;
- if (internal[prologues]=three)and(font_is_subsetted(f))then
- goto found;
- if ps_offset+1+length(font_enc_name[f])>max_print_line then
- print_nl("%%+ encoding");
- if firstitem then begin
- firstitem:=false;
- print_nl("%%+ encoding");
- end;
- print_char(" ");
- print(font_enc_name[f]);
- ldf:=f;
- found:
- end;
-ldf:=null_font;
-firstitem:=true;
-if internal[prologues]=three then begin
- for f:=null_font+1 to last_fnum do
- if font_sizes[f]<>null then
- begin
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_name[f],font_name[ff])=0 then
- goto found2;
- if not font_is_included(f) then
- goto found2;
- if ps_offset+1+length(font_ps_name[f])>max_print_line then
- print_nl("%%+ font");
- if firstitem then begin
- firstitem:=false;
- print_nl("%%+ font");
- end;
- print_char(" ");
- if font_is_subsetted(f) then
- print(fm_font_subset_name(f))
- else
- print(font_ps_name[f]);
- ldf:=f;
- found2:
- end;
- print_ln;
-end;
-end;
-
-
-@
-@p procedure list_needed_resources;
-label found,found2;
-var @!f,ff:font_number; {fonts used in a text node or as loop counters}
-@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)}
-firstitem:boolean;
-begin
-ldf:=null_font;
-firstitem:=true;
-for f:=null_font+1 to last_fnum do
- if font_sizes[f]<>null then
- begin
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_name[f],font_name[ff])=0 then
- goto found;
- if(internal[prologues]=three)and(font_is_included(f)) then
- goto found;
- if ps_offset+1+length(font_ps_name[f])>max_print_line then
- print_nl("%%+ font");
- if firstitem then begin
- firstitem:=false;
- print_nl("%%DocumentNeededResources: font");
- end;
- print_char(" ");
- print(font_ps_name[f]);
- ldf:=f;
- found:
- end;
-if not firstitem then begin
- print_ln;
- ldf:=null_font;
- firstitem:=true;
- for f:=null_font+1 to last_fnum do
- if font_sizes[f]<>null then
- begin
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_name[f],font_name[ff])=0 then
- goto found2;
- if(internal[prologues]=three)and(font_is_included(f)) then
- goto found2;
- print("%%IncludeResource: font ");
- print(font_ps_name[f]);
- print_ln;
- ldf:=f;
- found2:
- end;
-end;
-end;
-
-@
-@<Print improved initial comment and bounding box for edge...@>=
-print("%!PS-Adobe-3.0 EPSF-3.0");
-print_nl("%%BoundingBox: ");
-set_bbox(h,true);
-if minx_val(h)>maxx_val(h) then print("0 0 0 0")
-else begin ps_pair_out(floor_scaled(minx_val(h)),floor_scaled(miny_val(h)));
- ps_pair_out(-floor_scaled(-maxx_val(h)),-floor_scaled(-maxy_val(h)));
- end;
-print_nl("%%HiResBoundingBox: ");
-if minx_val(h)>maxx_val(h) then print("0 0 0 0")
-else begin
- ps_pair_out(minx_val(h),miny_val(h));
- ps_pair_out(maxx_val(h),maxy_val(h));
- end;
-print_nl("%%Creator: MetaPost ");
-print(metapost_version);
-print_nl("%%CreationDate: ");
-print_int(round_unscaled(internal[year])); print_char(".");
-print_dd(round_unscaled(internal[month])); print_char(".");
-print_dd(round_unscaled(internal[day])); print_char(":");@/
-t:=round_unscaled(internal[time]);
-print_dd(t div 60); print_dd(t mod 60);@/
-print_nl("%%Pages: 1");@/
-
-@
-
-@ @<Include encodings and fonts for edge structure~|h|@>=
-mpfontencodings(last_fnum,(internal[prologues]=two));
-@<Embed fonts that are available@>
-
-@ @<Scan all the text nodes and mark the used ...@>=
-for f:=null_font+1 to last_fnum do begin
- if font_sizes[f]<>null then begin
- unmark_font(f);
- font_sizes[f]:=null;
- end;
- if font_enc_name[f]<>0 then
- delete_str_ref(font_enc_name[f]);
- font_enc_name[f] := 0;
-end;
-for f:=null_font+1 to last_fnum do begin
- p:=link(dummy_loc(h));
- while p<>null do
- begin if type(p)=text_code then
- if font_n(p)<>null_font then begin
- font_sizes[font_n(p)] := void;
- mark_string_chars(font_n(p),text_p(p));
- if hasfmentry(font_n(p)) then
- font_ps_name[font_n(p)] := fm_font_name(font_n(p));
- end;
- p:=link(p);
- end;
-end
-
-@ @<Update encoding names@>=
-for f:=null_font+1 to last_fnum do begin
- p:=link(dummy_loc(h));
- while p<>null do
- begin if type(p)=text_code then
- if font_n(p)<>null_font then
- if hasfmentry(font_n(p)) then
- if font_enc_name[font_n(p)]=0 then
- font_enc_name[font_n(p)] := fm_encoding_name(font_n(p));
- p:=link(p);
- end;
-end
-
-@ @<Embed fonts that are available@>=
-begin next_size:=0;
-@<Make |cur_fsize| a copy of the |font_sizes| array@>;
-repeat done_fonts:=true;
-for f:=null_font+1 to last_fnum do
- begin if cur_fsize[f]<>null then begin
- if internal[prologues]=three then
- if not dopsfont(f) then
- if hasfmentry(f) then begin
- print_err("Font embedding failed");
- error;
- end;
- cur_fsize[f]:=link(cur_fsize[f]);
- if cur_fsize[f]<>null then
- begin unmark_font(f); done_fonts:=false; @+end
- end;
- end;
- if not done_fonts then
- @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
- that size index@>;
- until done_fonts;
-end
-
-
-@ 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 |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}.)
-
-@<Print the initial comment and give the bounding box for edge...@>=
-print("%!PS");
-if internal[prologues]>0 then print("-Adobe-3.0 EPSF-3.0");
-print_nl("%%BoundingBox: ");
-set_bbox(h,true);
-if minx_val(h)>maxx_val(h) then print("0 0 0 0")
-else if internal[prologues]<0 then
- begin ps_pair_out(minx_val(h),miny_val(h));
- ps_pair_out(maxx_val(h),maxy_val(h));
- end
-else begin ps_pair_out(floor_scaled(minx_val(h)),floor_scaled(miny_val(h)));
- ps_pair_out(-floor_scaled(-maxx_val(h)),-floor_scaled(-maxy_val(h)));
- end;
-print_nl("%%HiResBoundingBox: ");
-if minx_val(h)>maxx_val(h) then print("0 0 0 0")
-else begin
- ps_pair_out(minx_val(h),miny_val(h));
- ps_pair_out(maxx_val(h),maxy_val(h));
- end;
-print_nl("%%Creator: MetaPost ");
-print(metapost_version);
-print_nl("%%CreationDate: ");
-print_int(round_unscaled(internal[year])); print_char(".");
-print_dd(round_unscaled(internal[month])); print_char(".");
-print_dd(round_unscaled(internal[day])); print_char(":");@/
-t:=round_unscaled(internal[time]);
-print_dd(t div 60); print_dd(t mod 60);@/
-print_nl("%%Pages: 1");@/
-@<List all the fonts and magnifications for edge structure~|h|@>;
-print_ln
-
-@ @<List all the fonts and magnifications for edge structure~|h|@>=
-@<Scan all the text nodes and set the |font_sizes| lists;
- if |internal[prologues]<=0| list the sizes selected by |choose_scale|,
- apply |unmark_font| to each font encountered, and call |mark_string|
- whenever the size index is zero@>;
-if internal[prologues]>0 then
- @<Give a \.{DocumentFonts} comment listing all fonts with non-null
- |font_sizes| and eliminate duplicates@>
-else begin next_size:=0;
- @<Make |cur_fsize| a copy of the |font_sizes| array@>;
- repeat done_fonts:=true;
- for f:=null_font+1 to last_fnum do
- begin if cur_fsize[f]<>null then
- @<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>;
- if cur_fsize[f]<>null then
- begin unmark_font(f); done_fonts:=false; @+end;
- end;
- if not done_fonts then
- @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
- that size index@>;
- until done_fonts;
- end
-
-@ @<Make |cur_fsize| a copy of the |font_sizes| array@>=
-for f:=null_font+1 to last_fnum do
- cur_fsize[f]:=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...@>=
-begin ldf:=null_font;
-for f:=null_font+1 to last_fnum do
- if font_sizes[f]<>null then
- begin if ldf=null_font then print_nl("%%DocumentFonts:");
- for ff:=ldf downto null_font do
- if font_sizes[ff]<>null then
- if str_vs_str(font_ps_name[f],font_ps_name[ff])=0 then
- goto found;
- if ps_offset+1+length(font_ps_name[f])>max_print_line then
- print_nl("%%+");
- print_char(" ");
- print(font_ps_name[f]);
- ldf:=f;
- found:
- end;
-end
-
-@ @<Scan all the text nodes and set the |font_sizes| lists;...@>=
-for f:=null_font+1 to last_fnum do font_sizes[f]:=null;
-p:=link(dummy_loc(h));
-while p<>null do
- begin if type(p)=text_code then
- if font_n(p)<>null_font then
- begin f:=font_n(p);
- if internal[prologues]>0 then font_sizes[f]:=void
- else begin if font_sizes[f]=null then unmark_font(f);
- name_type(p):=size_index(f,choose_scale(p));
- if name_type(p)=0 then
- mark_string_chars(f,text_p(p));
- end;
- end;
- p:=link(p);
- end
-
-@ 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|.
-
-@<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>=
-begin t:=0;
-while check_ps_marks(f,t) do
- begin print_nl("%*Font: ");
- if ps_offset+length(font_name[f])+12>emergency_line_length then
- goto done;
- print(font_name[f]);
- print_char(" ");
- ds:=(font_dsize[f] + 8) div 16;
- print_scaled(take_scaled(ds,sc_factor(cur_fsize[f])));
- if ps_offset+12>emergency_line_length then goto done;
- print_char(" ");
- print_scaled(ds);
- if ps_offset+5>emergency_line_length then goto done;
- t:=ps_marks_out(f,t);
- end;
-done:
-cur_fsize[f]:=link(cur_fsize[f]);
-end
-
-@ @<Increment |next_size| and apply |mark_string_chars| to all text nodes...@>=
-begin incr(next_size);
-p:=link(dummy_loc(h));
-while p<>null do
- begin if type(p)=text_code then
- if font_n(p)<>null_font then
- if name_type(p)=next_size then
- mark_string_chars(font_n(p),text_p(p));
- p:=link(p);
- end;
-end
-
-@ 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@>
-
-@<Print the prologue@>=
-begin
-if ldf<>null_font then begin
- if internal[prologues]>0 then begin
- for f:=null_font+1 to last_fnum do
- if font_sizes[f]<>null then
- begin ps_name_out(font_name[f],true);
- ps_name_out(font_ps_name[f],true);
- ps_print(" def");
- print_ln;
- end;
- if internal[mpprocset]=0 then begin
- print("/fshow {exch findfont exch scalefont setfont show}bind def");
- print_ln;
- end;
- end;
- end;
-if internal[mpprocset]>0 then begin
- print_nl("%%BeginResource: procset mpost");
- if (internal[prologues]>0)and(ldf<>null_font) then
- print_nl("/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd")
- else
- print_nl("/bd{bind def}bind def");
- @<Print the procset@>;
- print_nl("%%EndResource");
- print_ln;
- end;
-end
-
-@ @<Cases for translating graphical object~|p| into \ps@>=
-start_clip_code:begin print_nl(""); print_cmd("gsave ","q ");
- ps_path_out(path_p(p));
- ps_print_cmd(" clip"," W");
- print_ln;
- if internal[restore_clip_color]>0 then
- unknown_graphics_state(1);
- end;
-stop_clip_code:begin print_nl(""); print_cmd("grestore","Q");
- print_ln;
- if internal[restore_clip_color]>0 then
- unknown_graphics_state(2)
- else
- unknown_graphics_state(-1);
- end;
-
-@ @<Cases for translating graphical object~|p| into \ps@>=
-fill_code: begin
- if pen_p(p)=null then ps_fill_out(path_p(p))
- else if pen_is_elliptical(pen_p(p)) then stroke_ellipse(p,true)
- else begin do_outer_envelope(copy_path(path_p(p)), p);
- do_outer_envelope(htap_ypoc(path_p(p)), p);
- end;
- if (post_script(p))<>null then begin
- print_nl (post_script(p)); print_ln;
- end;
- end;
-stroked_code: begin
- if pen_is_elliptical(pen_p(p)) then stroke_ellipse(p,false)
- else begin q:=copy_path(path_p(p));
- t:=lcap_val(p);
- @<Break the cycle and set |t:=1| if path |q| is cyclic@>;
- q:=make_envelope(q,pen_p(p),ljoin_val(p),t,miterlim_val(p));
- ps_fill_out(q);
- toss_knot_list(q);
- end;
- if (post_script(p))<>null then begin
- print_nl (post_script(p)); print_ln;
- end;
- end;
-
-@ 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 left_type(q)<>endpoint then
- begin left_type(insert_knot(q,x_coord(q),y_coord(q))):=endpoint;
- right_type(q):=endpoint;
- q:=link(q);
- t:=1;
- end
-
-@ @<Cases for translating graphical object~|p| into \ps@>=
-text_code: begin
- if (font_n(p)<>null_font) and (length(text_p(p))>0) then
- begin if internal[prologues]>0 then
- scf:=choose_scale(p)
- else scf:=indexed_size(font_n(p), 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@>;
- ps_string_out(text_p(p));
- ps_name_out(font_name[font_n(p)],false);
- @<Print the size information and \ps\ commands for text node~|p|@>;
- print_ln;
- end;
- if (post_script(p))<>null then begin
- print_nl (post_script(p)); print_ln;
- end;
- end;
-
-@ @<Print the size information and \ps\ commands for text node~|p|@>=
-ps_room(18);
-print_char(" ");
-ds:=(font_dsize[font_n(p)]+8) div 16;
-print_scaled(take_scaled(ds,scf));
-print(" fshow");
-if transformed then ps_print_cmd(" grestore"," Q")
-
-@ @<Shift or transform as necessary before outputting text node~|p| at...@>=
-transformed:=(txx_val(p)<>scf)or(tyy_val(p)<>scf)or@|
- (txy_val(p)<>0)or(tyx_val(p)<>0);
-if transformed then
- begin print_cmd("gsave [", "q [");
- ps_pair_out(make_scaled(txx_val(p),scf),@|make_scaled(tyx_val(p),scf));
- ps_pair_out(make_scaled(txy_val(p),scf),@|make_scaled(tyy_val(p),scf));
- ps_pair_out(tx_val(p),ty_val(p));@/
- ps_print_cmd("] concat 0 0 moveto","] t 0 0 m");
- end
-else begin ps_pair_out(tx_val(p),ty_val(p));
- ps_print_cmd("moveto","m");
- end;
-print_ln
-
-@ 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@>=
-begin cur_exp:=round_unscaled(cur_exp) mod 256;
-if cur_exp<0 then cur_exp:=cur_exp+256;
-boolean_reset(char_exists[cur_exp]); cur_type:=boolean_type;
-end
-
-@* \[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, `\.{(preloaded 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...@>=
-@!mem_ident:str_number;
-
-@ @<Set init...@>=
-mem_ident:=0;
-
-@ @<Initialize table entries...@>=
-mem_ident:=" (INIMP)";
-
-@ @<Declare act...@>=
-@!init procedure store_mem_file;
-label done;
-var @!k:integer; {all-purpose index}
-@!p,@!q: pointer; {all-purpose pointers}
-@!x: integer; {something to dump}
-@!w: four_quarters; {four ASCII codes}
-@!s: str_number; {all-purpose string}
-begin @<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@>;
-end;
-tini
-
-@ 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(#)==begin wake_up_terminal;
- wterm_ln('---! Must increase the ',#);
-@.Must increase the x@>
- goto off_base;
- end
-
-@p @t\4@>@<Declare the function called |open_mem_file|@>@;
-function load_mem_file:boolean;
-label done,off_base,exit;
-var @!k:integer; {all-purpose index}
-@!p,@!q: pointer; {all-purpose pointers}
-@!x: integer; {something undumped}
-@!s: str_number; {some temporary string}
-@!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 and the hash table@>;
-@<Undump a few more things and the closing check word@>;
-load_mem_file:=true; return; {it worked!}
-off_base: wake_up_terminal;
- wterm_ln('(Fatal mem file error; I''m stymied)');
-@.Fatal mem file error@>
-load_mem_file:=false;
-exit:end;
-
-@ Mem files consist of |memory_word| items, and we use the following
-macros to dump words of different types:
-
-@d dump_wd(#)==begin mem_file^:=#; put(mem_file);@+end
-@d dump_int(#)==begin mem_file^.int:=#; put(mem_file);@+end
-@d dump_hh(#)==begin mem_file^.hh:=#; put(mem_file);@+end
-@d dump_qqqq(#)==begin mem_file^.qqqq:=#; put(mem_file);@+end
-
-@<Glob...@>=
-@!mem_file:word_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 undump_wd(#)==begin get(mem_file); #:=mem_file^;@+end
-@d undump_int(#)==begin get(mem_file); #:=mem_file^.int;@+end
-@d undump_hh(#)==begin get(mem_file); #:=mem_file^.hh;@+end
-@d undump_qqqq(#)==begin get(mem_file); #:=mem_file^.qqqq;@+end
-@d undump_end_end(#)==#:=x;@+end
-@d undump_end(#)==(x>#) then goto off_base@+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 off_base; 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(mem_min);@/
-dump_int(mem_top);@/
-dump_int(hash_size);@/
-dump_int(hash_prime);@/
-dump_int(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@>=
-x:=mem_file^.int;
-if x<>@$ then goto off_base; {check that strings are the same}
-undump_int(x);
-if x<>mem_min then goto off_base;
-undump_int(x);
-if x<>mem_top then goto off_base;
-undump_int(x);
-if x<>hash_size then goto off_base;
-undump_int(x);
-if x<>hash_prime then goto off_base;
-undump_int(x);
-if x<>max_in_open then goto off_base
-
-@ We do string pool compaction to avoid dumping unused strings.
-
-@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@>=
-do_compaction(pool_size);
-dump_int(pool_ptr);
-dump_int(max_str_ptr);
-dump_int(str_ptr);
-k:=0;
-while (next_str[k]=k+1) and (k<=max_str_ptr) do incr(k);
-dump_int(k);
-while k<=max_str_ptr do
- begin dump_int(next_str[k]); incr(k);
- end;
-k:=0;
-loop @+begin dump_int(str_start[k]);
- if k=str_ptr then goto done else k:=next_str[k];
- end;
-done: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("at most "); print_int(max_str_ptr);
-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-1)('max strings')(max_str_ptr);
-undump(0)(max_str_ptr)(str_ptr);
-undump(0)(max_str_ptr+1)(s);
-for k:=0 to s-1 do next_str[k]:=k+1;
-for k:=s to max_str_ptr do undump(s+1)(max_str_ptr+1)(next_str[k]);
-fixed_str_use:=0;
-k:=0;
-loop @+begin undump(0)(pool_ptr)(str_start[k]);
- if k=str_ptr then goto done;
- str_ref[k]:=max_str_ref;
- incr(fixed_str_use);
- last_fixed_str:=k; k:=next_str[k];
- end;
-done: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_use:=fixed_str_use; init_pool_ptr:=pool_ptr;
-max_pool_ptr:=pool_ptr;
-strs_used_up:=fixed_str_use;
-stat pool_in_use:=str_start[str_ptr]; strs_in_use:=fixed_str_use;
- max_pl_used:=pool_in_use; max_strs_used:=strs_in_use;@/
- pact_count:=0; pact_chars:=0; pact_strs:=0;
-tats
-
-@ 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@>=
-sort_avail; var_used:=0;
-dump_int(lo_mem_max); dump_int(rover);
-p:=mem_min; q:=rover; x:=0;
-repeat for k:=p to q+1 do dump_wd(mem[k]);
-x:=x+q+2-p; var_used:=var_used+q-p;
-p:=q+node_size(q); q:=rlink(q);
-until q=rover;
-var_used:=var_used+lo_mem_max-p; dyn_used:=mem_end+1-hi_mem_min;@/
-for k:=p to lo_mem_max do dump_wd(mem[k]);
-x:=x+lo_mem_max+1-p;
-dump_int(hi_mem_min); dump_int(avail);
-for k:=hi_mem_min to mem_end do dump_wd(mem[k]);
-x:=x+mem_end+1-hi_mem_min;
-p:=avail;
-while p<>null do
- begin decr(dyn_used); p:=link(p);
- end;
-dump_int(var_used); 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(lo_mem_stat_max+1000)(hi_mem_stat_min-1)(lo_mem_max);
-undump(lo_mem_stat_max+1)(lo_mem_max)(rover);
-p:=mem_min; q:=rover;
-repeat for k:=p to q+1 do undump_wd(mem[k]);
-p:=q+node_size(q);
-if (p>lo_mem_max)or((q>=rlink(q))and(rlink(q)<>rover)) then goto off_base;
-q:=rlink(q);
-until q=rover;
-for k:=p to lo_mem_max do undump_wd(mem[k]);
-undump(lo_mem_max+1)(hi_mem_stat_min)(hi_mem_min);
-undump(null)(mem_top)(avail); mem_end:=mem_top;
-for k:=hi_mem_min to mem_end do undump_wd(mem[k]);
-undump_int(var_used); undump_int(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(hash_used); st_count:=frozen_inaccessible-1-hash_used;
-for p:=1 to hash_used do if text(p)<>0 then
- begin dump_int(p); dump_hh(hash[p]); dump_hh(eqtb[p]); incr(st_count);
- end;
-for p:=hash_used+1 to hash_end do
- begin dump_hh(hash[p]); dump_hh(eqtb[p]);
- end;
-dump_int(st_count);@/
-print_ln; print_int(st_count); print(" symbolic tokens")
-
-@ @<Undump the table of equivalents and the hash table@>=
-undump(1)(frozen_inaccessible)(hash_used); p:=0;
-repeat undump(p+1)(hash_used)(p); undump_hh(hash[p]); undump_hh(eqtb[p]);
-until p=hash_used;
-for p:=hash_used+1 to hash_end do
- begin undump_hh(hash[p]); undump_hh(eqtb[p]);
- end;
-undump_int(st_count)
-
-@ We have already printed a lot of statistics, so we set |tracing_stats:=0|
-to prevent them appearing again.
-
-@<Dump a few more things and the closing check word@>=
-dump_int(int_ptr);
-for k:=1 to int_ptr do
- begin dump_int(internal[k]); dump_int(int_name[k]);
- end;
-dump_int(start_sym); dump_int(interaction); dump_int(mem_ident);
-dump_int(bg_loc); dump_int(eg_loc); dump_int(serial_no); dump_int(69073);
-internal[tracing_stats]:=0
-
-@ @<Undump a few more things and the closing check word@>=
-undump(max_given_internal)(max_internal)(int_ptr);
-for k:=1 to int_ptr do
- begin undump_int(internal[k]);
- undump(0)(str_ptr)(int_name[k]);
- end;
-undump(0)(frozen_inaccessible)(start_sym);
-undump(batch_mode)(error_stop_mode)(interaction);
-undump(0)(str_ptr)(mem_ident);
-undump(1)(hash_end)(bg_loc);
-undump(1)(hash_end)(eg_loc);
-undump_int(serial_no);@/
-undump_int(x);@+if (x<>69073)or eof(mem_file) then goto off_base
-
-@ @<Create the |mem_ident|...@>=
-selector:=new_string;
-print(" (preloaded mem="); print(job_name); print_char(" ");
-print_int(round_unscaled(internal[year]) mod 100); print_char(".");
-print_int(round_unscaled(internal[month])); print_char(".");
-print_int(round_unscaled(internal[day])); print_char(")");
-if interaction=batch_mode then selector:=log_only
-else selector:=term_and_log;
-str_room(1); mem_ident:=make_string; str_ref[mem_ident]:=max_str_ref;@/
-pack_job_name(mem_extension);
-while not w_open_out(mem_file) do
- prompt_file_name("mem file name",mem_extension);
-print_nl("Beginning to dump on file ");
-@.Beginning to dump...@>
-s:=w_make_name_string(mem_file);
-print(s); flush_string(s);
-print_nl(mem_ident)
-
-@ @<Close the mem file@>=
-w_close(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.
-
-@p @<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 \PASCAL\ object code, they also have
-a mem 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 \.{VIRMP} is first
-loaded.\quad(2)~After we have read in a mem file and initialized
-everything, we set |ready_already:=314159|.\quad(3)~Soon \.{VIRMP}
-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@>
-
-@<Glob...@>=
-@!ready_already:integer; {a sacrifice of purity for economy}
-
-@ Now this is really it: \MP\ 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_MP;
-@<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_tab; {initialize the tables}
-init_prim; {call |primitive| for each primitive}
-init_str_use:=str_ptr; init_pool_ptr:=pool_ptr;@/
-max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr;
-fix_date_and_time;
-tini@/
-ready_already:=314159;
-start_of_MP: @<Initialize the output routines@>;
-@<Get the first line of input and prepare to start@>;
-mp_init_map_file(troff_mode);
-setjobid(internal[year],internal[month],internal[day],internal[time]);
-history:=spotless; {ready to go!}
-if start_sym>0 then {insert the `\&{everyjob}' symbol}
- begin cur_sym:=start_sym; back_input;
- end;
-main_control; {come to life}
-final_cleanup; {prepare for death}
-end_of_MP: close_files_and_terminate;
-final_end: ready_already:=0;
-end.
-
-@ 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...@>=
-procedure close_files_and_terminate;
-var @!k:integer; {all-purpose index}
-@!lh:integer; {the length of the \.{TFM} header, in words}
-@!lk_offset:0..256; {extra words inserted at beginning of |lig_kern| array}
-@!p:pointer; {runs through a list of \.{TFM} dimensions}
-begin @<Close all open files in the |rd_file| and |wr_file| arrays@>;
-@!stat if internal[tracing_stats]>0 then
- @<Output statistics about this job@>;@;@+tats@/
-wake_up_terminal; @<Do all the finishing work on the \.{TFM} file@>;
-@<Explain what output files were written@>;
-if log_opened then
- begin wlog_cr;
- a_close(log_file); selector:=selector-2;
- if selector=term_only then
- begin print_nl("Transcript written on ");
-@.Transcript written...@>
- print(log_name); print_char(".");
- end;
- end;
-end;
-
-@ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
-for k:=0 to read_files-1 do
- if rd_fname[k]<>0 then a_close(rd_file[k]);
-for k:=0 to write_files-1 do
- if wr_fname[k]<>0 then a_close(wr_file[k])
-
-@ We want to produce a \.{TFM} file if and only if |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 internal[fontmaking]>0 then
- begin @<Make the dynamic memory into one big available node@>;
- @<Massage the \.{TFM} widths@>;
- fix_design_size; fix_check_sum;
- @<Massage the \.{TFM} heights, depths, and italic corrections@>;
- internal[fontmaking]:=0; {avoid loop in case of fatal error}
- @<Finish the \.{TFM} file@>;
- end
-
-@ @<Make the dynamic memory into one big available node@>=
-rover:=lo_mem_stat_max+1; link(rover):=empty_flag; lo_mem_max:=hi_mem_min-1;
-if lo_mem_max-rover>max_halfword then lo_mem_max:=max_halfword+rover;
-node_size(rover):=lo_mem_max-rover; llink(rover):=rover; rlink(rover):=rover;
-link(lo_mem_max):=null; info(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 log_opened then
- begin wlog_ln(' ');
- wlog_ln('Here is how much of MetaPost''s memory',' you used:');
-@.Here is how much...@>
- wlog(' ',max_strs_used-init_str_use:1,' string');
- if max_strs_used<>init_str_use+1 then wlog('s');
- wlog_ln(' out of ', max_strings-1-init_str_use:1);@/
- wlog_ln(' ',max_pl_used-init_pool_ptr:1,' string characters out of ',
- pool_size-init_pool_ptr:1);@/
- wlog_ln(' ',lo_mem_max-mem_min+mem_end-hi_mem_min+2:1,@|
- ' words of memory out of ',mem_end+1-mem_min:1);@/
- wlog_ln(' ',st_count:1,' symbolic tokens out of ',
- hash_size:1);@/
- wlog_ln(' ',max_in_stack:1,'i,',@|
- int_ptr:1,'n,',@|
- max_param_stack:1,'p,',@|
- max_buf_stack+1:1,'b stack positions out of ',@|
- stack_size:1,'i,',
- max_internal:1,'n,',
- param_size:1,'p,',
- buf_size:1,'b');
- wlog_ln(' ',pact_count:1,' string compactions (moved ',
- pact_chars:1,' characters, ',
- pact_strs:1,' strings)');
- end
-
-@ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
-been scanned.
-
-@<Last-minute...@>=
-procedure final_cleanup;
-label exit;
-var c:small_number; {0 for \&{end}, 1 for \&{dump}}
-begin c:=cur_mod;
-if job_name=0 then open_log_file;
-while input_ptr>0 do
- if token_state then end_token_list@+else end_file_reading;
-while loop_ptr<>null do stop_iteration;
-while open_parens>0 do
- begin print(" )"); decr(open_parens);
- end;
-while cond_ptr<>null do
- begin print_nl("(end occurred when ");@/
-@.end occurred...@>
- print_cmd_mod(fi_or_else,cur_if);
- {`\.{if}' or `\.{elseif}' or `\.{else}'}
- 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:=name_type(cond_ptr); cond_ptr:=link(cond_ptr);
- end;
-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 store_mem_file; return;@+tini@/
- print_nl("(dump is performed only by INIMP)"); return;
-@.dump...only by INIMP@>
- end;
-exit:end;
-
-@ @<Last-minute...@>=
-@!init procedure init_prim; {initialize all the primitives}
-begin
-@<Put each...@>;
-end;
-@#
-procedure init_tab; {initialize other tables}
-var @!k:integer; {all-purpose index}
-begin @<Initialize table entries (done by \.{INIMP} only)@>@;
-end;
-tini
-
-@ 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...@>=
-begin @<Initialize the input routines@>;
-if (mem_ident=0)or(buffer[loc]="&") then
- begin if mem_ident<>0 then initialize; {erase preloaded mem}
- if not open_mem_file then goto final_end;
- if not load_mem_file then
- begin w_close(mem_file); goto final_end;
- end;
- w_close(mem_file);
- while (loc<limit)and(buffer[loc]=" ") do incr(loc);
- end;
-buffer[limit]:="%";@/
-fix_date_and_time;@/
-sys_random_seed := (internal[time] div unity)+internal[day];@/
-init_randoms(sys_random_seed);@/
-@<Initialize the print |selector|...@>;
-if loc<limit then if buffer[loc]<>"\" then start_input; {\&{input} assumed}
-end
-
-@* \[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, 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 \MP\ 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: begin print_int(eq_type(n)); print_char(":"); print_int(equiv(n));
- end;
-5: print_variable_name(n);
-6: print_int(internal[n]);
-7: do_show_dependencies;
-9: show_token_list(n,null,100000,0);
-10: print(n);
-11: check_mem(n>0); {check wellformedness; print new busy locations if |n>0|}
-12: search_mem(n); {look for pointers to |n|}
-13: begin read(term_in,l); print_cmd_mod(n,l);
- end;
-14: for k:=0 to n do print(buffer[k]);
-15: panicking:=not panicking;
-
-
-@ \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<=" ")or(k>"~")
-
-@ Saving the filename template
-
-@<Save the filename template@>=
-begin if filename_template<>0 then delete_str_ref(filename_template);
-if length(cur_exp)=0 then filename_template:=0
-else begin filename_template:=cur_exp; add_str_ref(filename_template);
- end;
-end
-@* \[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/mplibdir/ChangeLog b/Build/source/texk/web2c/mplibdir/ChangeLog
index ed97ac67f76..58c2d5aa0c2 100644
--- a/Build/source/texk/web2c/mplibdir/ChangeLog
+++ b/Build/source/texk/web2c/mplibdir/ChangeLog
@@ -1,5 +1,10 @@
2009-05-25 Peter Breitenlohner <peb@mppmu.mpg.de>
+ * dvitomp.test (new): Shell script to test dvitomp.
+ * am/mplib.am: Added dvitomp.test.
+
+2009-05-25 Peter Breitenlohner <peb@mppmu.mpg.de>
+
* am/.am (install-exec-hook, uninstall-hook): new targets
to (un)install dvitomp symlink.
diff --git a/Build/source/texk/web2c/mplibdir/am/mplib.am b/Build/source/texk/web2c/mplibdir/am/mplib.am
index 891a9ef3fec..bdd46e7af0d 100644
--- a/Build/source/texk/web2c/mplibdir/am/mplib.am
+++ b/Build/source/texk/web2c/mplibdir/am/mplib.am
@@ -47,7 +47,7 @@ uninstall-hook::
## MetaPost Tests
##
-mp_tests = mplibdir/mptrap.test
+mp_tests = mplibdir/dvitomp.test mplibdir/mptrap.test
EXTRA_DIST += $(mp_tests)
@@ -58,6 +58,8 @@ endif MP
.PHONY: mptrap-clean
clean-local:: mptrap-clean
+## dvitomp.test
+DISTCLEANFILES += ptmr.mpx tests/xptmr.mpx tests/xstory.mpx
## mptrap.test
mptrap-clean:
rm -f mtrap.mp mtrap.mem trapf.tfm
diff --git a/Build/source/texk/web2c/dvitomp.test b/Build/source/texk/web2c/mplibdir/dvitomp.test
index 834c0f42c14..c2f91463f96 100755
--- a/Build/source/texk/web2c/dvitomp.test
+++ b/Build/source/texk/web2c/mplibdir/dvitomp.test
@@ -9,13 +9,13 @@ if tfmpath=`$KPSEWHICH cmbx10.tfm`; then
TEXMFCNF=$srcdir/../kpathsea \
TFMFONTS=`dirname $tfmpath` \
- ./dvitomp $srcdir/tests/story.dvi tests/xstory.mpx || exit 1
+ ./mpost --dvitomp $srcdir/tests/story.dvi tests/xstory.mpx || exit 1
fi
TEXMFCNF=$srcdir/../kpathsea \
TFMFONTS=$srcdir/tests \
VFFONTS=$srcdir/tests: \
- ./dvitomp $srcdir/tests/ptmr && \
+ ./mpost --dvitomp $srcdir/tests/ptmr ptmr.mpx && \
mv ptmr.mpx tests/xptmr.mpx || exit 1
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:43:28 +0000